;; -*- mode: emacs-lisp; coding: hebrew-iso-8bit-unix; -*-
;; ekregister.el --- modified register commands for Emacs at Simon & Wiesel.
;; Copyright (C) 1992-2000  Ehud karni <ehud@unix.simonwiesel.co.il>

;; This file is NOT part of GNU Emacs, distribution conditions below.
;;
;;              EHUD   KARNI            ינרק   דוהא
;;              Ben Gurion st'   14   ןוירוג ןב 'חר
;;              Kfar - Sava    44 257     אבס - רפכ
;;              ===================================
;;              <kehud@iname.com>  972-(0)9-7659599
;;              ===================================

;;     RCS: $Id: ekregister.el,v 1.103 2000/03/05 13:47:49 ehud Exp ehud $
;;
;;     LOG: $Log: ekregister.el,v $
;;  Revision 1.103  2000/03/05  13:47:49  ehud
;;  Comment headers changes (NOT GNU)  +  Add 'file-query type.
;;
;;  Revision 1.102  1998/03/15  16:21:54  ehud
;;  Last revision for 19.34
;;
;;  Revision 1.101  1996/02/19  10:49:04  ehud
;;  Emacs 19.30 version
;;
;;  Revision 1.100  1995/01/19  17:22:18  ehud
;;  SW initial version control for all el's

;;  This program is free software; you can redistribute it and/or modify
;;  it under the terms of the GNU General Public License as published by
;;  the Free Software Foundation; either version 2 of the License, or
;;  (at your option) any later version.
;;
;;  This program is distributed in the hope that it will be useful,
;;  but WITHOUT ANY WARRANTY; without even the implied warranty of
;;  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;  GNU General Public License for more details.
;;
;;  You should have received a copy of the GNU General Public License
;;  along with this program; if not, write to the Free Software
;;  Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA


(defcustom view-register-buffer "*Register Data*"
  "Buffer name for viewing registers, set to *Help* if you want it to be
the same as other help (e.g. describe-variable) functions."
 :type  'string
 :group 'Ehuds )

(defun add-text-to-register (register text &optional new)
  "Append to register REGISTER new TEXT (a string).
The register value must be empty or string.
Optional 3rd parameter NEW means ignore current content."
       (let ((old-v (if new ""
                            (get-register register))))
           (or old-v
               (setq old-v ""))                ;; set to empty string
           (or (stringp old-v)                 ;; must be string
               (error "Register %c type is not text" register))
           (set-register register (concat old-v text))))


(defun add-substring-to-register (register start end &optional new)
  "Append to register REGISTER new substring from START to END.
The register value must be empty or string.
Optional 4th parameter NEW means ignore current content."
       (add-text-to-register register
                             (buffer-substring start end)
                             new))

(defun add-buffer-name-to-register (register &optional new)
  "Add current buffer name to register REGISTER.
Use ??-to-register functions to enter data to the register"
  (interactive "cAdd current buffer name to register: ")
       (add-text-to-register register (buffer-name-not-mini) new))

(defun add-dir-name-to-register (register &optional new)
  "Add current directory name to register REGISTER.
Use ??-to-register functions to enter data to the register"
  (interactive "cAdd current directory name to register: ")
       (let* ((bfn (buffer-file-name (get-buffer (buffer-name-not-mini)))))
           (or bfn
                (error "Current buffer not visiting file"))
           (add-text-to-register register
                                 (file-name-directory bfn)
                                 new)))

(defun add-file-name-to-register (register &optional new)
  "Add current file name to register REGISTER.
Use ??-to-register functions to enter data to the register"
  (interactive "cAdd current file name to register: ")
       (let* ((bfn (buffer-file-name (get-buffer (buffer-name-not-mini)))))
           (or bfn
                (error "Current buffer not visiting file"))
           (add-text-to-register register
                                 (file-name-nondirectory bfn)
                                 new)))

(defun add-word-to-register (register &optional new)
  "Add current word to register REGISTER.
Use ??-to-register functions to enter data to the register"
  (interactive "cAdd current word to register: ")
       (let ((sv-pos (point))
             (beg (progn (forward-char 1)
                         (backward-to-non-blank)
                         (point)))
             (end (progn (re-search-forward "[^ \t\n][ \t\n]" (point-max) t)
                         (1- (point)))))
           (add-substring-to-register register beg end new)
           (goto-char sv-pos)))

(defun buffer-name-to-register (register)
  "Store current buffer name in register REGISTER.
Use add-??-to-register functions to add more data to the register"
  (interactive "cSave current buffer name in register: ")
       (add-buffer-name-to-register register t))

(defun dir-name-to-register (register)
  "Store current directory name in register REGISTER.
Use add-??-to-register functions to add more data to the register"
  (interactive "cSave current directory name in register: ")
       (add-dir-name-to-register register t))

(defun file-name-to-register (register)
  "Store current file name in register REGISTER.
Use add-??-to-register functions to add more data to the register"
  (interactive "cSave current file name in register: ")
       (add-file-name-to-register register t))

(defun word-to-register (register)
  "Store current word in register REGISTER.
Use add-??-to-register functions to add more data to the register"
  (interactive "cSave current word in register: ")
       (add-word-to-register register t))


(defun add-line-to-register (register &optional new)
  "Add current line to register REGISTER.
Use \\[line-to-register] to store a line in the register.
Optional 2nd parameter NEW means ignore current content."
  (interactive "cAdd line to register: ")
       (let ((sv-pos (point))
             (beg (progn (beginning-of-line) (point)))
             (end (progn (forward-line 1) (point))))
           (add-substring-to-register register beg end new)
           (goto-char sv-pos)))


(defun add-marked-to-register (register &optional new)
  "Add marked area (lines or characters) to register REGISTER.
Use \\[marked-to-register] to store any marked area to a register.
Optional 2nd parameter NEW means ignore current content."
  (interactive "cAdd marked area to register: ")
       (or (get-register register)     ;; if no current value
           (setq new t))               ;; set new to true
       (if (mark-exist-chk t)          ;; error if no mark
           (if (= type-mark-set 4)     ;; block mark ?
               (if new                 ;; ok only for new
                   (save-excursion
                       (mark-block-to-17 nil)
                       (set-register register (get-register 17)))
                   (error "You can not add block mark"))
               (save-window-excursion
                   (set-buffer (marker-buffer (car mark-1st)))
                   (add-substring-to-register register
                           (marker-position (car mark-1st))
                           (marker-position (car mark-2nd))
                           new )))))


(defun erase-register (register)
  "Erase register REGISTER (delete it from `register-alist')"
  (interactive "cRegister to be erased: ")
       (let ((rg-vl (assoc register register-alist)))
           (and rg-vl
               (setq register-alist (delq rg-vl register-alist)))))


(defun line-to-register (register)
  "Store current line in register REGISTER.
Use \\[add-line-to-register] or \\[add-marked-to-register]
to add more data to the register"
  (interactive "cSave line in register: ")
       (add-line-to-register register t))


(defun marked-to-register (register)
  "Store marked area (any mark) in register REGISTER.
Use \\[add-line-to-register] or \\[add-marked-to-register]
to add more data to the register"
  (interactive "cSave marked area in register: ")
       (add-marked-to-register register t))


(defun overlay-register (register)
  "Overlay register REGISTER (saved block mark)."
  (interactive "cOverlay block from register: ")
       (let ((pos (point))
             (col (column-no))
             (blk (get-register register))
             lns)
           (and (not (consp blk))
                (not (stringp (car blk)))
                (error "Register %c empty or its type is not block" register))
           (setq lns (length blk))
           (if (> lns 0)
               (forward-line (1- lns)))
           (goto-col (+ col (length (car blk))))
           (setq lns (point))
           (goto-char pos)
           (delete-rectangle pos lns)
           (insert-register register)))


(defun position-to-register (register)
  "Store current position in register REGISTER.
Use \\[jump-to-register] to go to the saved position"
  (interactive "ccurrent Postion to register: ")
       (set-register register (point-marker)))


(defun view-register-init ()
  "Init view register(s) temp buffer and set to it"
       (autoload 'swhelp-make-fonts "swhelp")
       (if faces-on
           (swhelp-make-fonts))
       (let ((buf (get-buffer view-register-buffer)))
           (if buf (kill-buffer buf))))

(defun view-all-registers ()
  "Display what is contained in all the registers"
  (interactive)
       (view-register-init)
       (if (car-safe register-alist)
           (with-output-to-temp-buffer view-register-buffer
               (let ((svbuf (buffer-name))
                     (char 0))
                   (set-buffer standard-output)
                   (while (< char 256)
                       (and (get-register char)
                            (view-1-register char))
                       (setq char (1+ char)))
                   (pop-to-buffer svbuf)))
           (message "No registers saved")))

(defun view-register (register)
  "Display what is contained in register REGISTER."
  (interactive "cDisplay register: ")
       (view-register-init)
       (with-output-to-temp-buffer view-register-buffer
           (let ((svbuf (buffer-name)))
               (set-buffer standard-output)
               (view-1-register register)
               (pop-to-buffer svbuf))))


(defun view-1-register (char) "view one register (internal function)"
       (let* ((val (get-register char))
              (cval (car-safe val))
             )
           (if (null val)
               (message "Register %s is empty" (single-key-description char))
           (progn
               (view-register-princ "Register " 'swhelp-font-02)
               (view-register-princ (single-key-description char) 'swhelp-font-05)
               (view-register-princ " contains " 'swhelp-font-02)
               (cond
                   ((integerp val)
                           (view-register-princ val 'swhelp-font-03)
                           (princ " (an integer)"))
                   ((markerp val)
                           (let ((buf (marker-buffer val)))
                               (if (null buf)
                                   (progn
                                       (view-register-princ "a marker in no buffer" 'swhelp-font-01))
                                   (progn
                                       (view-register-princ "a buffer position:" 'swhelp-font-01)
                                       (princ "\nbuffer ")
                                       (view-register-princ (buffer-name buf) 'swhelp-font-03)
                                       (princ ", position ")
                                       (view-register-princ (marker-position val) 'swhelp-font-03)))))
                   ((window-configuration-p cval)
                           (view-register-princ "a window configuration:" 'swhelp-font-12)
                           (terpri)
                           (view-register-princ val 'swhelp-font-07))
                   ((frame-configuration-p cval)
                           (view-register-princ "a frame configuration:" 'swhelp-font-12)
                           (terpri)
                           (view-register-princ val 'swhelp-font-07))
                   ((stringp cval)
                           (view-register-princ "the block:" 'swhelp-font-19)
                           (while val
                               (terpri)
                               (view-register-princ (car val) 'swhelp-font-08)
                               (setq val (cdr val))))
                   ((eq cval 'file)
                           (view-register-princ "the file " 'swhelp-font-01)
                           (view-register-prin1 (cdr val) 'swhelp-font-03)
                           (princ "."))
                   ((eq cval 'file-query)
                           (view-register-princ "a file position (query):" 'swhelp-font-01)
                           (princ "\nfile ")
                           (view-register-princ (nth 1 val) 'swhelp-font-03)
                           (princ ", position ")
                           (view-register-princ (nth 2 val) 'swhelp-font-03))
                   ((stringp val)
                           (view-register-princ "the text:" 'swhelp-font-17)
                           (terpri)
                           (view-register-princ val 'swhelp-font-08))
                   (t
                           (view-register-princ "Garbage:" 'swhelp-font-19)
                           (terpri)
                           (view-register-prin1 val 'swhelp-font-15)))
               (terpri)
               (terpri)))))


(defun view-register-princ (val face)
  "Internal ekregister function. princ it's VAL and set it face to FACE"
       (let ((p1 (point)))
           (princ val)
           (view-register-ptp p1 (point) face)))


(defun view-register-prin1 (val face)
  "Internal ekregister function. princ it's VAL and set it face to FACE"
       (let ((p1 (point)))
           (prin1 val)
           (view-register-ptp p1 (point) face)))


(defun view-register-ptp (beg end face &optional object)
  "Internal ekregister function. Set face property only for X / pseudo X"
       (if faces-on
           (put-text-property beg end 'face face object)))

(defun register-map-help () (interactive)
    (describe-bindings-map "register-prefix-map" "register operations" "Alt-R"))
(defvar register-prefix-map (make-sparse-keymap) "Map for register operatrions (SW)")

(fset  'Alt-R  register-prefix-map)            ;register operation map
(define-key  register-prefix-map  alted-key-prefix  register-prefix-map)
(define-key register-prefix-map   "?"  'register-map-help)                 ;help for this map
(define-key register-prefix-map   "W"  'add-word-to-register)              ;add current word to register
(define-key register-prefix-map   "M"  'add-marked-to-register)            ;add marked area to register (according to type)
(define-key register-prefix-map   "L"  'add-line-to-register)              ;add current line to register
(define-key register-prefix-map   "F"  'add-file-name-to-register)         ;add buffer file name to register
(define-key register-prefix-map   "D"  'add-dir-name-to-register)          ;add buffer dir name to register
(define-key register-prefix-map   "B"  'add-buffer-name-to-register)       ;add buffer name to register
(define-key register-prefix-map   "w"  'word-to-register)                  ;save current word in register
(define-key register-prefix-map   "v"  'view-all-registers)                ;view all non-empty registers
(define-key register-prefix-map   "p"  'position-to-register)              ;save current position
(define-key register-prefix-map   "o"  'overlay-register)                  ;overlay register (block only)
(define-key register-prefix-map   "m"  'marked-to-register)                ;save marked area in register
(define-key register-prefix-map   "l"  'line-to-register)                  ;save current line in register
(define-key register-prefix-map   "i"  'insert-register)                   ;insert (copy) register here
(define-key register-prefix-map   "h"  'register-map-help)                 ;help for this map (another option)
(define-key register-prefix-map   "g"  'jump-to-register)                  ;goto saved position
(define-key register-prefix-map   "f"  'file-name-to-register)             ;buffer file name to register
(define-key register-prefix-map   "e"  'erase-register)                    ;erase (clear, delete) this register
(define-key register-prefix-map   "d"  'dir-name-to-register)              ;buffer dir name to register
(define-key register-prefix-map   "b"  'buffer-name-to-register)           ;buffer name to register
(define-key register-prefix-map   "1"  'view-register)                     ;view one register
(define-key register-prefix-map "\C-w" 'window-configuration-to-register)  ;save window configuration
(define-key register-prefix-map "\C-f" 'frame-configuration-to-register)   ;save frame configuration

;;======================  end of ekregister.el ======================