Commits

Mats Lidell committed 0e89712

New. list-register.el. Thank you Akihisa Matsushita.

Changelog addition:

2012-12-11 Mats Lidell <matsl@xemacs.org>

* list-register.el: New. Thank you Akihisa Matsushita.

  • Participants
  • Parent commits 0b8f090

Comments (0)

Files changed (3)

+2012-12-11  Mats Lidell  <matsl@xemacs.org>
+
+	* list-register.el: New. Thank you Akihisa Matsushita.
+
 2012-11-21  Norbert Koch  <viteno@xemacs.org>
 
 	* Makefile (VERSION): XEmacs package 2.48 released.
 	toolbar-utils.elc tree-menu.elc uniquify.elc where-was-i-db.elc \
 	winring.elc vertical-mode.elc power-macros.elc icon-themes.elc \
 	search-buffers.elc setnu.elc align.elc autorevert.elc allout.elc \
-	narrow-stack.elc highline.elc crm.elc wide-edit.elc buffer-colors.elc
+	narrow-stack.elc highline.elc crm.elc wide-edit.elc buffer-colors.elc \
+	list-register.elc
 
 EXPLICIT_DOCS = $(PACKAGE).texi tempo.texi
 

File list-register.el

+;;; list-register.el --- List register
+;; -*- Mode: Emacs-Lisp -*-
+
+;;  $Id: list-register.el,v 2.2 2008/02/12 09:17:09 akihisa Exp $
+
+;; 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 3, 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 GNU Emacs; see the file COPYING.  If not, write to the
+;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
+;; Boston, MA 02110-1301, USA.
+
+;;; Install:
+
+;; Put this file into load-path'ed directory, and byte compile it if
+;; desired.  And put the following expression into your ~/.emacs.
+;;
+;;     (require 'list-register)
+
+;; The latest version of this program can be downloaded from
+;; http://www.bookshelf.jp/elc/list-register.el
+
+;; M-x list-register
+
+
+;;; Commentary:
+;;
+
+;;; Code:
+(defvar list-register-buffer "*reg Output*")
+(defvar list-register-edit-buffer "*Edit Register*")
+
+;; internal
+(defvar list-register-mode-map nil)
+(defvar list-register-edit-mode-map nil)
+(defvar list-register-parent-buffer nil)
+(defvar list-register-edit-reg nil)
+
+;; util
+(defun current-line ()
+  "Return the vertical position of point..."
+  (1+ (count-lines 1 (point))))
+
+(defun max-line ()
+  "Return the vertical position of point..."
+  (save-excursion
+    (goto-char (point-max))
+    (current-line)))
+
+(or list-register-mode-map
+    (let ((map (make-sparse-keymap)))
+      (define-key map "e"
+        (function list-register-edit-text))
+      (define-key map "\C-m"
+        (function list-register-insert))
+      (define-key map "q"
+        (function list-register-quit))
+      (define-key map "p"
+        (function previous-line))
+      (define-key map "n"
+        (function next-line))
+      (define-key map "+"
+        (function list-register-increment))
+      (define-key map "-"
+        (function list-register-decrement))
+
+      (setq list-register-mode-map map)))
+
+(or list-register-edit-mode-map
+    (let ((map (make-sparse-keymap)))
+      (define-key map "\C-c\C-c"
+        (function list-register-edit-quit))
+      (define-key map "\C-c\C-q"
+        (function list-register-edit-cancel))
+      (define-key map "\C-c\C-s"
+        (function list-register-edit-set-register))
+      (setq list-register-edit-mode-map map)))
+
+(defun list-register-quit ()
+  "Exit *list-register* buffer."
+  (interactive)
+  (set-buffer list-register-parent-buffer)
+  (condition-case ()
+      (delete-window (get-buffer-window list-register-buffer))
+    (error ))
+  (kill-buffer list-register-buffer))
+
+(defun list-register-change-number (num)
+  "Add number of register to NUM."
+  (let (reg str)
+    (save-excursion
+      (beginning-of-line)
+      (if (re-search-forward "^[ \n]*\\([^\n:]+\\):[ \n]*\\([^:\n]+\\):.+$"
+                             (line-end-position) t)
+          (progn
+            (setq reg (buffer-substring
+                       (match-beginning 1) (match-end 1)))
+            (setq str (buffer-substring
+                       (match-beginning 2) (match-end 2)))))
+      (if (string-match "num" str)
+          (increment-register num (string-to-char reg))
+        (message "Register does not contain a number!"))))
+  (list-register-review))
+
+(defun list-register-increment (num)
+  "Add number of register to NUM."
+  (interactive "nIncrement Num: ")
+  (list-register-change-number num))
+
+(defun list-register-decrement (num)
+  "Subtract NUM from number of register."
+  (interactive "nDecrement Num: ")
+  (list-register-change-number (* -1 num)))
+
+;; edit register
+(defun list-register-edit-text-do (reg)
+  "Make the buffer to edit text of REG."
+  (switch-to-buffer (get-buffer-create list-register-edit-buffer))
+  (erase-buffer)
+
+  (list-insert-register (string-to-char reg))
+  (kill-all-local-variables)
+  (make-local-variable 'list-register-edit-reg)
+  (setq list-register-edit-reg reg)
+
+  (use-local-map list-register-edit-mode-map))
+
+(defun list-register-edit-text ()
+  "Edit text of register of current line."
+  (interactive)
+  (let (reg str)
+    (save-excursion
+      (beginning-of-line)
+      (if (re-search-forward
+           "^[ \n]*\\([^\n:]+\\):[ \n]*\\([^:\n]+\\):.+$"
+           (line-end-position) t)
+          (progn
+            (setq reg (buffer-substring
+                       (match-beginning 1) (match-end 1)))
+            (setq str (buffer-substring
+                       (match-beginning 2) (match-end 2)))))
+      (if (string-match "[0-9]+" str)
+          (list-register-edit-text-do reg)
+        (message "Register does not contain a text!")))))
+
+(defun list-register-edit-quit ()
+  "Exit the buffer to edit the register."
+  (interactive)
+  (set-register
+   (string-to-char list-register-edit-reg)
+   (buffer-substring (point-min) (point-max)))
+  ;;(delete-window (get-buffer-window list-register-edit-buffer))
+  (kill-buffer list-register-edit-buffer)
+  (switch-to-buffer list-register-buffer)
+  (list-register-review))
+
+(defun list-register-edit-set-register (char)
+  "Save text of a register to another register (CHAR)."
+  (interactive "cCopy to register: ")
+  (set-register
+   char
+   (buffer-substring (point-min) (point-max)))
+  ;;(delete-window (get-buffer-window list-register-edit-buffer))
+  (kill-buffer list-register-edit-buffer)
+  (switch-to-buffer list-register-buffer)
+  (list-register-review))
+
+(defun list-register-edit-cancel ()
+  "Cancel to edit a register."
+  (interactive)
+  (kill-buffer list-register-edit-buffer)
+  (switch-to-buffer list-register-buffer))
+
+(defun list-register-insert ()
+  "Insert text of a register."
+  (interactive)
+  (let (reg str)
+    (save-excursion
+      (beginning-of-line)
+      (if (re-search-forward
+           "^[ \n]*\\([^\n:]+\\):[ \n]*\\([^:\n]+\\):.+$"
+           (line-end-position) t)
+          (progn
+            (setq reg (buffer-substring
+                       (match-beginning 1) (match-end 1)))
+            (setq str (buffer-substring
+                       (match-beginning 2) (match-end 2)))))
+
+      (set-buffer list-register-parent-buffer)
+      (cond
+       ((or
+         (string-match "file" str)
+         (string-match "conf" str)
+         (string-match "pos" str))
+        (list-jump-to-register (string-to-char reg)))
+       ((or
+         (string-match "num" str)
+         (string-match "[0-9]+" str))
+        (list-insert-register (string-to-char reg))
+        (condition-case ()
+            (delete-window (get-buffer-window list-register-buffer))
+          (error ))
+        (kill-buffer list-register-buffer))))))
+
+(defun list-register-print-text (arg)
+  "Print the text of register of ARG."
+  (interactive "p")
+  (let ((x (get-register arg)) (w (- (window-width) 15))
+        str strtmp lines prev)
+    (setq str (split-string x "\n"))
+    (setq strtmp str)
+    (setq lines (format "%4d" (length str)))
+    (setq str (mapconcat (lambda (y) y) str " "))
+    (if (string-match "^[ \t]*$" str)
+        ()
+      (insert (format "%s: %s\n" lines
+                      (truncate-string-to-width
+                       (mapconcat (lambda (y) y) strtmp
+                                  "^J") w)))
+      (setq prev str))))
+
+(defun list-register ()
+  "List contents of register."
+  (interactive)
+  (let ((lst register-alist) val reg st (pbuf (current-buffer))
+        lines)
+    (with-output-to-temp-buffer list-register-buffer
+      (set-buffer list-register-buffer)
+      (kill-all-local-variables)
+
+      (make-local-variable 'list-register-parent-buffer)
+      (setq list-register-parent-buffer pbuf)
+
+      (use-local-map list-register-mode-map)
+
+      (princ "List of register\n")
+      (setq st (point))
+      (while lst
+        (setq reg (car lst))
+        (setq lst (cdr lst))
+        (princ
+         (concat
+          ;;"-------------------------------------------------\n"
+          (format "%3s"
+                  (single-key-description (car reg)))
+          ":"))
+        (setq val (get-register (car reg)))
+        (cond
+         ((numberp val)
+          (insert " num:")
+          (insert (int-to-string val))
+          (insert "\n"))
+
+         ((markerp val)
+          (insert " pos:")
+          (let ((buf (marker-buffer val)))
+            (if (null buf)
+                (insert "a marker in no buffer")
+              (insert "a buffer position:")
+              (insert (buffer-name buf))
+              (insert ", position ")
+              (insert (int-to-string (marker-position val)))
+              (insert "\n"))))
+
+         ((and (consp val) (window-configuration-p (car val)))
+          (insert "conf:a window configuration.\n"))
+
+         ((and (consp val) (frame-configuration-p (car val)))
+          (insert "conf:a frame configuration.\n"))
+
+         ((and (consp val) (eq (car val) 'file))
+          (insert "file:")
+          (prin1 (cdr val))
+          (insert ".\n"))
+
+         ((and (consp val) (eq (car val) 'file-query))
+          (insert "file:a file-query reference: file ")
+          (insert (car (cdr val)))
+          (insert ", position ")
+          (insert (int-to-string (car (cdr (cdr val)))))
+          (insert ".\n"))
+
+         ((consp val)
+          (setq lines (format "%4d" (length val)))
+          (insert (format "%s: %s\n" lines
+                          (truncate-string-to-width
+                           (mapconcat (lambda (y) y) val
+                                      "^J") (- (window-width) 15)))))
+         ((stringp val)
+          (list-register-print-text (car reg)))
+         (t
+          ;;(insert "Garbage:\n")
+          ;;(prin1 val))
+          )))
+      (sort-lines nil st (point-max))
+      (setq buffer-read-only t)))
+  (pop-to-buffer list-register-buffer))
+
+(defun list-register-review ()
+  "Update list-register buffer."
+  (let ((pbuf list-register-parent-buffer)
+        (cp (current-line)))
+    (list-register)
+    (next-line (- cp 1))
+    (setq list-register-parent-buffer pbuf)))
+
+(defun my-jump-to-register (&optional arg)
+  (interactive)
+  (let (char)
+    (message "Jump to register: ")
+    (list-register)
+    (setq char (read-char))
+    (list-jump-to-register char)))
+
+(defun data-to-register (arg)
+  (interactive "P")
+  (let ((char))
+    (message "Copy to register: ")
+    (setq char (read-char))
+    (cond
+     ((region-active-p) ;; XEmacs change
+      (if (and
+           (not (= (save-excursion
+                     (goto-char (region-beginning)) (current-column))
+                   (save-excursion
+                     (goto-char (region-end)) (current-column))))
+           (not (= (save-excursion
+                     (goto-char (region-beginning)) (current-line))
+                   (save-excursion
+                     (goto-char (region-end)) (current-line)))))
+          (if (y-or-n-p "Rectangle? ")
+              (progn
+                (copy-rectangle-to-register
+                 char (region-beginning) (region-end) arg))
+            (set-register char (buffer-substring
+                                (region-beginning) (region-end)))
+            (if arg
+                (delete-region (region-beginning) (region-end))))))
+     (t
+      (message "f)rame w)indow p)oint")
+      (let ((c (char-to-string (read-char))))
+        (cond
+         ((string-match "f" c)
+          (frame-configuration-to-register char arg))
+         ((string-match "w" c)
+          (window-configuration-to-register char arg))
+         ((string-match "p" c)
+          (point-to-register char arg))))))))
+
+(defun list-insert-register (register)
+  (push-mark)
+  (let ((val (get-register register)))
+    (cond
+     ((consp val)
+      (insert-rectangle val))
+     ((stringp val)
+      (insert val))
+     ((numberp val)
+      (princ val (current-buffer)))
+     ((and (markerp val) (marker-position val))
+      (princ (marker-position val) (current-buffer)))
+     (t
+      (error "Register does not contain text")))))
+
+(defun list-jump-to-register (register)
+  (let ((val (get-register register)))
+    (cond
+     ((and (consp val) (frame-configuration-p (car val)))
+      (set-frame-configuration (car val))
+      (goto-char (cadr val)))
+     ((and (consp val) (window-configuration-p (car val)))
+      (set-window-configuration (car val))
+      (goto-char (cadr val)))
+     ((markerp val)
+      (or (marker-buffer val)
+          (error "That register's buffer no longer exists"))
+      (switch-to-buffer (marker-buffer val))
+      (goto-char val))
+     ((and (consp val) (eq (car val) 'file))
+      (find-file (cdr val)))
+     ((and (consp val) (eq (car val) 'file-query))
+      (or (find-buffer-visiting (nth 1 val))
+          (y-or-n-p (format "Visit file %s again? " (nth 1 val)))
+          (error "Register access aborted"))
+      (find-file (nth 1 val))
+      (goto-char (nth 2 val)))
+     (t
+      (error "Register doesn't contain a buffer position or configuration")))))
+
+(provide 'list-register)
+;;; list-register.el ends here