X-Git-Url: https://code.delx.au/gnu-emacs/blobdiff_plain/5df4f04cd32af723742c81095b38ae83b3c2b462..c9586acc9719f5af71c61a24b7c5c40eb1b0905f:/lisp/register.el diff --git a/lisp/register.el b/lisp/register.el index f34fd8d065..ae2f7cf3e2 100644 --- a/lisp/register.el +++ b/lisp/register.el @@ -1,10 +1,11 @@ ;;; register.el --- register commands for Emacs -;; Copyright (C) 1985, 1993, 1994, 2001, 2002, 2003, 2004, -;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc. +;; Copyright (C) 1985, 1993-1994, 2001-2013 Free Software Foundation, +;; Inc. ;; Maintainer: FSF ;; Keywords: internal +;; Package: emacs ;; This file is part of GNU Emacs. @@ -28,31 +29,44 @@ ;; pieces of buffer state to named variables. The entry points are ;; documented in the Emacs user's manual. +(eval-when-compile (require 'cl-lib)) + (declare-function semantic-insert-foreign-tag "semantic/tag" (foreign-tag)) (declare-function semantic-tag-buffer "semantic/tag" (tag)) (declare-function semantic-tag-start "semantic/tag" (tag)) -;;; Global key bindings - -(define-key ctl-x-r-map "\C-@" 'point-to-register) -(define-key ctl-x-r-map [?\C-\ ] 'point-to-register) -(define-key ctl-x-r-map " " 'point-to-register) -(define-key ctl-x-r-map "j" 'jump-to-register) -(define-key ctl-x-r-map "s" 'copy-to-register) -(define-key ctl-x-r-map "x" 'copy-to-register) -(define-key ctl-x-r-map "i" 'insert-register) -(define-key ctl-x-r-map "g" 'insert-register) -(define-key ctl-x-r-map "r" 'copy-rectangle-to-register) -(define-key ctl-x-r-map "n" 'number-to-register) -(define-key ctl-x-r-map "+" 'increment-register) -(define-key ctl-x-r-map "w" 'window-configuration-to-register) -(define-key ctl-x-r-map "f" 'frame-configuration-to-register) - ;;; Code: +(cl-defstruct + (registerv (:constructor nil) + (:constructor registerv--make (&optional data print-func + jump-func insert-func)) + (:copier nil) + (:type vector) + :named) + (data nil :read-only t) + (print-func nil :read-only t) + (jump-func nil :read-only t) + (insert-func nil :read-only t)) + +(cl-defun registerv-make (data &key print-func jump-func insert-func) + "Create a register value object. + +DATA can be any value. +PRINT-FUNC if provided controls how `list-registers' and +`view-register' print the register. It should be a function +receiving one argument DATA and print text that completes +this sentence: + Register X contains [TEXT PRINTED BY PRINT-FUNC] +JUMP-FUNC if provided, controls how `jump-to-register' jumps to the register. +INSERT-FUNC if provided, controls how `insert-register' insert the register. +They both receive DATA as argument." + (registerv--make data print-func jump-func insert-func)) + (defvar register-alist nil "Alist of elements (NAME . CONTENTS), one for each Emacs register. -NAME is a character (a number). CONTENTS is a string, number, marker or list. +NAME is a character (a number). CONTENTS is a string, number, marker, list +or a struct returned by `registerv-make'. A list of strings represents a rectangle. A list of the form (file . FILE-NAME) represents the file named FILE-NAME. A list of the form (file-query FILE-NAME POSITION) represents @@ -63,6 +77,22 @@ A list of the form (WINDOW-CONFIGURATION POSITION) A list of the form (FRAME-CONFIGURATION POSITION) represents a saved frame configuration plus a saved value of point.") +(defgroup register nil + "Register commands." + :group 'convenience + :version "24.3") + +(defcustom register-separator nil + "Register containing the text to put between collected texts, or nil if none. + +When collecting text with +`append-to-register' (resp. `prepend-to-register') contents of +this register is added to the beginning (resp. end) of the marked +text." + :group 'register + :type '(choice (const :tag "None" nil) + (character :tag "Use register" :value ?+))) + (defun get-register (register) "Return contents of Emacs register named REGISTER, or nil if none." (cdr (assq register register-alist))) @@ -88,7 +118,7 @@ Argument is a character, naming the register." (if arg (list (current-frame-configuration) (point-marker)) (point-marker)))) -(defun window-configuration-to-register (register &optional arg) +(defun window-configuration-to-register (register &optional _arg) "Store the window configuration of the selected frame in register REGISTER. Use \\[jump-to-register] to restore the configuration. Argument is a character, naming the register." @@ -97,7 +127,7 @@ Argument is a character, naming the register." ;; of point in the current buffer, so record that separately. (set-register register (list (current-window-configuration) (point-marker)))) -(defun frame-configuration-to-register (register &optional arg) +(defun frame-configuration-to-register (register &optional _arg) "Store the window configuration of all frames in register REGISTER. Use \\[jump-to-register] to restore the configuration. Argument is a character, naming the register." @@ -120,6 +150,11 @@ delete any existing frames that the frame configuration doesn't mention. (interactive "cJump to register: \nP") (let ((val (get-register register))) (cond + ((registerv-p val) + (cl-assert (registerv-jump-func val) nil + "Don't know how to jump to register %s" + (single-key-description register)) + (funcall (registerv-jump-func val) (registerv-data val))) ((and (consp val) (frame-configuration-p (car val))) (set-frame-configuration (car val) (not delete)) (goto-char (cadr val))) @@ -174,13 +209,24 @@ Interactively, NUMBER is the prefix arg (none means nil)." (string-to-number (match-string 0))) 0)))) -(defun increment-register (number register) - "Add NUMBER to the contents of register REGISTER. -Interactively, NUMBER is the prefix arg." - (interactive "p\ncIncrement register: ") - (or (numberp (get-register register)) - (error "Register does not contain a number")) - (set-register register (+ number (get-register register)))) +(defun increment-register (prefix register) + "Augment contents of REGISTER. +Interactively, PREFIX is in raw form. + +If REGISTER contains a number, add `prefix-numeric-value' of +PREFIX to it. + +If REGISTER is empty or if it contains text, call +`append-to-register' with `delete-flag' set to PREFIX." + (interactive "P\ncIncrement register: ") + (let ((register-val (get-register register))) + (cond + ((numberp register-val) + (let ((number (prefix-numeric-value prefix))) + (set-register register (+ number register-val)))) + ((or (not register-val) (stringp register-val)) + (append-to-register register (region-beginning) (region-end) prefix)) + (t (error "Register does not contain a number or text"))))) (defun view-register (register) "Display what is contained in register named REGISTER. @@ -209,6 +255,11 @@ The Lisp value REGISTER is a character." (princ " contains ") (let ((val (get-register register))) (cond + ((registerv-p val) + (if (registerv-print-func val) + (funcall (registerv-print-func val) (registerv-data val)) + (princ "[UNPRINTABLE CONTENTS]."))) + ((numberp val) (princ val)) @@ -285,6 +336,11 @@ Interactively, second arg is non-nil if prefix arg is supplied." (push-mark) (let ((val (get-register register))) (cond + ((registerv-p val) + (cl-assert (registerv-insert-func val) nil + "Don't know how to insert register %s" + (single-key-description register)) + (funcall (registerv-insert-func val) (registerv-data val))) ((consp val) (insert-rectangle val)) ((stringp val) @@ -308,7 +364,11 @@ Called from program, takes four args: REGISTER, START, END and DELETE-FLAG. START and END are buffer positions indicating what to copy." (interactive "cCopy to register: \nr\nP") (set-register register (filter-buffer-substring start end)) - (if delete-flag (delete-region start end))) + (setq deactivate-mark t) + (cond (delete-flag + (delete-region start end)) + ((called-interactively-p 'interactive) + (indicate-copied-region)))) (defun append-to-register (register start end &optional delete-flag) "Append region to text in register REGISTER. @@ -317,12 +377,17 @@ Called from program, takes four args: REGISTER, START, END and DELETE-FLAG. START and END are buffer positions indicating what to append." (interactive "cAppend to register: \nr\nP") (let ((reg (get-register register)) - (text (filter-buffer-substring start end))) + (text (filter-buffer-substring start end)) + (separator (and register-separator (get-register register-separator)))) (set-register register (cond ((not reg) text) - ((stringp reg) (concat reg text)) + ((stringp reg) (concat reg separator text)) (t (error "Register does not contain text"))))) - (if delete-flag (delete-region start end))) + (setq deactivate-mark t) + (cond (delete-flag + (delete-region start end)) + ((called-interactively-p 'interactive) + (indicate-copied-region)))) (defun prepend-to-register (register start end &optional delete-flag) "Prepend region to text in register REGISTER. @@ -331,12 +396,17 @@ Called from program, takes four args: REGISTER, START, END and DELETE-FLAG. START and END are buffer positions indicating what to prepend." (interactive "cPrepend to register: \nr\nP") (let ((reg (get-register register)) - (text (filter-buffer-substring start end))) + (text (filter-buffer-substring start end)) + (separator (and register-separator (get-register register-separator)))) (set-register register (cond ((not reg) text) - ((stringp reg) (concat text reg)) + ((stringp reg) (concat text separator reg)) (t (error "Register does not contain text"))))) - (if delete-flag (delete-region start end))) + (setq deactivate-mark t) + (cond (delete-flag + (delete-region start end)) + ((called-interactively-p 'interactive) + (indicate-copied-region)))) (defun copy-rectangle-to-register (register start end &optional delete-flag) "Copy rectangular region into register REGISTER. @@ -346,11 +416,15 @@ To insert this register in the buffer, use \\[insert-register]. Called from a program, takes four args: REGISTER, START, END and DELETE-FLAG. START and END are buffer positions giving two corners of rectangle." (interactive "cCopy rectangle to register: \nr\nP") - (set-register register - (if delete-flag - (delete-extract-rectangle start end) - (extract-rectangle start end)))) + (let ((rectangle (if delete-flag + (delete-extract-rectangle start end) + (extract-rectangle start end)))) + (set-register register rectangle) + (when (and (null delete-flag) + (called-interactively-p 'interactive)) + (setq deactivate-mark t) + (indicate-copied-region (length (car rectangle)))))) + (provide 'register) -;; arch-tag: ce14dd68-8265-475f-9341-5d4ec5a53035 ;;; register.el ends here