Mercurial > hg > xemacs-beta

comparison lisp/prim/register.el @ 195:a2f645c6b9f8 r20-3b24

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r20-3b24
author cvs
date Mon, 13 Aug 2007 09:59:05 +0200
parents b9518feda344
children
comparison
equal deleted inserted replaced
194:2947057885e5 195:a2f645c6b9f8
1 ;;; register.el --- register commands for XEmacs. 1 ;;; register.el --- register commands for Emacs.
2 2
3 ;; Copyright (C) 1985, 1993, 1994 Free Software Foundation, Inc. 3 ;; Copyright (C) 1985, 1993, 1994 Free Software Foundation, Inc.
4 4
5 ;; Maintainer: FSF 5 ;; Maintainer: FSF
6 ;; Keywords: internal 6 ;; Keywords: internal
7 7
8 ;; This file is part of XEmacs. 8 ;; This file is part of XEmacs.
9 9
10 ;; XEmacs is free software; you can redistribute it and/or modify it 10 ;; XEmacs is free software; you can redistribute it and/or modify
11 ;; under the terms of the GNU General Public License as published by 11 ;; it under the terms of the GNU General Public License as published by
12 ;; the Free Software Foundation; either version 2, or (at your option) 12 ;; the Free Software Foundation; either version 2, or (at your option)
13 ;; any later version. 13 ;; any later version.
14 14
15 ;; XEmacs is distributed in the hope that it will be useful, but 15 ;; XEmacs is distributed in the hope that it will be useful,
16 ;; WITHOUT ANY WARRANTY; without even the implied warranty of 16 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
18 ;; General Public License for more details. 18 ;; GNU General Public License for more details.
19 19
20 ;; You should have received a copy of the GNU General Public License 20 ;; You should have received a copy of the GNU General Public License
21 ;; along with XEmacs; see the file COPYING. If not, write to the Free 21 ;; along with XEmacs; see the file COPYING. If not, write to the
22 ;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 22 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
23 ;; 02111-1307, USA. 23 ;; Boston, MA 02111-1307, USA.
24 24
25 ;;; Synched up with: FSF 19.34. 25 ;;; Synched up with: FSF 20.1
26 26
27 ;;; Commentary: 27 ;;; Commentary:
28 28
29 ;; This package of functions emulates and somewhat extends the venerable 29 ;; This package of functions emulates and somewhat extends the venerable
30 ;; TECO's `register' feature, which permits you to save various useful 30 ;; TECO's `register' feature, which permits you to save various useful
31 ;; pieces of buffer state to named variables. The entry points are 31 ;; pieces of buffer state to named variables. The entry points are
32 ;; documented in the XEmacs Reference Manual. 32 ;; documented in the Emacs user's manual.
33 33
34 ;;; Code: 34 ;;; Code:
35 35
36 (defvar register-alist nil 36 (defvar register-alist nil
37 "Alist of elements (NAME . CONTENTS), one for each Emacs register. 37 "Alist of elements (NAME . CONTENTS), one for each Emacs register.
38 NAME is a character (a number). CONTENTS is a string, number, 38 NAME is a character (a number). CONTENTS is a string, number,
39 frame configuration, mark or list. 39 frame configuration, mark or list.
40 A list of strings represents a rectangle. 40 A list of strings represents a rectangle.
41 A list of the form (file . NAME) represents the file named NAME.") 41 A list of the form (file . NAME) represents the file named NAME.
42 A list of the form (file-query NAME POSITION) represents position POSITION
43 in the file named NAME, but query before visiting it.")
42 44
43 (defun get-register (reg) 45 (defun get-register (reg)
44 "Return contents of Emacs register named REG, or nil if none." 46 "Return contents of Emacs register named REG, or nil if none."
45 (cdr (assq reg register-alist))) 47 (cdr (assq reg register-alist)))
46 48
47 (defun set-register (register value) 49 (defun set-register (register value)
48 "Set contents of Emacs register named REGISTER to VALUE. Returns VALUE. 50 "Set contents of Emacs register named REGISTER to VALUE. Returns VALUE.
49 See the documentation of the variable `register-alist' for possible VALUEs." 51 See the documentation of the variable `register-alist' for possible VALUE."
50 (let ((aelt (assq register register-alist))) 52 (let ((aelt (assq register register-alist)))
51 (if aelt 53 (if aelt
52 (setcdr aelt value) 54 (setcdr aelt value)
53 (setq aelt (cons register value)) 55 (setq aelt (cons register value))
54 (setq register-alist (cons aelt register-alist))) 56 (setq register-alist (cons aelt register-alist)))
101 (error "That register's buffer no longer exists")) 103 (error "That register's buffer no longer exists"))
102 (switch-to-buffer (marker-buffer val)) 104 (switch-to-buffer (marker-buffer val))
103 (goto-char val)) 105 (goto-char val))
104 ((and (consp val) (eq (car val) 'file)) 106 ((and (consp val) (eq (car val) 'file))
105 (find-file (cdr val))) 107 (find-file (cdr val)))
108 ((and (consp val) (eq (car val) 'file-query))
109 (or (find-buffer-visiting (nth 1 val))
110 (y-or-n-p (format "Visit file %s again? " (nth 1 val)))
111 (error "Register access aborted"))
112 (find-file (nth 1 val))
113 (goto-char (nth 2 val)))
106 (t 114 (t
107 (error "Register doesn't contain a buffer position or configuration"))))) 115 (error "Register doesn't contain a buffer position or configuration")))))
116
117 ;; Turn markers into file-query references when a buffer is killed.
118 (defun register-swap-out ()
119 (and buffer-file-name
120 (let ((tail register-alist))
121 (while tail
122 (and (markerp (cdr (car tail)))
123 (eq (marker-buffer (cdr (car tail))) (current-buffer))
124 (setcdr (car tail)
125 (list 'file-query
126 buffer-file-name
127 (marker-position (cdr (car tail))))))
128 (setq tail (cdr tail))))))
129
130 (add-hook 'kill-buffer-hook 'register-swap-out)
108 131
109 ;(defun number-to-register (arg char) 132 ;(defun number-to-register (arg char)
110 ; "Store a number in a register. 133 ; "Store a number in a register.
111 ;Two args, NUMBER and REGISTER (a character, naming the register). 134 ;Two args, NUMBER and REGISTER (a character, naming the register).
112 ;If NUMBER is nil, digits in the buffer following point are read 135 ;If NUMBER is nil, digits in the buffer following point are read
140 (interactive "cView register: ") 163 (interactive "cView register: ")
141 (let ((val (get-register register))) 164 (let ((val (get-register register)))
142 (if (null val) 165 (if (null val)
143 (message "Register %s is empty" (single-key-description register)) 166 (message "Register %s is empty" (single-key-description register))
144 (with-output-to-temp-buffer "*Output*" 167 (with-output-to-temp-buffer "*Output*"
145 (princ (format "Register %s contains " 168 (princ "Register ")
146 (single-key-description register))) 169 (princ (single-key-description register))
147 (cond 170 (princ " contains ")
171 (cond
148 ((integerp val) 172 ((integerp val)
149 (princ val)) 173 (princ val))
150 174
151 ((markerp val) 175 ((markerp val)
152 (let ((buf (marker-buffer val))) 176 (let ((buf (marker-buffer val)))
153 (if (null buf) 177 (if (null buf)
154 (princ "a marker in no buffer") 178 (princ "a marker in no buffer")
155 (princ (format 179 (princ "a buffer position:\nbuffer ")
156 "a buffer position:\nbuff %s, position %s" 180 (princ (buffer-name buf))
157 (buffer-name (marker-buffer val)) 181 (princ ", position ")
158 (marker-position val)))))) 182 (princ (marker-position val)))))
159 183
160 ((window-configuration-p val) 184 ((window-configuration-p val)
161 (princ "a window configuration.")) 185 (princ "a window configuration."))
162 186
163 187 ((frame-configuration-p val)
164 ;; ((frame-configuration-p val) 188 (princ "a frame configuration."))
165 ;; (princ "a frame configuration."))
166 189
167 ((and (consp val) (eq (car val) 'file)) 190 ((and (consp val) (eq (car val) 'file))
168 (princ "the file ") 191 (princ "the file ")
169 (prin1 (cdr val)) 192 (prin1 (cdr val))
170 (princ ".")) 193 (princ "."))
171 194
172 ((consp val) 195 ((consp val)
173 (princ "the rectangle:\n") 196 (princ "the rectangle:\n")
174 (while val 197 (while val
175 (princ (car val)) 198 (princ (car val))
176 (terpri) 199 (terpri)
177 (setq val (cdr val)))) 200 (setq val (cdr val))))
178 201
179 ((stringp val) 202 ((stringp val)
183 (t 206 (t
184 (princ "Garbage:\n") 207 (princ "Garbage:\n")
185 (prin1 val))))))) 208 (prin1 val)))))))
186 209
187 (defun insert-register (register &optional arg) 210 (defun insert-register (register &optional arg)
188 "Insert contents of register REGISTER. (REGISTER is a character). 211 "Insert contents of register REGISTER. (REGISTER is a character.)
189 Normally puts point before and mark after the inserted text. 212 Normally puts point before and mark after the inserted text.
190 If optional second arg is non-nil, puts mark before and point after. 213 If optional second arg is non-nil, puts mark before and point after.
191 Interactively, second arg is non-nil if prefix arg is supplied." 214 Interactively, second arg is non-nil if prefix arg is supplied."
192 (interactive "*cInsert register: \nP") 215 (interactive "*cInsert register: \nP")
193 (push-mark) 216 (push-mark)
201 (princ val (current-buffer))) 224 (princ val (current-buffer)))
202 ((and (markerp val) (marker-position val)) 225 ((and (markerp val) (marker-position val))
203 (princ (marker-position val) (current-buffer))) 226 (princ (marker-position val) (current-buffer)))
204 (t 227 (t
205 (error "Register does not contain text")))) 228 (error "Register does not contain text"))))
206 ;; XEmacs: don't activate the region. It's annoying. 229 (if (not arg) (exchange-point-and-mark)))
207 (if (not arg) (exchange-point-and-mark t)))
208 230
209 (defun copy-to-register (register start end &optional delete-flag) 231 (defun copy-to-register (register start end &optional delete-flag)
210 "Copy region into register REGISTER. With prefix arg, delete as well. 232 "Copy region into register REGISTER. With prefix arg, delete as well.
211 Called from program, takes four args: REGISTER, START, END and DELETE-FLAG. 233 Called from program, takes four args: REGISTER, START, END and DELETE-FLAG.
212 START and END are buffer positions indicating what to copy." 234 START and END are buffer positions indicating what to copy."
221 START and END are buffer positions indicating what to append." 243 START and END are buffer positions indicating what to append."
222 (interactive "cAppend to register: \nr\nP") 244 (interactive "cAppend to register: \nr\nP")
223 (or (stringp (get-register register)) 245 (or (stringp (get-register register))
224 (error "Register does not contain text")) 246 (error "Register does not contain text"))
225 (set-register register (concat (get-register register) 247 (set-register register (concat (get-register register)
226 (buffer-substring start end))) 248 (buffer-substring start end)))
227 (if delete-flag (delete-region start end))) 249 (if delete-flag (delete-region start end)))
228 250
229 (defun prepend-to-register (register start end &optional delete-flag) 251 (defun prepend-to-register (register start end &optional delete-flag)
230 "Prepend region to text in register REGISTER. 252 "Prepend region to text in register REGISTER.
231 With prefix arg, delete as well. 253 With prefix arg, delete as well.
233 START and END are buffer positions indicating what to prepend." 255 START and END are buffer positions indicating what to prepend."
234 (interactive "cPrepend to register: \nr\nP") 256 (interactive "cPrepend to register: \nr\nP")
235 (or (stringp (get-register register)) 257 (or (stringp (get-register register))
236 (error "Register does not contain text")) 258 (error "Register does not contain text"))
237 (set-register register (concat (buffer-substring start end) 259 (set-register register (concat (buffer-substring start end)
238 (get-register register))) 260 (get-register register)))
239 (if delete-flag (delete-region start end))) 261 (if delete-flag (delete-region start end)))
240 262
241 (defun copy-rectangle-to-register (register start end &optional delete-flag) 263 (defun copy-rectangle-to-register (register start end &optional delete-flag)
242 "Copy rectangular region into register REGISTER. 264 "Copy rectangular region into register REGISTER.
243 With prefix arg, delete as well. 265 With prefix arg, delete as well.