*** empty log message ***
[bpt/emacs.git] / lisp / simple.el
1 ;;; simple.el --- basic editing commands for Emacs
2
3 ;; Copyright (C) 1985, 86, 87, 93, 94, 95, 96, 97, 98, 99, 2000
4 ;; Free Software Foundation, Inc.
5
6 ;; This file is part of GNU Emacs.
7
8 ;; GNU Emacs is free software; you can redistribute it and/or modify
9 ;; it under the terms of the GNU General Public License as published by
10 ;; the Free Software Foundation; either version 2, or (at your option)
11 ;; any later version.
12
13 ;; GNU Emacs is distributed in the hope that it will be useful,
14 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
15 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
16 ;; GNU General Public License for more details.
17
18 ;; You should have received a copy of the GNU General Public License
19 ;; along with GNU Emacs; see the file COPYING. If not, write to the
20 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
21 ;; Boston, MA 02111-1307, USA.
22
23 ;;; Commentary:
24
25 ;; A grab-bag of basic Emacs commands not specifically related to some
26 ;; major mode or to file-handling.
27
28 ;;; Code:
29
30 (eval-when-compile
31 (autoload 'widget-convert "wid-edit")
32 (autoload 'shell-mode "shell")
33 (require 'cl))
34
35
36 (defgroup killing nil
37 "Killing and yanking commands"
38 :group 'editing)
39
40 (defgroup paren-matching nil
41 "Highlight (un)matching of parens and expressions."
42 :group 'matching)
43
44
45 (defun fundamental-mode ()
46 "Major mode not specialized for anything in particular.
47 Other major modes are defined by comparison with this one."
48 (interactive)
49 (kill-all-local-variables))
50
51 ;; Making and deleting lines.
52
53 (defun newline (&optional arg)
54 "Insert a newline, and move to left margin of the new line if it's blank.
55 The newline is marked with the text-property `hard'.
56 With ARG, insert that many newlines.
57 In Auto Fill mode, if no numeric arg, break the preceding line if it's long."
58 (interactive "*P")
59 (barf-if-buffer-read-only)
60 ;; Inserting a newline at the end of a line produces better redisplay in
61 ;; try_window_id than inserting at the beginning of a line, and the textual
62 ;; result is the same. So, if we're at beginning of line, pretend to be at
63 ;; the end of the previous line.
64 (let ((flag (and (not (bobp))
65 (bolp)
66 ;; Make sure no functions want to be told about
67 ;; the range of the changes.
68 (not after-change-functions)
69 (not before-change-functions)
70 ;; Make sure there are no markers here.
71 (not (buffer-has-markers-at (1- (point))))
72 (not (buffer-has-markers-at (point)))
73 ;; Make sure no text properties want to know
74 ;; where the change was.
75 (not (get-char-property (1- (point)) 'modification-hooks))
76 (not (get-char-property (1- (point)) 'insert-behind-hooks))
77 (or (eobp)
78 (not (get-char-property (point) 'insert-in-front-hooks)))
79 ;; Make sure the newline before point isn't intangible.
80 (not (get-char-property (1- (point)) 'intangible))
81 ;; Make sure the newline before point isn't read-only.
82 (not (get-char-property (1- (point)) 'read-only))
83 ;; Make sure the newline before point isn't invisible.
84 (not (get-char-property (1- (point)) 'invisible))
85 ;; Make sure the newline before point has the same
86 ;; properties as the char before it (if any).
87 (< (or (previous-property-change (point)) -2)
88 (- (point) 2))))
89 (was-page-start (and (bolp)
90 (looking-at page-delimiter)))
91 (beforepos (point)))
92 (if flag (backward-char 1))
93 ;; Call self-insert so that auto-fill, abbrev expansion etc. happens.
94 ;; Set last-command-char to tell self-insert what to insert.
95 (let ((last-command-char ?\n)
96 ;; Don't auto-fill if we have a numeric argument.
97 ;; Also not if flag is true (it would fill wrong line);
98 ;; there is no need to since we're at BOL.
99 (auto-fill-function (if (or arg flag) nil auto-fill-function)))
100 (unwind-protect
101 (self-insert-command (prefix-numeric-value arg))
102 ;; If we get an error in self-insert-command, put point at right place.
103 (if flag (forward-char 1))))
104 ;; Even if we did *not* get an error, keep that forward-char;
105 ;; all further processing should apply to the newline that the user
106 ;; thinks he inserted.
107
108 ;; Mark the newline(s) `hard'.
109 (if use-hard-newlines
110 (set-hard-newline-properties
111 (- (point) (if arg (prefix-numeric-value arg) 1)) (point)))
112 ;; If the newline leaves the previous line blank,
113 ;; and we have a left margin, delete that from the blank line.
114 (or flag
115 (save-excursion
116 (goto-char beforepos)
117 (beginning-of-line)
118 (and (looking-at "[ \t]$")
119 (> (current-left-margin) 0)
120 (delete-region (point) (progn (end-of-line) (point))))))
121 ;; Indent the line after the newline, except in one case:
122 ;; when we added the newline at the beginning of a line
123 ;; which starts a page.
124 (or was-page-start
125 (move-to-left-margin nil t)))
126 nil)
127
128 (defun set-hard-newline-properties (from to)
129 (let ((sticky (get-text-property from 'rear-nonsticky)))
130 (put-text-property from to 'hard 't)
131 ;; If rear-nonsticky is not "t", add 'hard to rear-nonsticky list
132 (if (and (listp sticky) (not (memq 'hard sticky)))
133 (put-text-property from (point) 'rear-nonsticky
134 (cons 'hard sticky)))))
135
136 (defun open-line (arg)
137 "Insert a newline and leave point before it.
138 If there is a fill prefix and/or a left-margin, insert them on the new line
139 if the line would have been blank.
140 With arg N, insert N newlines."
141 (interactive "*p")
142 (let* ((do-fill-prefix (and fill-prefix (bolp)))
143 (do-left-margin (and (bolp) (> (current-left-margin) 0)))
144 (loc (point)))
145 (newline arg)
146 (goto-char loc)
147 (while (> arg 0)
148 (cond ((bolp)
149 (if do-left-margin (indent-to (current-left-margin)))
150 (if do-fill-prefix (insert-and-inherit fill-prefix))))
151 (forward-line 1)
152 (setq arg (1- arg)))
153 (goto-char loc)
154 (end-of-line)))
155
156 (defun split-line ()
157 "Split current line, moving portion beyond point vertically down."
158 (interactive "*")
159 (skip-chars-forward " \t")
160 (let ((col (current-column))
161 (pos (point)))
162 (newline 1)
163 (indent-to col 0)
164 (goto-char pos)))
165
166 (defun delete-indentation (&optional arg)
167 "Join this line to previous and fix up whitespace at join.
168 If there is a fill prefix, delete it from the beginning of this line.
169 With argument, join this line to following line."
170 (interactive "*P")
171 (beginning-of-line)
172 (if arg (forward-line 1))
173 (if (eq (preceding-char) ?\n)
174 (progn
175 (delete-region (point) (1- (point)))
176 ;; If the second line started with the fill prefix,
177 ;; delete the prefix.
178 (if (and fill-prefix
179 (<= (+ (point) (length fill-prefix)) (point-max))
180 (string= fill-prefix
181 (buffer-substring (point)
182 (+ (point) (length fill-prefix)))))
183 (delete-region (point) (+ (point) (length fill-prefix))))
184 (fixup-whitespace))))
185
186 (defalias 'join-line #'delete-indentation) ; easier to find
187
188 (defun delete-blank-lines ()
189 "On blank line, delete all surrounding blank lines, leaving just one.
190 On isolated blank line, delete that one.
191 On nonblank line, delete any immediately following blank lines."
192 (interactive "*")
193 (let (thisblank singleblank)
194 (save-excursion
195 (beginning-of-line)
196 (setq thisblank (looking-at "[ \t]*$"))
197 ;; Set singleblank if there is just one blank line here.
198 (setq singleblank
199 (and thisblank
200 (not (looking-at "[ \t]*\n[ \t]*$"))
201 (or (bobp)
202 (progn (forward-line -1)
203 (not (looking-at "[ \t]*$")))))))
204 ;; Delete preceding blank lines, and this one too if it's the only one.
205 (if thisblank
206 (progn
207 (beginning-of-line)
208 (if singleblank (forward-line 1))
209 (delete-region (point)
210 (if (re-search-backward "[^ \t\n]" nil t)
211 (progn (forward-line 1) (point))
212 (point-min)))))
213 ;; Delete following blank lines, unless the current line is blank
214 ;; and there are no following blank lines.
215 (if (not (and thisblank singleblank))
216 (save-excursion
217 (end-of-line)
218 (forward-line 1)
219 (delete-region (point)
220 (if (re-search-forward "[^ \t\n]" nil t)
221 (progn (beginning-of-line) (point))
222 (point-max)))))
223 ;; Handle the special case where point is followed by newline and eob.
224 ;; Delete the line, leaving point at eob.
225 (if (looking-at "^[ \t]*\n\\'")
226 (delete-region (point) (point-max)))))
227
228 (defun delete-trailing-whitespace ()
229 "Delete all the trailing whitespace across the current buffer.
230 All whitespace after the last non-whitespace character in a line is deleted.
231 This respects narrowing, created by \\[narrow-to-region] and friends."
232 (interactive "*")
233 (save-match-data
234 (save-excursion
235 (let (eol bol)
236 (goto-char (point-min))
237 (while (re-search-forward "\\s-$" nil t)
238 (skip-syntax-backward "-" (save-excursion (forward-line 0) (point)))
239 (delete-region (point) (match-end 0)))))))
240
241 (defun newline-and-indent ()
242 "Insert a newline, then indent according to major mode.
243 Indentation is done using the value of `indent-line-function'.
244 In programming language modes, this is the same as TAB.
245 In some text modes, where TAB inserts a tab, this command indents to the
246 column specified by the function `current-left-margin'."
247 (interactive "*")
248 (delete-region (point) (progn (skip-chars-backward " \t") (point)))
249 (newline)
250 (indent-according-to-mode))
251
252 (defun reindent-then-newline-and-indent ()
253 "Reindent current line, insert newline, then indent the new line.
254 Indentation of both lines is done according to the current major mode,
255 which means calling the current value of `indent-line-function'.
256 In programming language modes, this is the same as TAB.
257 In some text modes, where TAB inserts a tab, this indents to the
258 column specified by the function `current-left-margin'."
259 (interactive "*")
260 (save-excursion
261 (delete-region (point) (progn (skip-chars-backward " \t") (point)))
262 (indent-according-to-mode))
263 (newline)
264 (indent-according-to-mode))
265
266 (defun quoted-insert (arg)
267 "Read next input character and insert it.
268 This is useful for inserting control characters.
269
270 If the first character you type after this command is an octal digit,
271 you should type a sequence of octal digits which specify a character code.
272 Any nondigit terminates the sequence. If the terminator is a RET,
273 it is discarded; any other terminator is used itself as input.
274 The variable `read-quoted-char-radix' specifies the radix for this feature;
275 set it to 10 or 16 to use decimal or hex instead of octal.
276
277 In overwrite mode, this function inserts the character anyway, and
278 does not handle octal digits specially. This means that if you use
279 overwrite as your normal editing mode, you can use this function to
280 insert characters when necessary.
281
282 In binary overwrite mode, this function does overwrite, and octal
283 digits are interpreted as a character code. This is intended to be
284 useful for editing binary files."
285 (interactive "*p")
286 (let ((char (if (or (not overwrite-mode)
287 (eq overwrite-mode 'overwrite-mode-binary))
288 (read-quoted-char)
289 (read-char))))
290 ;; Assume character codes 0240 - 0377 stand for characters in some
291 ;; single-byte character set, and convert them to Emacs
292 ;; characters.
293 (if (and enable-multibyte-characters
294 (>= char ?\240)
295 (<= char ?\377))
296 (setq char (unibyte-char-to-multibyte char)))
297 (if (> arg 0)
298 (if (eq overwrite-mode 'overwrite-mode-binary)
299 (delete-char arg)))
300 (while (> arg 0)
301 (insert-and-inherit char)
302 (setq arg (1- arg)))))
303
304 (defun forward-to-indentation (arg)
305 "Move forward ARG lines and position at first nonblank character."
306 (interactive "p")
307 (forward-line arg)
308 (skip-chars-forward " \t"))
309
310 (defun backward-to-indentation (arg)
311 "Move backward ARG lines and position at first nonblank character."
312 (interactive "p")
313 (forward-line (- arg))
314 (skip-chars-forward " \t"))
315
316 (defun back-to-indentation ()
317 "Move point to the first non-whitespace character on this line."
318 (interactive)
319 (beginning-of-line 1)
320 (skip-chars-forward " \t"))
321
322 (defun fixup-whitespace ()
323 "Fixup white space between objects around point.
324 Leave one space or none, according to the context."
325 (interactive "*")
326 (save-excursion
327 (delete-horizontal-space)
328 (if (or (looking-at "^\\|\\s)")
329 (save-excursion (forward-char -1)
330 (looking-at "$\\|\\s(\\|\\s'")))
331 nil
332 (insert ?\ ))))
333
334 (defun delete-horizontal-space ()
335 "Delete all spaces and tabs around point."
336 (interactive "*")
337 (skip-chars-backward " \t" (field-beginning))
338 (delete-region (point) (progn (skip-chars-forward " \t") (point))))
339
340 (defun just-one-space ()
341 "Delete all spaces and tabs around point, leaving one space."
342 (interactive "*")
343 (skip-chars-backward " \t")
344 (if (= (following-char) ? )
345 (forward-char 1)
346 (insert ? ))
347 (delete-region (point) (progn (skip-chars-forward " \t") (point))))
348
349
350 (defun beginning-of-buffer (&optional arg)
351 "Move point to the beginning of the buffer; leave mark at previous position.
352 With arg N, put point N/10 of the way from the beginning.
353
354 If the buffer is narrowed, this command uses the beginning and size
355 of the accessible part of the buffer.
356
357 Don't use this command in Lisp programs!
358 \(goto-char (point-min)) is faster and avoids clobbering the mark."
359 (interactive "P")
360 (push-mark)
361 (let ((size (- (point-max) (point-min))))
362 (goto-char (if arg
363 (+ (point-min)
364 (if (> size 10000)
365 ;; Avoid overflow for large buffer sizes!
366 (* (prefix-numeric-value arg)
367 (/ size 10))
368 (/ (+ 10 (* size (prefix-numeric-value arg))) 10)))
369 (point-min))))
370 (if arg (forward-line 1)))
371
372 (defun end-of-buffer (&optional arg)
373 "Move point to the end of the buffer; leave mark at previous position.
374 With arg N, put point N/10 of the way from the end.
375
376 If the buffer is narrowed, this command uses the beginning and size
377 of the accessible part of the buffer.
378
379 Don't use this command in Lisp programs!
380 \(goto-char (point-max)) is faster and avoids clobbering the mark."
381 (interactive "P")
382 (push-mark)
383 (let ((size (- (point-max) (point-min))))
384 (goto-char (if arg
385 (- (point-max)
386 (if (> size 10000)
387 ;; Avoid overflow for large buffer sizes!
388 (* (prefix-numeric-value arg)
389 (/ size 10))
390 (/ (* size (prefix-numeric-value arg)) 10)))
391 (point-max))))
392 ;; If we went to a place in the middle of the buffer,
393 ;; adjust it to the beginning of a line.
394 (cond (arg (forward-line 1))
395 ((< (point) (window-end nil t))
396 ;; If the end of the buffer is not already on the screen,
397 ;; then scroll specially to put it near, but not at, the bottom.
398 (overlay-recenter (point))
399 (recenter -3))))
400
401 (defun mark-whole-buffer ()
402 "Put point at beginning and mark at end of buffer.
403 You probably should not use this function in Lisp programs;
404 it is usually a mistake for a Lisp function to use any subroutine
405 that uses or sets the mark."
406 (interactive)
407 (push-mark (point))
408 (push-mark (point-max) nil t)
409 (goto-char (point-min)))
410
411
412 ;; Counting lines, one way or another.
413
414 (defun goto-line (arg)
415 "Goto line ARG, counting from line 1 at beginning of buffer."
416 (interactive "NGoto line: ")
417 (setq arg (prefix-numeric-value arg))
418 (save-restriction
419 (widen)
420 (goto-char 1)
421 (if (eq selective-display t)
422 (re-search-forward "[\n\C-m]" nil 'end (1- arg))
423 (forward-line (1- arg)))))
424
425 (defun count-lines-region (start end)
426 "Print number of lines and characters in the region."
427 (interactive "r")
428 (message "Region has %d lines, %d characters"
429 (count-lines start end) (- end start)))
430
431 (defun what-line ()
432 "Print the current buffer line number and narrowed line number of point."
433 (interactive)
434 (let ((opoint (point)) start)
435 (save-excursion
436 (save-restriction
437 (goto-char (point-min))
438 (widen)
439 (beginning-of-line)
440 (setq start (point))
441 (goto-char opoint)
442 (beginning-of-line)
443 (if (/= start 1)
444 (message "line %d (narrowed line %d)"
445 (1+ (count-lines 1 (point)))
446 (1+ (count-lines start (point))))
447 (message "Line %d" (1+ (count-lines 1 (point)))))))))
448
449 (defun count-lines (start end)
450 "Return number of lines between START and END.
451 This is usually the number of newlines between them,
452 but can be one more if START is not equal to END
453 and the greater of them is not at the start of a line."
454 (save-excursion
455 (save-restriction
456 (narrow-to-region start end)
457 (goto-char (point-min))
458 (if (eq selective-display t)
459 (save-match-data
460 (let ((done 0))
461 (while (re-search-forward "[\n\C-m]" nil t 40)
462 (setq done (+ 40 done)))
463 (while (re-search-forward "[\n\C-m]" nil t 1)
464 (setq done (+ 1 done)))
465 (goto-char (point-max))
466 (if (and (/= start end)
467 (not (bolp)))
468 (1+ done)
469 done)))
470 (- (buffer-size) (forward-line (buffer-size)))))))
471
472 (defun what-cursor-position (&optional detail)
473 "Print info on cursor position (on screen and within buffer).
474 Also describe the character after point, and give its character code
475 in octal, decimal and hex.
476
477 For a non-ASCII multibyte character, also give its encoding in the
478 buffer's selected coding system if the coding system encodes the
479 character safely. If the character is encoded into one byte, that
480 code is shown in hex. If the character is encoded into more than one
481 byte, just \"...\" is shown.
482
483 In addition, with prefix argument, show details about that character
484 in *Help* buffer. See also the command `describe-char-after'."
485 (interactive "P")
486 (let* ((char (following-char))
487 (beg (point-min))
488 (end (point-max))
489 (pos (point))
490 (total (buffer-size))
491 (percent (if (> total 50000)
492 ;; Avoid overflow from multiplying by 100!
493 (/ (+ (/ total 200) (1- pos)) (max (/ total 100) 1))
494 (/ (+ (/ total 2) (* 100 (1- pos))) (max total 1))))
495 (hscroll (if (= (window-hscroll) 0)
496 ""
497 (format " Hscroll=%d" (window-hscroll))))
498 (col (current-column)))
499 (if (= pos end)
500 (if (or (/= beg 1) (/= end (1+ total)))
501 (message "point=%d of %d (%d%%) <%d - %d> column %d %s"
502 pos total percent beg end col hscroll)
503 (message "point=%d of %d (%d%%) column %d %s"
504 pos total percent col hscroll))
505 (let ((coding buffer-file-coding-system)
506 encoded encoding-msg)
507 (if (or (not coding)
508 (eq (coding-system-type coding) t))
509 (setq coding default-buffer-file-coding-system))
510 (if (not (char-valid-p char))
511 (setq encoding-msg
512 (format "(0%o, %d, 0x%x, invalid)" char char char))
513 (setq encoded (and (>= char 128) (encode-coding-char char coding)))
514 (setq encoding-msg
515 (if encoded
516 (format "(0%o, %d, 0x%x, file %s)"
517 char char char
518 (if (> (length encoded) 1)
519 "..."
520 (encoded-string-description encoded coding)))
521 (format "(0%o, %d, 0x%x)" char char char))))
522 (if detail
523 ;; We show the detailed information about CHAR.
524 (describe-char-after (point)))
525 (if (or (/= beg 1) (/= end (1+ total)))
526 (message "Char: %s %s point=%d of %d (%d%%) <%d - %d> column %d %s"
527 (if (< char 256)
528 (single-key-description char)
529 (buffer-substring-no-properties (point) (1+ (point))))
530 encoding-msg pos total percent beg end col hscroll)
531 (message "Char: %s %s point=%d of %d (%d%%) column %d %s"
532 (if (< char 256)
533 (single-key-description char)
534 (buffer-substring-no-properties (point) (1+ (point))))
535 encoding-msg pos total percent col hscroll))))))
536
537 (defvar read-expression-map
538 (let ((m (make-sparse-keymap)))
539 (define-key m "\M-\t" 'lisp-complete-symbol)
540 (set-keymap-parent m minibuffer-local-map)
541 m)
542 "Minibuffer keymap used for reading Lisp expressions.")
543
544 (defvar read-expression-history nil)
545
546 (defcustom eval-expression-print-level 4
547 "*Value to use for `print-level' when printing value in `eval-expression'."
548 :group 'lisp
549 :type 'integer
550 :version "21.1")
551
552 (defcustom eval-expression-print-length 12
553 "*Value to use for `print-length' when printing value in `eval-expression'."
554 :group 'lisp
555 :type '(choice (const nil) integer)
556 :version "21.1")
557
558 (defcustom eval-expression-debug-on-error t
559 "*Non-nil means set `debug-on-error' when evaluating in `eval-expression'.
560 If nil, don't change the value of `debug-on-error'."
561 :group 'lisp
562 :type 'boolean
563 :version "21.1")
564
565 ;; We define this, rather than making `eval' interactive,
566 ;; for the sake of completion of names like eval-region, eval-current-buffer.
567 (defun eval-expression (eval-expression-arg
568 &optional eval-expression-insert-value)
569 "Evaluate EXPRESSION and print value in minibuffer.
570 Value is also consed on to front of the variable `values'."
571 (interactive
572 (list (read-from-minibuffer "Eval: "
573 nil read-expression-map t
574 'read-expression-history)
575 current-prefix-arg))
576
577 (if (null eval-expression-debug-on-error)
578 (setq values (cons (eval eval-expression-arg) values))
579 (let ((old-value (make-symbol "t")) new-value)
580 ;; Bind debug-on-error to something unique so that we can
581 ;; detect when evaled code changes it.
582 (let ((debug-on-error old-value))
583 (setq values (cons (eval eval-expression-arg) values))
584 (setq new-value debug-on-error))
585 ;; If evaled code has changed the value of debug-on-error,
586 ;; propagate that change to the global binding.
587 (unless (eq old-value new-value)
588 (setq debug-on-error new-value))))
589
590 (let ((print-length eval-expression-print-length)
591 (print-level eval-expression-print-level))
592 (prin1 (car values)
593 (if eval-expression-insert-value (current-buffer) t))))
594
595 (defun edit-and-eval-command (prompt command)
596 "Prompting with PROMPT, let user edit COMMAND and eval result.
597 COMMAND is a Lisp expression. Let user edit that expression in
598 the minibuffer, then read and evaluate the result."
599 (let ((command (read-from-minibuffer prompt
600 (prin1-to-string command)
601 read-expression-map t
602 '(command-history . 1))))
603 ;; If command was added to command-history as a string,
604 ;; get rid of that. We want only evaluable expressions there.
605 (if (stringp (car command-history))
606 (setq command-history (cdr command-history)))
607
608 ;; If command to be redone does not match front of history,
609 ;; add it to the history.
610 (or (equal command (car command-history))
611 (setq command-history (cons command command-history)))
612 (eval command)))
613
614 (defun repeat-complex-command (arg)
615 "Edit and re-evaluate last complex command, or ARGth from last.
616 A complex command is one which used the minibuffer.
617 The command is placed in the minibuffer as a Lisp form for editing.
618 The result is executed, repeating the command as changed.
619 If the command has been changed or is not the most recent previous command
620 it is added to the front of the command history.
621 You can use the minibuffer history commands \\<minibuffer-local-map>\\[next-history-element] and \\[previous-history-element]
622 to get different commands to edit and resubmit."
623 (interactive "p")
624 (let ((elt (nth (1- arg) command-history))
625 newcmd)
626 (if elt
627 (progn
628 (setq newcmd
629 (let ((print-level nil)
630 (minibuffer-history-position arg)
631 (minibuffer-history-sexp-flag (1+ (minibuffer-depth))))
632 (read-from-minibuffer
633 "Redo: " (prin1-to-string elt) read-expression-map t
634 (cons 'command-history arg))))
635
636 ;; If command was added to command-history as a string,
637 ;; get rid of that. We want only evaluable expressions there.
638 (if (stringp (car command-history))
639 (setq command-history (cdr command-history)))
640
641 ;; If command to be redone does not match front of history,
642 ;; add it to the history.
643 (or (equal newcmd (car command-history))
644 (setq command-history (cons newcmd command-history)))
645 (eval newcmd))
646 (ding))))
647
648 (defvar minibuffer-history nil
649 "Default minibuffer history list.
650 This is used for all minibuffer input
651 except when an alternate history list is specified.")
652 (defvar minibuffer-history-sexp-flag nil
653 "Non-nil when doing history operations on `command-history'.
654 More generally, indicates that the history list being acted on
655 contains expressions rather than strings.
656 It is only valid if its value equals the current minibuffer depth,
657 to handle recursive uses of the minibuffer.")
658 (setq minibuffer-history-variable 'minibuffer-history)
659 (setq minibuffer-history-position nil)
660 (defvar minibuffer-history-search-history nil)
661
662 (mapcar
663 (lambda (key-and-command)
664 (mapcar
665 (lambda (keymap-and-completionp)
666 ;; Arg is (KEYMAP-SYMBOL . COMPLETION-MAP-P).
667 ;; If the cdr of KEY-AND-COMMAND (the command) is a cons,
668 ;; its car is used if COMPLETION-MAP-P is nil, its cdr if it is t.
669 (define-key (symbol-value (car keymap-and-completionp))
670 (car key-and-command)
671 (let ((command (cdr key-and-command)))
672 (if (consp command)
673 ;; (and ... nil) => ... turns back on the completion-oriented
674 ;; history commands which rms turned off since they seem to
675 ;; do things he doesn't like.
676 (if (and (cdr keymap-and-completionp) nil) ;XXX turned off
677 (progn (error "EMACS BUG!") (cdr command))
678 (car command))
679 command))))
680 '((minibuffer-local-map . nil)
681 (minibuffer-local-ns-map . nil)
682 (minibuffer-local-completion-map . t)
683 (minibuffer-local-must-match-map . t)
684 (read-expression-map . nil))))
685 '(("\en" . (next-history-element . next-complete-history-element))
686 ([next] . (next-history-element . next-complete-history-element))
687 ("\ep" . (previous-history-element . previous-complete-history-element))
688 ([prior] . (previous-history-element . previous-complete-history-element))
689 ("\er" . previous-matching-history-element)
690 ("\es" . next-matching-history-element)))
691
692 (defvar minibuffer-text-before-history nil
693 "Text that was in this minibuffer before any history commands.
694 This is nil if there have not yet been any history commands
695 in this use of the minibuffer.")
696
697 (add-hook 'minibuffer-setup-hook 'minibuffer-history-initialize)
698
699 (defun minibuffer-history-initialize ()
700 (setq minibuffer-text-before-history nil))
701
702 (defun minibuffer-avoid-prompt (new old)
703 "A point-motion hook for the minibuffer, that moves point out of the prompt."
704 (constrain-to-field nil (point-max)))
705
706 (defcustom minibuffer-history-case-insensitive-variables nil
707 "*Minibuffer history variables for which matching should ignore case.
708 If a history variable is a member of this list, then the
709 \\[previous-matching-history-element] and \\[next-matching-history-element]\
710 commands ignore case when searching it, regardless of `case-fold-search'."
711 :type '(repeat variable)
712 :group 'minibuffer)
713
714 (defun previous-matching-history-element (regexp n)
715 "Find the previous history element that matches REGEXP.
716 \(Previous history elements refer to earlier actions.)
717 With prefix argument N, search for Nth previous match.
718 If N is negative, find the next or Nth next match.
719 An uppercase letter in REGEXP makes the search case-sensitive.
720 See also `minibuffer-history-case-insensitive-variables'."
721 (interactive
722 (let* ((enable-recursive-minibuffers t)
723 (regexp (read-from-minibuffer "Previous element matching (regexp): "
724 nil
725 minibuffer-local-map
726 nil
727 'minibuffer-history-search-history)))
728 ;; Use the last regexp specified, by default, if input is empty.
729 (list (if (string= regexp "")
730 (if minibuffer-history-search-history
731 (car minibuffer-history-search-history)
732 (error "No previous history search regexp"))
733 regexp)
734 (prefix-numeric-value current-prefix-arg))))
735 (unless (zerop n)
736 (if (and (zerop minibuffer-history-position)
737 (null minibuffer-text-before-history))
738 (setq minibuffer-text-before-history (field-string (point-max))))
739 (let ((history (symbol-value minibuffer-history-variable))
740 (case-fold-search
741 (if (isearch-no-upper-case-p regexp t) ; assume isearch.el is dumped
742 ;; On some systems, ignore case for file names.
743 (if (memq minibuffer-history-variable
744 minibuffer-history-case-insensitive-variables)
745 t
746 ;; Respect the user's setting for case-fold-search:
747 case-fold-search)
748 nil))
749 prevpos
750 match-string
751 match-offset
752 (pos minibuffer-history-position))
753 (while (/= n 0)
754 (setq prevpos pos)
755 (setq pos (min (max 1 (+ pos (if (< n 0) -1 1))) (length history)))
756 (when (= pos prevpos)
757 (error (if (= pos 1)
758 "No later matching history item"
759 "No earlier matching history item")))
760 (setq match-string
761 (if (eq minibuffer-history-sexp-flag (minibuffer-depth))
762 (let ((print-level nil))
763 (prin1-to-string (nth (1- pos) history)))
764 (nth (1- pos) history)))
765 (setq match-offset
766 (if (< n 0)
767 (and (string-match regexp match-string)
768 (match-end 0))
769 (and (string-match (concat ".*\\(" regexp "\\)") match-string)
770 (match-beginning 1))))
771 (when match-offset
772 (setq n (+ n (if (< n 0) 1 -1)))))
773 (setq minibuffer-history-position pos)
774 (goto-char (point-max))
775 (delete-field)
776 (insert match-string)
777 (goto-char (+ (field-beginning) match-offset))))
778 (if (or (eq (car (car command-history)) 'previous-matching-history-element)
779 (eq (car (car command-history)) 'next-matching-history-element))
780 (setq command-history (cdr command-history))))
781
782 (defun next-matching-history-element (regexp n)
783 "Find the next history element that matches REGEXP.
784 \(The next history element refers to a more recent action.)
785 With prefix argument N, search for Nth next match.
786 If N is negative, find the previous or Nth previous match.
787 An uppercase letter in REGEXP makes the search case-sensitive."
788 (interactive
789 (let* ((enable-recursive-minibuffers t)
790 (regexp (read-from-minibuffer "Next element matching (regexp): "
791 nil
792 minibuffer-local-map
793 nil
794 'minibuffer-history-search-history)))
795 ;; Use the last regexp specified, by default, if input is empty.
796 (list (if (string= regexp "")
797 (setcar minibuffer-history-search-history
798 (nth 1 minibuffer-history-search-history))
799 regexp)
800 (prefix-numeric-value current-prefix-arg))))
801 (previous-matching-history-element regexp (- n)))
802
803 (defvar minibuffer-temporary-goal-position nil)
804
805 (defun next-history-element (n)
806 "Insert the next element of the minibuffer history into the minibuffer."
807 (interactive "p")
808 (or (zerop n)
809 (let ((narg (- minibuffer-history-position n))
810 (minimum (if minibuffer-default -1 0))
811 elt minibuffer-returned-to-present)
812 (if (and (zerop minibuffer-history-position)
813 (null minibuffer-text-before-history))
814 (setq minibuffer-text-before-history (field-string (point-max))))
815 (if (< narg minimum)
816 (if minibuffer-default
817 (error "End of history; no next item")
818 (error "End of history; no default available")))
819 (if (> narg (length (symbol-value minibuffer-history-variable)))
820 (error "Beginning of history; no preceding item"))
821 (unless (or (eq last-command 'next-history-element)
822 (eq last-command 'previous-history-element))
823 (let ((prompt-end (field-beginning (point-max))))
824 (set (make-local-variable 'minibuffer-temporary-goal-position)
825 (cond ((<= (point) prompt-end) prompt-end)
826 ((eobp) nil)
827 (t (point))))))
828 (goto-char (point-max))
829 (delete-field)
830 (setq minibuffer-history-position narg)
831 (cond ((= narg -1)
832 (setq elt minibuffer-default))
833 ((= narg 0)
834 (setq elt (or minibuffer-text-before-history ""))
835 (setq minibuffer-returned-to-present t)
836 (setq minibuffer-text-before-history nil))
837 (t (setq elt (nth (1- minibuffer-history-position)
838 (symbol-value minibuffer-history-variable)))))
839 (insert
840 (if (and (eq minibuffer-history-sexp-flag (minibuffer-depth))
841 (not minibuffer-returned-to-present))
842 (let ((print-level nil))
843 (prin1-to-string elt))
844 elt))
845 (goto-char (or minibuffer-temporary-goal-position (point-max))))))
846
847 (defun previous-history-element (n)
848 "Inserts the previous element of the minibuffer history into the minibuffer."
849 (interactive "p")
850 (next-history-element (- n)))
851
852 (defun next-complete-history-element (n)
853 "Get next history element which completes the minibuffer before the point.
854 The contents of the minibuffer after the point are deleted, and replaced
855 by the new completion."
856 (interactive "p")
857 (let ((point-at-start (point)))
858 (next-matching-history-element
859 (concat
860 "^" (regexp-quote (buffer-substring (field-beginning) (point))))
861 n)
862 ;; next-matching-history-element always puts us at (point-min).
863 ;; Move to the position we were at before changing the buffer contents.
864 ;; This is still sensical, because the text before point has not changed.
865 (goto-char point-at-start)))
866
867 (defun previous-complete-history-element (n)
868 "\
869 Get previous history element which completes the minibuffer before the point.
870 The contents of the minibuffer after the point are deleted, and replaced
871 by the new completion."
872 (interactive "p")
873 (next-complete-history-element (- n)))
874
875 ;; These two functions are for compatibility with the old subrs of the
876 ;; same name.
877
878 (defun minibuffer-prompt-width ()
879 "Return the display width of the minibuffer prompt.
880 Return 0 if current buffer is not a mini-buffer."
881 ;; Return the width of everything before the field at the end of
882 ;; the buffer; this should be 0 for normal buffers.
883 (1- (field-beginning (point-max))))
884
885 (defun minibuffer-prompt-end ()
886 "Return the buffer position of the end of the minibuffer prompt.
887 Return (point-min) if current buffer is not a mini-buffer."
888 (field-beginning (point-max)))
889
890 (defun minibuffer-contents ()
891 "Return the user input in a minbuffer as a string.
892 The current buffer must be a minibuffer."
893 (field-string (point-max)))
894
895 (defun minibuffer-contents-no-properties ()
896 "Return the user input in a minbuffer as a string, without text-properties.
897 The current buffer must be a minibuffer."
898 (field-string-no-properties (point-max)))
899
900 (defun delete-minibuffer-contents ()
901 "Delete all user input in a minibuffer.
902 The current buffer must be a minibuffer."
903 (delete-field (point-max)))
904
905 ;Put this on C-x u, so we can force that rather than C-_ into startup msg
906 (defalias 'advertised-undo 'undo)
907
908 (defun undo (&optional arg)
909 "Undo some previous changes.
910 Repeat this command to undo more changes.
911 A numeric argument serves as a repeat count.
912
913 In Transient Mark mode when the mark is active, only undo changes within
914 the current region. Similarly, when not in Transient Mark mode, just C-u
915 as an argument limits undo to changes within the current region."
916 (interactive "*P")
917 ;; If we don't get all the way thru, make last-command indicate that
918 ;; for the following command.
919 (setq this-command t)
920 (let ((modified (buffer-modified-p))
921 (recent-save (recent-auto-save-p)))
922 (or (eq (selected-window) (minibuffer-window))
923 (message "Undo!"))
924 (unless (eq last-command 'undo)
925 (if (if transient-mark-mode mark-active (and arg (not (numberp arg))))
926 (undo-start (region-beginning) (region-end))
927 (undo-start))
928 ;; get rid of initial undo boundary
929 (undo-more 1))
930 (undo-more
931 (if (or transient-mark-mode (numberp arg))
932 (prefix-numeric-value arg)
933 1))
934 ;; Don't specify a position in the undo record for the undo command.
935 ;; Instead, undoing this should move point to where the change is.
936 (let ((tail buffer-undo-list)
937 done)
938 (while (and tail (not done) (not (null (car tail))))
939 (if (integerp (car tail))
940 (progn
941 (setq done t)
942 (setq buffer-undo-list (delq (car tail) buffer-undo-list))))
943 (setq tail (cdr tail))))
944 (and modified (not (buffer-modified-p))
945 (delete-auto-save-file-if-necessary recent-save)))
946 ;; If we do get all the way thru, make this-command indicate that.
947 (setq this-command 'undo))
948
949 (defvar pending-undo-list nil
950 "Within a run of consecutive undo commands, list remaining to be undone.")
951
952 (defvar undo-in-progress nil
953 "Non-nil while performing an undo.
954 Some change-hooks test this variable to do something different.")
955
956 (defun undo-more (count)
957 "Undo back N undo-boundaries beyond what was already undone recently.
958 Call `undo-start' to get ready to undo recent changes,
959 then call `undo-more' one or more times to undo them."
960 (or pending-undo-list
961 (error "No further undo information"))
962 (let ((undo-in-progress t))
963 (setq pending-undo-list (primitive-undo count pending-undo-list))))
964
965 ;; Deep copy of a list
966 (defun undo-copy-list (list)
967 "Make a copy of undo list LIST."
968 (mapcar 'undo-copy-list-1 list))
969
970 (defun undo-copy-list-1 (elt)
971 (if (consp elt)
972 (cons (car elt) (undo-copy-list-1 (cdr elt)))
973 elt))
974
975 (defun undo-start (&optional beg end)
976 "Set `pending-undo-list' to the front of the undo list.
977 The next call to `undo-more' will undo the most recently made change.
978 If BEG and END are specified, then only undo elements
979 that apply to text between BEG and END are used; other undo elements
980 are ignored. If BEG and END are nil, all undo elements are used."
981 (if (eq buffer-undo-list t)
982 (error "No undo information in this buffer"))
983 (setq pending-undo-list
984 (if (and beg end (not (= beg end)))
985 (undo-make-selective-list (min beg end) (max beg end))
986 buffer-undo-list)))
987
988 (defvar undo-adjusted-markers)
989
990 (defun undo-make-selective-list (start end)
991 "Return a list of undo elements for the region START to END.
992 The elements come from `buffer-undo-list', but we keep only
993 the elements inside this region, and discard those outside this region.
994 If we find an element that crosses an edge of this region,
995 we stop and ignore all further elements."
996 (let ((undo-list-copy (undo-copy-list buffer-undo-list))
997 (undo-list (list nil))
998 undo-adjusted-markers
999 some-rejected
1000 undo-elt undo-elt temp-undo-list delta)
1001 (while undo-list-copy
1002 (setq undo-elt (car undo-list-copy))
1003 (let ((keep-this
1004 (cond ((and (consp undo-elt) (eq (car undo-elt) t))
1005 ;; This is a "was unmodified" element.
1006 ;; Keep it if we have kept everything thus far.
1007 (not some-rejected))
1008 (t
1009 (undo-elt-in-region undo-elt start end)))))
1010 (if keep-this
1011 (progn
1012 (setq end (+ end (cdr (undo-delta undo-elt))))
1013 ;; Don't put two nils together in the list
1014 (if (not (and (eq (car undo-list) nil)
1015 (eq undo-elt nil)))
1016 (setq undo-list (cons undo-elt undo-list))))
1017 (if (undo-elt-crosses-region undo-elt start end)
1018 (setq undo-list-copy nil)
1019 (setq some-rejected t)
1020 (setq temp-undo-list (cdr undo-list-copy))
1021 (setq delta (undo-delta undo-elt))
1022
1023 (when (/= (cdr delta) 0)
1024 (let ((position (car delta))
1025 (offset (cdr delta)))
1026
1027 ;; Loop down the earlier events adjusting their buffer positions
1028 ;; to reflect the fact that a change to the buffer isn't being
1029 ;; undone. We only need to process those element types which
1030 ;; undo-elt-in-region will return as being in the region since
1031 ;; only those types can ever get into the output
1032
1033 (while temp-undo-list
1034 (setq undo-elt (car temp-undo-list))
1035 (cond ((integerp undo-elt)
1036 (if (>= undo-elt position)
1037 (setcar temp-undo-list (- undo-elt offset))))
1038 ((atom undo-elt) nil)
1039 ((stringp (car undo-elt))
1040 ;; (TEXT . POSITION)
1041 (let ((text-pos (abs (cdr undo-elt)))
1042 (point-at-end (< (cdr undo-elt) 0 )))
1043 (if (>= text-pos position)
1044 (setcdr undo-elt (* (if point-at-end -1 1)
1045 (- text-pos offset))))))
1046 ((integerp (car undo-elt))
1047 ;; (BEGIN . END)
1048 (when (>= (car undo-elt) position)
1049 (setcar undo-elt (- (car undo-elt) offset))
1050 (setcdr undo-elt (- (cdr undo-elt) offset))))
1051 ((null (car undo-elt))
1052 ;; (nil PROPERTY VALUE BEG . END)
1053 (let ((tail (nthcdr 3 undo-elt)))
1054 (when (>= (car tail) position)
1055 (setcar tail (- (car tail) offset))
1056 (setcdr tail (- (cdr tail) offset))))))
1057 (setq temp-undo-list (cdr temp-undo-list))))))))
1058 (setq undo-list-copy (cdr undo-list-copy)))
1059 (nreverse undo-list)))
1060
1061 (defun undo-elt-in-region (undo-elt start end)
1062 "Determine whether UNDO-ELT falls inside the region START ... END.
1063 If it crosses the edge, we return nil."
1064 (cond ((integerp undo-elt)
1065 (and (>= undo-elt start)
1066 (< undo-elt end)))
1067 ((eq undo-elt nil)
1068 t)
1069 ((atom undo-elt)
1070 nil)
1071 ((stringp (car undo-elt))
1072 ;; (TEXT . POSITION)
1073 (and (>= (abs (cdr undo-elt)) start)
1074 (< (abs (cdr undo-elt)) end)))
1075 ((and (consp undo-elt) (markerp (car undo-elt)))
1076 ;; This is a marker-adjustment element (MARKER . ADJUSTMENT).
1077 ;; See if MARKER is inside the region.
1078 (let ((alist-elt (assq (car undo-elt) undo-adjusted-markers)))
1079 (unless alist-elt
1080 (setq alist-elt (cons (car undo-elt)
1081 (marker-position (car undo-elt))))
1082 (setq undo-adjusted-markers
1083 (cons alist-elt undo-adjusted-markers)))
1084 (and (cdr alist-elt)
1085 (>= (cdr alist-elt) start)
1086 (< (cdr alist-elt) end))))
1087 ((null (car undo-elt))
1088 ;; (nil PROPERTY VALUE BEG . END)
1089 (let ((tail (nthcdr 3 undo-elt)))
1090 (and (>= (car tail) start)
1091 (< (cdr tail) end))))
1092 ((integerp (car undo-elt))
1093 ;; (BEGIN . END)
1094 (and (>= (car undo-elt) start)
1095 (< (cdr undo-elt) end)))))
1096
1097 (defun undo-elt-crosses-region (undo-elt start end)
1098 "Test whether UNDO-ELT crosses one edge of that region START ... END.
1099 This assumes we have already decided that UNDO-ELT
1100 is not *inside* the region START...END."
1101 (cond ((atom undo-elt) nil)
1102 ((null (car undo-elt))
1103 ;; (nil PROPERTY VALUE BEG . END)
1104 (let ((tail (nthcdr 3 undo-elt)))
1105 (not (or (< (car tail) end)
1106 (> (cdr tail) start)))))
1107 ((integerp (car undo-elt))
1108 ;; (BEGIN . END)
1109 (not (or (< (car undo-elt) end)
1110 (> (cdr undo-elt) start))))))
1111
1112 ;; Return the first affected buffer position and the delta for an undo element
1113 ;; delta is defined as the change in subsequent buffer positions if we *did*
1114 ;; the undo.
1115 (defun undo-delta (undo-elt)
1116 (if (consp undo-elt)
1117 (cond ((stringp (car undo-elt))
1118 ;; (TEXT . POSITION)
1119 (cons (abs (cdr undo-elt)) (length (car undo-elt))))
1120 ((integerp (car undo-elt))
1121 ;; (BEGIN . END)
1122 (cons (car undo-elt) (- (car undo-elt) (cdr undo-elt))))
1123 (t
1124 '(0 . 0)))
1125 '(0 . 0)))
1126
1127 (defvar shell-command-history nil
1128 "History list for some commands that read shell commands.")
1129
1130 (defvar shell-command-switch "-c"
1131 "Switch used to have the shell execute its command line argument.")
1132
1133 (defvar shell-command-default-error-buffer nil
1134 "*Buffer name for `shell-command' and `shell-command-on-region' error output.
1135 This buffer is used when `shell-command' or 'shell-command-on-region'
1136 is run interactively. A value of nil means that output to stderr and
1137 stdout will be intermixed in the output stream.")
1138
1139 (defun shell-command (command &optional output-buffer error-buffer)
1140 "Execute string COMMAND in inferior shell; display output, if any.
1141 With prefix argument, insert the COMMAND's output at point.
1142
1143 If COMMAND ends in ampersand, execute it asynchronously.
1144 The output appears in the buffer `*Async Shell Command*'.
1145 That buffer is in shell mode.
1146
1147 Otherwise, COMMAND is executed synchronously. The output appears in
1148 the buffer `*Shell Command Output*'. If the output is short enough to
1149 display in the echo area (which is determined by the variables
1150 `resize-mini-windows' and `max-mini-window-height'), it is shown
1151 there, but it is nonetheless available in buffer `*Shell Command
1152 Output*' even though that buffer is not automatically displayed. If
1153 there is no output, or if output is inserted in the current buffer,
1154 then `*Shell Command Output*' is deleted.
1155
1156 To specify a coding system for converting non-ASCII characters
1157 in the shell command output, use \\[universal-coding-system-argument]
1158 before this command.
1159
1160 Noninteractive callers can specify coding systems by binding
1161 `coding-system-for-read' and `coding-system-for-write'.
1162
1163 The optional second argument OUTPUT-BUFFER, if non-nil,
1164 says to put the output in some other buffer.
1165 If OUTPUT-BUFFER is a buffer or buffer name, put the output there.
1166 If OUTPUT-BUFFER is not a buffer and not nil,
1167 insert output in current buffer. (This cannot be done asynchronously.)
1168 In either case, the output is inserted after point (leaving mark after it).
1169
1170 If the optional third argument ERROR-BUFFER is non-nil, it is a buffer
1171 or buffer name to which to direct the command's standard error output.
1172 If it is nil, error output is mingled with regular output.
1173 In an interactive call, the variable `shell-command-default-error-buffer'
1174 specifies the value of ERROR-BUFFER."
1175
1176 (interactive (list (read-from-minibuffer "Shell command: "
1177 nil nil nil 'shell-command-history)
1178 current-prefix-arg
1179 shell-command-default-error-buffer))
1180 ;; Look for a handler in case default-directory is a remote file name.
1181 (let ((handler
1182 (find-file-name-handler (directory-file-name default-directory)
1183 'shell-command)))
1184 (if handler
1185 (funcall handler 'shell-command command output-buffer error-buffer)
1186 (if (and output-buffer
1187 (not (or (bufferp output-buffer) (stringp output-buffer))))
1188 (let ((error-file
1189 (if error-buffer
1190 (make-temp-file
1191 (expand-file-name "scor"
1192 (or small-temporary-file-directory
1193 temporary-file-directory)))
1194 nil)))
1195 (barf-if-buffer-read-only)
1196 (push-mark nil t)
1197 ;; We do not use -f for csh; we will not support broken use of
1198 ;; .cshrcs. Even the BSD csh manual says to use
1199 ;; "if ($?prompt) exit" before things which are not useful
1200 ;; non-interactively. Besides, if someone wants their other
1201 ;; aliases for shell commands then they can still have them.
1202 (call-process shell-file-name nil
1203 (if error-file
1204 (list t error-file)
1205 t)
1206 nil shell-command-switch command)
1207 (when (and error-file (file-exists-p error-file))
1208 (if (< 0 (nth 7 (file-attributes error-file)))
1209 (with-current-buffer (get-buffer-create error-buffer)
1210 (let ((pos-from-end (- (point-max) (point))))
1211 (or (bobp)
1212 (insert "\f\n"))
1213 ;; Do no formatting while reading error file,
1214 ;; because that can run a shell command, and we
1215 ;; don't want that to cause an infinite recursion.
1216 (format-insert-file error-file nil)
1217 ;; Put point after the inserted errors.
1218 (goto-char (- (point-max) pos-from-end)))
1219 (display-buffer (current-buffer))))
1220 (delete-file error-file))
1221 ;; This is like exchange-point-and-mark, but doesn't
1222 ;; activate the mark. It is cleaner to avoid activation,
1223 ;; even though the command loop would deactivate the mark
1224 ;; because we inserted text.
1225 (goto-char (prog1 (mark t)
1226 (set-marker (mark-marker) (point)
1227 (current-buffer)))))
1228 ;; Preserve the match data in case called from a program.
1229 (save-match-data
1230 (if (string-match "[ \t]*&[ \t]*$" command)
1231 ;; Command ending with ampersand means asynchronous.
1232 (let ((buffer (get-buffer-create
1233 (or output-buffer "*Async Shell Command*")))
1234 (directory default-directory)
1235 proc)
1236 ;; Remove the ampersand.
1237 (setq command (substring command 0 (match-beginning 0)))
1238 ;; If will kill a process, query first.
1239 (setq proc (get-buffer-process buffer))
1240 (if proc
1241 (if (yes-or-no-p "A command is running. Kill it? ")
1242 (kill-process proc)
1243 (error "Shell command in progress")))
1244 (save-excursion
1245 (set-buffer buffer)
1246 (setq buffer-read-only nil)
1247 (erase-buffer)
1248 (display-buffer buffer)
1249 (setq default-directory directory)
1250 (setq proc (start-process "Shell" buffer shell-file-name
1251 shell-command-switch command))
1252 (setq mode-line-process '(":%s"))
1253 (require 'shell) (shell-mode)
1254 (set-process-sentinel proc 'shell-command-sentinel)
1255 ))
1256 (shell-command-on-region (point) (point) command
1257 output-buffer nil error-buffer)))))))
1258
1259 (defun display-message-or-buffer (message
1260 &optional buffer-name not-this-window frame)
1261 "Display MESSAGE in the echo area if possible, otherwise in a pop-up buffer.
1262 MESSAGE may be either a string or a buffer.
1263
1264 A buffer is displayed using `display-buffer' if MESSAGE is too long for
1265 the maximum height of the echo area, as defined by `max-mini-window-height'
1266 if `resize-mini-windows' is non-nil.
1267
1268 Returns either the string shown in the echo area, or when a pop-up
1269 buffer is used, the window used to display it.
1270
1271 If MESSAGE is a string, then the optional argument BUFFER-NAME is the
1272 name of the buffer used to display it in the case where a pop-up buffer
1273 is used, defaulting to `*Message*'. In the case where MESSAGE is a
1274 string and it is displayed in the echo area, it is not specified whether
1275 the contents are inserted into the buffer anyway.
1276
1277 Optional arguments NOT-THIS-WINDOW and FRAME are as for `display-buffer',
1278 and only used if a buffer is displayed."
1279 (cond ((and (stringp message) (not (string-match "\n" message)))
1280 ;; Trivial case where we can use the echo area
1281 (message "%s" message))
1282 ((and (stringp message)
1283 (= (string-match "\n" message) (1- (length message))))
1284 ;; Trivial case where we can just remove single trailing newline
1285 (message "%s" (substring message 0 (1- (length message)))))
1286 (t
1287 ;; General case
1288 (with-current-buffer
1289 (if (bufferp message)
1290 message
1291 (get-buffer-create (or buffer-name "*Message*")))
1292
1293 (unless (bufferp message)
1294 (erase-buffer)
1295 (insert message))
1296
1297 (let ((lines
1298 (if (= (buffer-size) 0)
1299 0
1300 (count-lines (point-min) (point-max)))))
1301 (cond ((or (<= lines 1)
1302 (<= lines
1303 (if resize-mini-windows
1304 (cond ((floatp max-mini-window-height)
1305 (* (frame-height)
1306 max-mini-window-height))
1307 ((integerp max-mini-window-height)
1308 max-mini-window-height)
1309 (t
1310 1))
1311 1)))
1312 ;; Echo area
1313 (goto-char (point-max))
1314 (when (bolp)
1315 (backward-char 1))
1316 (message "%s" (buffer-substring (point-min) (point))))
1317 (t
1318 ;; Buffer
1319 (goto-char (point-min))
1320 (display-buffer message not-this-window frame))))))))
1321
1322
1323 ;; We have a sentinel to prevent insertion of a termination message
1324 ;; in the buffer itself.
1325 (defun shell-command-sentinel (process signal)
1326 (if (memq (process-status process) '(exit signal))
1327 (message "%s: %s."
1328 (car (cdr (cdr (process-command process))))
1329 (substring signal 0 -1))))
1330
1331 (defun shell-command-on-region (start end command
1332 &optional output-buffer replace
1333 error-buffer)
1334 "Execute string COMMAND in inferior shell with region as input.
1335 Normally display output (if any) in temp buffer `*Shell Command Output*';
1336 Prefix arg means replace the region with it. Return the exit code of
1337 COMMAND.
1338
1339 To specify a coding system for converting non-ASCII characters
1340 in the input and output to the shell command, use \\[universal-coding-system-argument]
1341 before this command. By default, the input (from the current buffer)
1342 is encoded in the same coding system that will be used to save the file,
1343 `buffer-file-coding-system'. If the output is going to replace the region,
1344 then it is decoded from that same coding system.
1345
1346 The noninteractive arguments are START, END, COMMAND, OUTPUT-BUFFER,
1347 REPLACE, ERROR-BUFFER. Noninteractive callers can specify coding
1348 systems by binding `coding-system-for-read' and
1349 `coding-system-for-write'.
1350
1351 If the output is short enough to display in the echo area (which is
1352 determined by the variable `max-mini-window-height' if
1353 `resize-mini-windows' is non-nil), it is shown there, but it is
1354 nonetheless available in buffer `*Shell Command Output*' even though
1355 that buffer is not automatically displayed. If there is no output, or
1356 if output is inserted in the current buffer, then `*Shell Command
1357 Output*' is deleted.
1358
1359 If the optional fourth argument OUTPUT-BUFFER is non-nil,
1360 that says to put the output in some other buffer.
1361 If OUTPUT-BUFFER is a buffer or buffer name, put the output there.
1362 If OUTPUT-BUFFER is not a buffer and not nil,
1363 insert output in the current buffer.
1364 In either case, the output is inserted after point (leaving mark after it).
1365
1366 If REPLACE, the optional fifth argument, is non-nil, that means insert
1367 the output in place of text from START to END, putting point and mark
1368 around it.
1369
1370 If optional sixth argument ERROR-BUFFER is non-nil, it is a buffer
1371 or buffer name to which to direct the command's standard error output.
1372 If it is nil, error output is mingled with regular output.
1373 In an interactive call, the variable `shell-command-default-error-buffer'
1374 specifies the value of ERROR-BUFFER."
1375 (interactive (let ((string
1376 ;; Do this before calling region-beginning
1377 ;; and region-end, in case subprocess output
1378 ;; relocates them while we are in the minibuffer.
1379 (read-from-minibuffer "Shell command on region: "
1380 nil nil nil
1381 'shell-command-history)))
1382 ;; call-interactively recognizes region-beginning and
1383 ;; region-end specially, leaving them in the history.
1384 (list (region-beginning) (region-end)
1385 string
1386 current-prefix-arg
1387 current-prefix-arg
1388 shell-command-default-error-buffer)))
1389 (let ((error-file
1390 (if error-buffer
1391 (make-temp-file
1392 (expand-file-name "scor"
1393 (or small-temporary-file-directory
1394 temporary-file-directory)))
1395 nil))
1396 exit-status)
1397 (if (or replace
1398 (and output-buffer
1399 (not (or (bufferp output-buffer) (stringp output-buffer)))))
1400 ;; Replace specified region with output from command.
1401 (let ((swap (and replace (< start end))))
1402 ;; Don't muck with mark unless REPLACE says we should.
1403 (goto-char start)
1404 (and replace (push-mark))
1405 (setq exit-status
1406 (call-process-region start end shell-file-name t
1407 (if error-file
1408 (list t error-file)
1409 t)
1410 nil shell-command-switch command))
1411 (let ((shell-buffer (get-buffer "*Shell Command Output*")))
1412 (and shell-buffer (not (eq shell-buffer (current-buffer)))
1413 (kill-buffer shell-buffer)))
1414 ;; Don't muck with mark unless REPLACE says we should.
1415 (and replace swap (exchange-point-and-mark)))
1416 ;; No prefix argument: put the output in a temp buffer,
1417 ;; replacing its entire contents.
1418 (let ((buffer (get-buffer-create
1419 (or output-buffer "*Shell Command Output*")))
1420 (success nil))
1421 (unwind-protect
1422 (if (eq buffer (current-buffer))
1423 ;; If the input is the same buffer as the output,
1424 ;; delete everything but the specified region,
1425 ;; then replace that region with the output.
1426 (progn (setq buffer-read-only nil)
1427 (delete-region (max start end) (point-max))
1428 (delete-region (point-min) (min start end))
1429 (setq exit-status
1430 (call-process-region (point-min) (point-max)
1431 shell-file-name t
1432 (if error-file
1433 (list t error-file)
1434 t)
1435 nil shell-command-switch
1436 command)))
1437 ;; Clear the output buffer, then run the command with
1438 ;; output there.
1439 (let ((directory default-directory))
1440 (save-excursion
1441 (set-buffer buffer)
1442 (setq buffer-read-only nil)
1443 (if (not output-buffer)
1444 (setq default-directory directory))
1445 (erase-buffer)))
1446 (setq exit-status
1447 (call-process-region start end shell-file-name nil
1448 (if error-file
1449 (list buffer error-file)
1450 buffer)
1451 nil shell-command-switch command)))
1452 (setq success (and exit-status (equal 0 exit-status)))
1453 ;; Report the amount of output.
1454 (if (with-current-buffer buffer (> (point-max) (point-min)))
1455 ;; There's some output, display it
1456 (display-message-or-buffer buffer)
1457 ;; No output; error?
1458 (message (if (and error-file
1459 (< 0 (nth 7 (file-attributes error-file))))
1460 "(Shell command %sed with some error output)"
1461 "(Shell command %sed with no output)")
1462 (if (equal 0 exit-status) "succeed" "fail"))
1463 (kill-buffer buffer)))))
1464
1465 (when (and error-file (file-exists-p error-file))
1466 (if (< 0 (nth 7 (file-attributes error-file)))
1467 (with-current-buffer (get-buffer-create error-buffer)
1468 (let ((pos-from-end (- (point-max) (point))))
1469 (or (bobp)
1470 (insert "\f\n"))
1471 ;; Do no formatting while reading error file,
1472 ;; because that can run a shell command, and we
1473 ;; don't want that to cause an infinite recursion.
1474 (format-insert-file error-file nil)
1475 ;; Put point after the inserted errors.
1476 (goto-char (- (point-max) pos-from-end)))
1477 (display-buffer (current-buffer))))
1478 (delete-file error-file))
1479 exit-status))
1480
1481 (defun shell-command-to-string (command)
1482 "Execute shell command COMMAND and return its output as a string."
1483 (with-output-to-string
1484 (with-current-buffer
1485 standard-output
1486 (call-process shell-file-name nil t nil shell-command-switch command))))
1487
1488 (defvar universal-argument-map
1489 (let ((map (make-sparse-keymap)))
1490 (define-key map [t] 'universal-argument-other-key)
1491 (define-key map (vector meta-prefix-char t) 'universal-argument-other-key)
1492 (define-key map [switch-frame] nil)
1493 (define-key map [?\C-u] 'universal-argument-more)
1494 (define-key map [?-] 'universal-argument-minus)
1495 (define-key map [?0] 'digit-argument)
1496 (define-key map [?1] 'digit-argument)
1497 (define-key map [?2] 'digit-argument)
1498 (define-key map [?3] 'digit-argument)
1499 (define-key map [?4] 'digit-argument)
1500 (define-key map [?5] 'digit-argument)
1501 (define-key map [?6] 'digit-argument)
1502 (define-key map [?7] 'digit-argument)
1503 (define-key map [?8] 'digit-argument)
1504 (define-key map [?9] 'digit-argument)
1505 (define-key map [kp-0] 'digit-argument)
1506 (define-key map [kp-1] 'digit-argument)
1507 (define-key map [kp-2] 'digit-argument)
1508 (define-key map [kp-3] 'digit-argument)
1509 (define-key map [kp-4] 'digit-argument)
1510 (define-key map [kp-5] 'digit-argument)
1511 (define-key map [kp-6] 'digit-argument)
1512 (define-key map [kp-7] 'digit-argument)
1513 (define-key map [kp-8] 'digit-argument)
1514 (define-key map [kp-9] 'digit-argument)
1515 (define-key map [kp-subtract] 'universal-argument-minus)
1516 map)
1517 "Keymap used while processing \\[universal-argument].")
1518
1519 (defvar universal-argument-num-events nil
1520 "Number of argument-specifying events read by `universal-argument'.
1521 `universal-argument-other-key' uses this to discard those events
1522 from (this-command-keys), and reread only the final command.")
1523
1524 (defun universal-argument ()
1525 "Begin a numeric argument for the following command.
1526 Digits or minus sign following \\[universal-argument] make up the numeric argument.
1527 \\[universal-argument] following the digits or minus sign ends the argument.
1528 \\[universal-argument] without digits or minus sign provides 4 as argument.
1529 Repeating \\[universal-argument] without digits or minus sign
1530 multiplies the argument by 4 each time.
1531 For some commands, just \\[universal-argument] by itself serves as a flag
1532 which is different in effect from any particular numeric argument.
1533 These commands include \\[set-mark-command] and \\[start-kbd-macro]."
1534 (interactive)
1535 (setq prefix-arg (list 4))
1536 (setq universal-argument-num-events (length (this-command-keys)))
1537 (setq overriding-terminal-local-map universal-argument-map))
1538
1539 ;; A subsequent C-u means to multiply the factor by 4 if we've typed
1540 ;; nothing but C-u's; otherwise it means to terminate the prefix arg.
1541 (defun universal-argument-more (arg)
1542 (interactive "P")
1543 (if (consp arg)
1544 (setq prefix-arg (list (* 4 (car arg))))
1545 (if (eq arg '-)
1546 (setq prefix-arg (list -4))
1547 (setq prefix-arg arg)
1548 (setq overriding-terminal-local-map nil)))
1549 (setq universal-argument-num-events (length (this-command-keys))))
1550
1551 (defun negative-argument (arg)
1552 "Begin a negative numeric argument for the next command.
1553 \\[universal-argument] following digits or minus sign ends the argument."
1554 (interactive "P")
1555 (cond ((integerp arg)
1556 (setq prefix-arg (- arg)))
1557 ((eq arg '-)
1558 (setq prefix-arg nil))
1559 (t
1560 (setq prefix-arg '-)))
1561 (setq universal-argument-num-events (length (this-command-keys)))
1562 (setq overriding-terminal-local-map universal-argument-map))
1563
1564 (defun digit-argument (arg)
1565 "Part of the numeric argument for the next command.
1566 \\[universal-argument] following digits or minus sign ends the argument."
1567 (interactive "P")
1568 (let* ((char (if (integerp last-command-char)
1569 last-command-char
1570 (get last-command-char 'ascii-character)))
1571 (digit (- (logand char ?\177) ?0)))
1572 (cond ((integerp arg)
1573 (setq prefix-arg (+ (* arg 10)
1574 (if (< arg 0) (- digit) digit))))
1575 ((eq arg '-)
1576 ;; Treat -0 as just -, so that -01 will work.
1577 (setq prefix-arg (if (zerop digit) '- (- digit))))
1578 (t
1579 (setq prefix-arg digit))))
1580 (setq universal-argument-num-events (length (this-command-keys)))
1581 (setq overriding-terminal-local-map universal-argument-map))
1582
1583 ;; For backward compatibility, minus with no modifiers is an ordinary
1584 ;; command if digits have already been entered.
1585 (defun universal-argument-minus (arg)
1586 (interactive "P")
1587 (if (integerp arg)
1588 (universal-argument-other-key arg)
1589 (negative-argument arg)))
1590
1591 ;; Anything else terminates the argument and is left in the queue to be
1592 ;; executed as a command.
1593 (defun universal-argument-other-key (arg)
1594 (interactive "P")
1595 (setq prefix-arg arg)
1596 (let* ((key (this-command-keys))
1597 (keylist (listify-key-sequence key)))
1598 (setq unread-command-events
1599 (append (nthcdr universal-argument-num-events keylist)
1600 unread-command-events)))
1601 (reset-this-command-lengths)
1602 (setq overriding-terminal-local-map nil))
1603
1604 ;;;; Window system cut and paste hooks.
1605
1606 (defvar interprogram-cut-function nil
1607 "Function to call to make a killed region available to other programs.
1608
1609 Most window systems provide some sort of facility for cutting and
1610 pasting text between the windows of different programs.
1611 This variable holds a function that Emacs calls whenever text
1612 is put in the kill ring, to make the new kill available to other
1613 programs.
1614
1615 The function takes one or two arguments.
1616 The first argument, TEXT, is a string containing
1617 the text which should be made available.
1618 The second, PUSH, if non-nil means this is a \"new\" kill;
1619 nil means appending to an \"old\" kill.")
1620
1621 (defvar interprogram-paste-function nil
1622 "Function to call to get text cut from other programs.
1623
1624 Most window systems provide some sort of facility for cutting and
1625 pasting text between the windows of different programs.
1626 This variable holds a function that Emacs calls to obtain
1627 text that other programs have provided for pasting.
1628
1629 The function should be called with no arguments. If the function
1630 returns nil, then no other program has provided such text, and the top
1631 of the Emacs kill ring should be used. If the function returns a
1632 string, that string should be put in the kill ring as the latest kill.
1633
1634 Note that the function should return a string only if a program other
1635 than Emacs has provided a string for pasting; if Emacs provided the
1636 most recent string, the function should return nil. If it is
1637 difficult to tell whether Emacs or some other program provided the
1638 current string, it is probably good enough to return nil if the string
1639 is equal (according to `string=') to the last text Emacs provided.")
1640
1641
1642
1643 ;;;; The kill ring data structure.
1644
1645 (defvar kill-ring nil
1646 "List of killed text sequences.
1647 Since the kill ring is supposed to interact nicely with cut-and-paste
1648 facilities offered by window systems, use of this variable should
1649 interact nicely with `interprogram-cut-function' and
1650 `interprogram-paste-function'. The functions `kill-new',
1651 `kill-append', and `current-kill' are supposed to implement this
1652 interaction; you may want to use them instead of manipulating the kill
1653 ring directly.")
1654
1655 (defcustom kill-ring-max 60
1656 "*Maximum length of kill ring before oldest elements are thrown away."
1657 :type 'integer
1658 :group 'killing)
1659
1660 (defvar kill-ring-yank-pointer nil
1661 "The tail of the kill ring whose car is the last thing yanked.")
1662
1663 (defun kill-new (string &optional replace)
1664 "Make STRING the latest kill in the kill ring.
1665 Set the kill-ring-yank pointer to point to it.
1666 If `interprogram-cut-function' is non-nil, apply it to STRING.
1667 Optional second argument REPLACE non-nil means that STRING will replace
1668 the front of the kill ring, rather than being added to the list."
1669 (and (fboundp 'menu-bar-update-yank-menu)
1670 (menu-bar-update-yank-menu string (and replace (car kill-ring))))
1671 (if (and replace kill-ring)
1672 (setcar kill-ring string)
1673 (setq kill-ring (cons string kill-ring))
1674 (if (> (length kill-ring) kill-ring-max)
1675 (setcdr (nthcdr (1- kill-ring-max) kill-ring) nil)))
1676 (setq kill-ring-yank-pointer kill-ring)
1677 (if interprogram-cut-function
1678 (funcall interprogram-cut-function string (not replace))))
1679
1680 (defun kill-append (string before-p)
1681 "Append STRING to the end of the latest kill in the kill ring.
1682 If BEFORE-P is non-nil, prepend STRING to the kill.
1683 If `interprogram-cut-function' is set, pass the resulting kill to
1684 it."
1685 (kill-new (if before-p
1686 (concat string (car kill-ring))
1687 (concat (car kill-ring) string)) t))
1688
1689 (defun current-kill (n &optional do-not-move)
1690 "Rotate the yanking point by N places, and then return that kill.
1691 If N is zero, `interprogram-paste-function' is set, and calling it
1692 returns a string, then that string is added to the front of the
1693 kill ring and returned as the latest kill.
1694 If optional arg DO-NOT-MOVE is non-nil, then don't actually move the
1695 yanking point; just return the Nth kill forward."
1696 (let ((interprogram-paste (and (= n 0)
1697 interprogram-paste-function
1698 (funcall interprogram-paste-function))))
1699 (if interprogram-paste
1700 (progn
1701 ;; Disable the interprogram cut function when we add the new
1702 ;; text to the kill ring, so Emacs doesn't try to own the
1703 ;; selection, with identical text.
1704 (let ((interprogram-cut-function nil))
1705 (kill-new interprogram-paste))
1706 interprogram-paste)
1707 (or kill-ring (error "Kill ring is empty"))
1708 (let ((ARGth-kill-element
1709 (nthcdr (mod (- n (length kill-ring-yank-pointer))
1710 (length kill-ring))
1711 kill-ring)))
1712 (or do-not-move
1713 (setq kill-ring-yank-pointer ARGth-kill-element))
1714 (car ARGth-kill-element)))))
1715
1716
1717
1718 ;;;; Commands for manipulating the kill ring.
1719
1720 (defcustom kill-read-only-ok nil
1721 "*Non-nil means don't signal an error for killing read-only text."
1722 :type 'boolean
1723 :group 'killing)
1724
1725 (put 'text-read-only 'error-conditions
1726 '(text-read-only buffer-read-only error))
1727 (put 'text-read-only 'error-message "Text is read-only")
1728
1729 (defun kill-region (beg end)
1730 "Kill between point and mark.
1731 The text is deleted but saved in the kill ring.
1732 The command \\[yank] can retrieve it from there.
1733 \(If you want to kill and then yank immediately, use \\[copy-region-as-kill].)
1734 If the buffer is read-only, Emacs will beep and refrain from deleting
1735 the text, but put the text in the kill ring anyway. This means that
1736 you can use the killing commands to copy text from a read-only buffer.
1737
1738 This is the primitive for programs to kill text (as opposed to deleting it).
1739 Supply two arguments, character numbers indicating the stretch of text
1740 to be killed.
1741 Any command that calls this function is a \"kill command\".
1742 If the previous command was also a kill command,
1743 the text killed this time appends to the text killed last time
1744 to make one entry in the kill ring."
1745 (interactive "r")
1746 (condition-case nil
1747 (let ((string (delete-and-extract-region beg end)))
1748 (when string ;STRING is nil if BEG = END
1749 ;; Add that string to the kill ring, one way or another.
1750 (if (eq last-command 'kill-region)
1751 (kill-append string (< end beg))
1752 (kill-new string)))
1753 (setq this-command 'kill-region))
1754 ((buffer-read-only text-read-only)
1755 ;; The code above failed because the buffer, or some of the characters
1756 ;; in the region, are read-only.
1757 ;; We should beep, in case the user just isn't aware of this.
1758 ;; However, there's no harm in putting
1759 ;; the region's text in the kill ring, anyway.
1760 (copy-region-as-kill beg end)
1761 ;; Set this-command now, so it will be set even if we get an error.
1762 (setq this-command 'kill-region)
1763 ;; This should barf, if appropriate, and give us the correct error.
1764 (if kill-read-only-ok
1765 (message "Read only text copied to kill ring")
1766 ;; Signal an error if the buffer is read-only.
1767 (barf-if-buffer-read-only)
1768 ;; If the buffer isn't read-only, the text is.
1769 (signal 'text-read-only (list (current-buffer)))))))
1770
1771 ;; copy-region-as-kill no longer sets this-command, because it's confusing
1772 ;; to get two copies of the text when the user accidentally types M-w and
1773 ;; then corrects it with the intended C-w.
1774 (defun copy-region-as-kill (beg end)
1775 "Save the region as if killed, but don't kill it.
1776 In Transient Mark mode, deactivate the mark.
1777 If `interprogram-cut-function' is non-nil, also save the text for a window
1778 system cut and paste."
1779 (interactive "r")
1780 (if (eq last-command 'kill-region)
1781 (kill-append (buffer-substring beg end) (< end beg))
1782 (kill-new (buffer-substring beg end)))
1783 (if transient-mark-mode
1784 (setq deactivate-mark t))
1785 nil)
1786
1787 (defun kill-ring-save (beg end)
1788 "Save the region as if killed, but don't kill it.
1789 In Transient Mark mode, deactivate the mark.
1790 If `interprogram-cut-function' is non-nil, also save the text for a window
1791 system cut and paste.
1792
1793 This command is similar to `copy-region-as-kill', except that it gives
1794 visual feedback indicating the extent of the region being copied."
1795 (interactive "r")
1796 (copy-region-as-kill beg end)
1797 (if (interactive-p)
1798 (let ((other-end (if (= (point) beg) end beg))
1799 (opoint (point))
1800 ;; Inhibit quitting so we can make a quit here
1801 ;; look like a C-g typed as a command.
1802 (inhibit-quit t))
1803 (if (pos-visible-in-window-p other-end (selected-window))
1804 (progn
1805 ;; Swap point and mark.
1806 (set-marker (mark-marker) (point) (current-buffer))
1807 (goto-char other-end)
1808 (sit-for 1)
1809 ;; Swap back.
1810 (set-marker (mark-marker) other-end (current-buffer))
1811 (goto-char opoint)
1812 ;; If user quit, deactivate the mark
1813 ;; as C-g would as a command.
1814 (and quit-flag mark-active
1815 (deactivate-mark)))
1816 (let* ((killed-text (current-kill 0))
1817 (message-len (min (length killed-text) 40)))
1818 (if (= (point) beg)
1819 ;; Don't say "killed"; that is misleading.
1820 (message "Saved text until \"%s\""
1821 (substring killed-text (- message-len)))
1822 (message "Saved text from \"%s\""
1823 (substring killed-text 0 message-len))))))))
1824
1825 (defun append-next-kill (&optional interactive)
1826 "Cause following command, if it kills, to append to previous kill.
1827 The argument is used for internal purposes; do not supply one."
1828 (interactive "p")
1829 ;; We don't use (interactive-p), since that breaks kbd macros.
1830 (if interactive
1831 (progn
1832 (setq this-command 'kill-region)
1833 (message "If the next command is a kill, it will append"))
1834 (setq last-command 'kill-region)))
1835
1836 ;; Yanking.
1837
1838 (defun yank-pop (arg)
1839 "Replace just-yanked stretch of killed text with a different stretch.
1840 This command is allowed only immediately after a `yank' or a `yank-pop'.
1841 At such a time, the region contains a stretch of reinserted
1842 previously-killed text. `yank-pop' deletes that text and inserts in its
1843 place a different stretch of killed text.
1844
1845 With no argument, the previous kill is inserted.
1846 With argument N, insert the Nth previous kill.
1847 If N is negative, this is a more recent kill.
1848
1849 The sequence of kills wraps around, so that after the oldest one
1850 comes the newest one."
1851 (interactive "*p")
1852 (if (not (eq last-command 'yank))
1853 (error "Previous command was not a yank"))
1854 (setq this-command 'yank)
1855 (let ((inhibit-read-only t)
1856 (before (< (point) (mark t))))
1857 (delete-region (point) (mark t))
1858 (set-marker (mark-marker) (point) (current-buffer))
1859 (let ((opoint (point)))
1860 (insert (current-kill arg))
1861 (let ((inhibit-read-only t))
1862 (remove-text-properties opoint (point) '(read-only nil))))
1863 (if before
1864 ;; This is like exchange-point-and-mark, but doesn't activate the mark.
1865 ;; It is cleaner to avoid activation, even though the command
1866 ;; loop would deactivate the mark because we inserted text.
1867 (goto-char (prog1 (mark t)
1868 (set-marker (mark-marker) (point) (current-buffer))))))
1869 nil)
1870
1871 (defun yank (&optional arg)
1872 "Reinsert the last stretch of killed text.
1873 More precisely, reinsert the stretch of killed text most recently
1874 killed OR yanked. Put point at end, and set mark at beginning.
1875 With just C-u as argument, same but put point at beginning (and mark at end).
1876 With argument N, reinsert the Nth most recently killed stretch of killed
1877 text.
1878 See also the command \\[yank-pop]."
1879 (interactive "*P")
1880 ;; If we don't get all the way thru, make last-command indicate that
1881 ;; for the following command.
1882 (setq this-command t)
1883 (push-mark (point))
1884 (let ((opoint (point)))
1885 (insert (current-kill (cond
1886 ((listp arg) 0)
1887 ((eq arg '-) -1)
1888 (t (1- arg)))))
1889 (let ((inhibit-read-only t))
1890 (remove-text-properties opoint (point) '(read-only nil))))
1891 (if (consp arg)
1892 ;; This is like exchange-point-and-mark, but doesn't activate the mark.
1893 ;; It is cleaner to avoid activation, even though the command
1894 ;; loop would deactivate the mark because we inserted text.
1895 (goto-char (prog1 (mark t)
1896 (set-marker (mark-marker) (point) (current-buffer)))))
1897 ;; If we do get all the way thru, make this-command indicate that.
1898 (setq this-command 'yank)
1899 nil)
1900
1901 (defun rotate-yank-pointer (arg)
1902 "Rotate the yanking point in the kill ring.
1903 With argument, rotate that many kills forward (or backward, if negative)."
1904 (interactive "p")
1905 (current-kill arg))
1906
1907 ;; Some kill commands.
1908
1909 ;; Internal subroutine of delete-char
1910 (defun kill-forward-chars (arg)
1911 (if (listp arg) (setq arg (car arg)))
1912 (if (eq arg '-) (setq arg -1))
1913 (kill-region (point) (forward-point arg)))
1914
1915 ;; Internal subroutine of backward-delete-char
1916 (defun kill-backward-chars (arg)
1917 (if (listp arg) (setq arg (car arg)))
1918 (if (eq arg '-) (setq arg -1))
1919 (kill-region (point) (forward-point (- arg))))
1920
1921 (defcustom backward-delete-char-untabify-method 'untabify
1922 "*The method for untabifying when deleting backward.
1923 Can be `untabify' -- turn a tab to many spaces, then delete one space;
1924 `hungry' -- delete all whitespace, both tabs and spaces;
1925 `all' -- delete all whitespace, including tabs, spaces and newlines;
1926 nil -- just delete one character."
1927 :type '(choice (const untabify) (const hungry) (const all) (const nil))
1928 :group 'killing)
1929
1930 (defun backward-delete-char-untabify (arg &optional killp)
1931 "Delete characters backward, changing tabs into spaces.
1932 The exact behavior depends on `backward-delete-char-untabify-method'.
1933 Delete ARG chars, and kill (save in kill ring) if KILLP is non-nil.
1934 Interactively, ARG is the prefix arg (default 1)
1935 and KILLP is t if a prefix arg was specified."
1936 (interactive "*p\nP")
1937 (when (eq backward-delete-char-untabify-method 'untabify)
1938 (let ((count arg))
1939 (save-excursion
1940 (while (and (> count 0) (not (bobp)))
1941 (if (= (preceding-char) ?\t)
1942 (let ((col (current-column)))
1943 (forward-char -1)
1944 (setq col (- col (current-column)))
1945 (insert-char ?\ col)
1946 (delete-char 1)))
1947 (forward-char -1)
1948 (setq count (1- count))))))
1949 (delete-backward-char
1950 (let ((skip (cond ((eq backward-delete-char-untabify-method 'hungry) " \t")
1951 ((eq backward-delete-char-untabify-method 'all)
1952 " \t\n\r"))))
1953 (if skip
1954 (let ((wh (- (point) (save-excursion (skip-chars-backward skip)
1955 (point)))))
1956 (+ arg (if (zerop wh) 0 (1- wh))))
1957 arg))
1958 killp))
1959
1960 (defun zap-to-char (arg char)
1961 "Kill up to and including ARG'th occurrence of CHAR.
1962 Case is ignored if `case-fold-search' is non-nil in the current buffer.
1963 Goes backward if ARG is negative; error if CHAR not found."
1964 (interactive "p\ncZap to char: ")
1965 (kill-region (point) (progn
1966 (search-forward (char-to-string char) nil nil arg)
1967 ; (goto-char (if (> arg 0) (1- (point)) (1+ (point))))
1968 (point))))
1969
1970 ;; kill-line and its subroutines.
1971
1972 (defcustom kill-whole-line nil
1973 "*If non-nil, `kill-line' with no arg at beg of line kills the whole line."
1974 :type 'boolean
1975 :group 'killing)
1976
1977 (defun kill-line (&optional arg)
1978 "Kill the rest of the current line; if no nonblanks there, kill thru newline.
1979 With prefix argument, kill that many lines from point.
1980 Negative arguments kill lines backward.
1981 With zero argument, kills the text before point on the current line.
1982
1983 When calling from a program, nil means \"no arg\",
1984 a number counts as a prefix arg.
1985
1986 To kill a whole line, when point is not at the beginning, type \
1987 \\[beginning-of-line] \\[kill-line] \\[kill-line].
1988
1989 If `kill-whole-line' is non-nil, then this command kills the whole line
1990 including its terminating newline, when used at the beginning of a line
1991 with no argument. As a consequence, you can always kill a whole line
1992 by typing \\[beginning-of-line] \\[kill-line]."
1993 (interactive "P")
1994 (kill-region (point)
1995 ;; It is better to move point to the other end of the kill
1996 ;; before killing. That way, in a read-only buffer, point
1997 ;; moves across the text that is copied to the kill ring.
1998 ;; The choice has no effect on undo now that undo records
1999 ;; the value of point from before the command was run.
2000 (progn
2001 (if arg
2002 (forward-visible-line (prefix-numeric-value arg))
2003 (if (eobp)
2004 (signal 'end-of-buffer nil))
2005 (if (or (looking-at "[ \t]*$") (and kill-whole-line (bolp)))
2006 (forward-visible-line 1)
2007 (end-of-visible-line)))
2008 (point))))
2009
2010 (defun forward-visible-line (arg)
2011 "Move forward by ARG lines, ignoring currently invisible newlines only.
2012 If ARG is negative, move backward -ARG lines.
2013 If ARG is zero, move to the beginning of the current line."
2014 (condition-case nil
2015 (if (> arg 0)
2016 (while (> arg 0)
2017 (or (zerop (forward-line 1))
2018 (signal 'end-of-buffer nil))
2019 ;; If the following character is currently invisible,
2020 ;; skip all characters with that same `invisible' property value,
2021 ;; then find the next newline.
2022 (while (and (not (eobp))
2023 (let ((prop
2024 (get-char-property (point) 'invisible)))
2025 (if (eq buffer-invisibility-spec t)
2026 prop
2027 (or (memq prop buffer-invisibility-spec)
2028 (assq prop buffer-invisibility-spec)))))
2029 (goto-char
2030 (if (get-text-property (point) 'invisible)
2031 (or (next-single-property-change (point) 'invisible)
2032 (point-max))
2033 (next-overlay-change (point))))
2034 (or (zerop (forward-line 1))
2035 (signal 'end-of-buffer nil)))
2036 (setq arg (1- arg)))
2037 (let ((first t))
2038 (while (or first (< arg 0))
2039 (if (zerop arg)
2040 (beginning-of-line)
2041 (or (zerop (forward-line -1))
2042 (signal 'beginning-of-buffer nil)))
2043 (while (and (not (bobp))
2044 (let ((prop
2045 (get-char-property (1- (point)) 'invisible)))
2046 (if (eq buffer-invisibility-spec t)
2047 prop
2048 (or (memq prop buffer-invisibility-spec)
2049 (assq prop buffer-invisibility-spec)))))
2050 (goto-char
2051 (if (get-text-property (1- (point)) 'invisible)
2052 (or (previous-single-property-change (point) 'invisible)
2053 (point-min))
2054 (previous-overlay-change (point))))
2055 (or (zerop (forward-line -1))
2056 (signal 'beginning-of-buffer nil)))
2057 (setq first nil)
2058 (setq arg (1+ arg)))))
2059 ((beginning-of-buffer end-of-buffer)
2060 nil)))
2061
2062 (defun end-of-visible-line ()
2063 "Move to end of current visible line."
2064 (end-of-line)
2065 ;; If the following character is currently invisible,
2066 ;; skip all characters with that same `invisible' property value,
2067 ;; then find the next newline.
2068 (while (and (not (eobp))
2069 (let ((prop
2070 (get-char-property (point) 'invisible)))
2071 (if (eq buffer-invisibility-spec t)
2072 prop
2073 (or (memq prop buffer-invisibility-spec)
2074 (assq prop buffer-invisibility-spec)))))
2075 (if (get-text-property (point) 'invisible)
2076 (goto-char (next-single-property-change (point) 'invisible))
2077 (goto-char (next-overlay-change (point))))
2078 (end-of-line)))
2079
2080 (defun insert-buffer (buffer)
2081 "Insert after point the contents of BUFFER.
2082 Puts mark after the inserted text.
2083 BUFFER may be a buffer or a buffer name.
2084
2085 This function is meant for the user to run interactively.
2086 Don't call it from programs!"
2087 (interactive
2088 (list
2089 (progn
2090 (barf-if-buffer-read-only)
2091 (read-buffer "Insert buffer: "
2092 (if (eq (selected-window) (next-window (selected-window)))
2093 (other-buffer (current-buffer))
2094 (window-buffer (next-window (selected-window))))
2095 t))))
2096 (or (bufferp buffer)
2097 (setq buffer (get-buffer buffer)))
2098 (let (start end newmark)
2099 (save-excursion
2100 (save-excursion
2101 (set-buffer buffer)
2102 (setq start (point-min) end (point-max)))
2103 (insert-buffer-substring buffer start end)
2104 (setq newmark (point)))
2105 (push-mark newmark))
2106 nil)
2107
2108 (defun append-to-buffer (buffer start end)
2109 "Append to specified buffer the text of the region.
2110 It is inserted into that buffer before its point.
2111
2112 When calling from a program, give three arguments:
2113 BUFFER (or buffer name), START and END.
2114 START and END specify the portion of the current buffer to be copied."
2115 (interactive
2116 (list (read-buffer "Append to buffer: " (other-buffer (current-buffer) t))
2117 (region-beginning) (region-end)))
2118 (let ((oldbuf (current-buffer)))
2119 (save-excursion
2120 (let* ((append-to (get-buffer-create buffer))
2121 (windows (get-buffer-window-list append-to t t))
2122 point)
2123 (set-buffer append-to)
2124 (setq point (point))
2125 (barf-if-buffer-read-only)
2126 (insert-buffer-substring oldbuf start end)
2127 (dolist (window windows)
2128 (when (= (window-point window) point)
2129 (set-window-point window (point))))))))
2130
2131 (defun prepend-to-buffer (buffer start end)
2132 "Prepend to specified buffer the text of the region.
2133 It is inserted into that buffer after its point.
2134
2135 When calling from a program, give three arguments:
2136 BUFFER (or buffer name), START and END.
2137 START and END specify the portion of the current buffer to be copied."
2138 (interactive "BPrepend to buffer: \nr")
2139 (let ((oldbuf (current-buffer)))
2140 (save-excursion
2141 (set-buffer (get-buffer-create buffer))
2142 (barf-if-buffer-read-only)
2143 (save-excursion
2144 (insert-buffer-substring oldbuf start end)))))
2145
2146 (defun copy-to-buffer (buffer start end)
2147 "Copy to specified buffer the text of the region.
2148 It is inserted into that buffer, replacing existing text there.
2149
2150 When calling from a program, give three arguments:
2151 BUFFER (or buffer name), START and END.
2152 START and END specify the portion of the current buffer to be copied."
2153 (interactive "BCopy to buffer: \nr")
2154 (let ((oldbuf (current-buffer)))
2155 (save-excursion
2156 (set-buffer (get-buffer-create buffer))
2157 (barf-if-buffer-read-only)
2158 (erase-buffer)
2159 (save-excursion
2160 (insert-buffer-substring oldbuf start end)))))
2161
2162 (put 'mark-inactive 'error-conditions '(mark-inactive error))
2163 (put 'mark-inactive 'error-message "The mark is not active now")
2164
2165 (defun mark (&optional force)
2166 "Return this buffer's mark value as integer; error if mark inactive.
2167 If optional argument FORCE is non-nil, access the mark value
2168 even if the mark is not currently active, and return nil
2169 if there is no mark at all.
2170
2171 If you are using this in an editing command, you are most likely making
2172 a mistake; see the documentation of `set-mark'."
2173 (if (or force (not transient-mark-mode) mark-active mark-even-if-inactive)
2174 (marker-position (mark-marker))
2175 (signal 'mark-inactive nil)))
2176
2177 ;; Many places set mark-active directly, and several of them failed to also
2178 ;; run deactivate-mark-hook. This shorthand should simplify.
2179 (defsubst deactivate-mark ()
2180 "Deactivate the mark by setting `mark-active' to nil.
2181 \(That makes a difference only in Transient Mark mode.)
2182 Also runs the hook `deactivate-mark-hook'."
2183 (if transient-mark-mode
2184 (progn
2185 (setq mark-active nil)
2186 (run-hooks 'deactivate-mark-hook))))
2187
2188 (defun set-mark (pos)
2189 "Set this buffer's mark to POS. Don't use this function!
2190 That is to say, don't use this function unless you want
2191 the user to see that the mark has moved, and you want the previous
2192 mark position to be lost.
2193
2194 Normally, when a new mark is set, the old one should go on the stack.
2195 This is why most applications should use push-mark, not set-mark.
2196
2197 Novice Emacs Lisp programmers often try to use the mark for the wrong
2198 purposes. The mark saves a location for the user's convenience.
2199 Most editing commands should not alter the mark.
2200 To remember a location for internal use in the Lisp program,
2201 store it in a Lisp variable. Example:
2202
2203 (let ((beg (point))) (forward-line 1) (delete-region beg (point)))."
2204
2205 (if pos
2206 (progn
2207 (setq mark-active t)
2208 (run-hooks 'activate-mark-hook)
2209 (set-marker (mark-marker) pos (current-buffer)))
2210 ;; Normally we never clear mark-active except in Transient Mark mode.
2211 ;; But when we actually clear out the mark value too,
2212 ;; we must clear mark-active in any mode.
2213 (setq mark-active nil)
2214 (run-hooks 'deactivate-mark-hook)
2215 (set-marker (mark-marker) nil)))
2216
2217 (defvar mark-ring nil
2218 "The list of former marks of the current buffer, most recent first.")
2219 (make-variable-buffer-local 'mark-ring)
2220 (put 'mark-ring 'permanent-local t)
2221
2222 (defcustom mark-ring-max 16
2223 "*Maximum size of mark ring. Start discarding off end if gets this big."
2224 :type 'integer
2225 :group 'editing-basics)
2226
2227 (defvar global-mark-ring nil
2228 "The list of saved global marks, most recent first.")
2229
2230 (defcustom global-mark-ring-max 16
2231 "*Maximum size of global mark ring. \
2232 Start discarding off end if gets this big."
2233 :type 'integer
2234 :group 'editing-basics)
2235
2236 (defun set-mark-command (arg)
2237 "Set mark at where point is, or jump to mark.
2238 With no prefix argument, set mark, push old mark position on local mark
2239 ring, and push mark on global mark ring.
2240 With argument, jump to mark, and pop a new position for mark off the ring
2241 \(does not affect global mark ring\).
2242
2243 Novice Emacs Lisp programmers often try to use the mark for the wrong
2244 purposes. See the documentation of `set-mark' for more information."
2245 (interactive "P")
2246 (if (null arg)
2247 (progn
2248 (push-mark nil nil t))
2249 (if (null (mark t))
2250 (error "No mark set in this buffer")
2251 (goto-char (mark t))
2252 (pop-mark))))
2253
2254 (defun push-mark (&optional location nomsg activate)
2255 "Set mark at LOCATION (point, by default) and push old mark on mark ring.
2256 If the last global mark pushed was not in the current buffer,
2257 also push LOCATION on the global mark ring.
2258 Display `Mark set' unless the optional second arg NOMSG is non-nil.
2259 In Transient Mark mode, activate mark if optional third arg ACTIVATE non-nil.
2260
2261 Novice Emacs Lisp programmers often try to use the mark for the wrong
2262 purposes. See the documentation of `set-mark' for more information.
2263
2264 In Transient Mark mode, this does not activate the mark."
2265 (if (null (mark t))
2266 nil
2267 (setq mark-ring (cons (copy-marker (mark-marker)) mark-ring))
2268 (if (> (length mark-ring) mark-ring-max)
2269 (progn
2270 (move-marker (car (nthcdr mark-ring-max mark-ring)) nil)
2271 (setcdr (nthcdr (1- mark-ring-max) mark-ring) nil))))
2272 (set-marker (mark-marker) (or location (point)) (current-buffer))
2273 ;; Now push the mark on the global mark ring.
2274 (if (and global-mark-ring
2275 (eq (marker-buffer (car global-mark-ring)) (current-buffer)))
2276 ;; The last global mark pushed was in this same buffer.
2277 ;; Don't push another one.
2278 nil
2279 (setq global-mark-ring (cons (copy-marker (mark-marker)) global-mark-ring))
2280 (if (> (length global-mark-ring) global-mark-ring-max)
2281 (progn
2282 (move-marker (car (nthcdr global-mark-ring-max global-mark-ring))
2283 nil)
2284 (setcdr (nthcdr (1- global-mark-ring-max) global-mark-ring) nil))))
2285 (or nomsg executing-kbd-macro (> (minibuffer-depth) 0)
2286 (message "Mark set"))
2287 (if (or activate (not transient-mark-mode))
2288 (set-mark (mark t)))
2289 nil)
2290
2291 (defun pop-mark ()
2292 "Pop off mark ring into the buffer's actual mark.
2293 Does not set point. Does nothing if mark ring is empty."
2294 (if mark-ring
2295 (progn
2296 (setq mark-ring (nconc mark-ring (list (copy-marker (mark-marker)))))
2297 (set-marker (mark-marker) (+ 0 (car mark-ring)) (current-buffer))
2298 (deactivate-mark)
2299 (move-marker (car mark-ring) nil)
2300 (if (null (mark t)) (ding))
2301 (setq mark-ring (cdr mark-ring)))))
2302
2303 (defalias 'exchange-dot-and-mark 'exchange-point-and-mark)
2304 (defun exchange-point-and-mark ()
2305 "Put the mark where point is now, and point where the mark is now.
2306 This command works even when the mark is not active,
2307 and it reactivates the mark."
2308 (interactive nil)
2309 (let ((omark (mark t)))
2310 (if (null omark)
2311 (error "No mark set in this buffer"))
2312 (set-mark (point))
2313 (goto-char omark)
2314 nil))
2315
2316 (defun transient-mark-mode (arg)
2317 "Toggle Transient Mark mode.
2318 With arg, turn Transient Mark mode on if arg is positive, off otherwise.
2319
2320 In Transient Mark mode, when the mark is active, the region is highlighted.
2321 Changing the buffer \"deactivates\" the mark.
2322 So do certain other operations that set the mark
2323 but whose main purpose is something else--for example,
2324 incremental search, \\[beginning-of-buffer], and \\[end-of-buffer]."
2325 (interactive "P")
2326 (setq transient-mark-mode
2327 (if (null arg)
2328 (not transient-mark-mode)
2329 (> (prefix-numeric-value arg) 0)))
2330 (if (interactive-p)
2331 (if transient-mark-mode
2332 (message "Transient Mark mode enabled")
2333 (message "Transient Mark mode disabled"))))
2334
2335 (defun pop-global-mark ()
2336 "Pop off global mark ring and jump to the top location."
2337 (interactive)
2338 ;; Pop entries which refer to non-existent buffers.
2339 (while (and global-mark-ring (not (marker-buffer (car global-mark-ring))))
2340 (setq global-mark-ring (cdr global-mark-ring)))
2341 (or global-mark-ring
2342 (error "No global mark set"))
2343 (let* ((marker (car global-mark-ring))
2344 (buffer (marker-buffer marker))
2345 (position (marker-position marker)))
2346 (setq global-mark-ring (nconc (cdr global-mark-ring)
2347 (list (car global-mark-ring))))
2348 (set-buffer buffer)
2349 (or (and (>= position (point-min))
2350 (<= position (point-max)))
2351 (widen))
2352 (goto-char position)
2353 (switch-to-buffer buffer)))
2354
2355 (defcustom next-line-add-newlines nil
2356 "*If non-nil, `next-line' inserts newline to avoid `end of buffer' error."
2357 :type 'boolean
2358 :group 'editing-basics)
2359
2360 (defun next-line (arg)
2361 "Move cursor vertically down ARG lines.
2362 If there is no character in the target line exactly under the current column,
2363 the cursor is positioned after the character in that line which spans this
2364 column, or at the end of the line if it is not long enough.
2365 If there is no line in the buffer after this one, behavior depends on the
2366 value of `next-line-add-newlines'. If non-nil, it inserts a newline character
2367 to create a line, and moves the cursor to that line. Otherwise it moves the
2368 cursor to the end of the buffer.
2369
2370 The command \\[set-goal-column] can be used to create
2371 a semipermanent goal column for this command.
2372 Then instead of trying to move exactly vertically (or as close as possible),
2373 this command moves to the specified goal column (or as close as possible).
2374 The goal column is stored in the variable `goal-column', which is nil
2375 when there is no goal column.
2376
2377 If you are thinking of using this in a Lisp program, consider
2378 using `forward-line' instead. It is usually easier to use
2379 and more reliable (no dependence on goal column, etc.)."
2380 (interactive "p")
2381 (if (and next-line-add-newlines (= arg 1))
2382 (let ((opoint (point)))
2383 (end-of-line)
2384 (if (eobp)
2385 (newline 1)
2386 (goto-char opoint)
2387 (line-move arg)))
2388 (if (interactive-p)
2389 (condition-case nil
2390 (line-move arg)
2391 ((beginning-of-buffer end-of-buffer) (ding)))
2392 (line-move arg)))
2393 nil)
2394
2395 (defun previous-line (arg)
2396 "Move cursor vertically up ARG lines.
2397 If there is no character in the target line exactly over the current column,
2398 the cursor is positioned after the character in that line which spans this
2399 column, or at the end of the line if it is not long enough.
2400
2401 The command \\[set-goal-column] can be used to create
2402 a semipermanent goal column for this command.
2403 Then instead of trying to move exactly vertically (or as close as possible),
2404 this command moves to the specified goal column (or as close as possible).
2405 The goal column is stored in the variable `goal-column', which is nil
2406 when there is no goal column.
2407
2408 If you are thinking of using this in a Lisp program, consider using
2409 `forward-line' with a negative argument instead. It is usually easier
2410 to use and more reliable (no dependence on goal column, etc.)."
2411 (interactive "p")
2412 (if (interactive-p)
2413 (condition-case nil
2414 (line-move (- arg))
2415 ((beginning-of-buffer end-of-buffer) (ding)))
2416 (line-move (- arg)))
2417 nil)
2418
2419 (defcustom track-eol nil
2420 "*Non-nil means vertical motion starting at end of line keeps to ends of lines.
2421 This means moving to the end of each line moved onto.
2422 The beginning of a blank line does not count as the end of a line."
2423 :type 'boolean
2424 :group 'editing-basics)
2425
2426 (defcustom goal-column nil
2427 "*Semipermanent goal column for vertical motion, as set by \\[set-goal-column], or nil."
2428 :type '(choice integer
2429 (const :tag "None" nil))
2430 :group 'editing-basics)
2431 (make-variable-buffer-local 'goal-column)
2432
2433 (defvar temporary-goal-column 0
2434 "Current goal column for vertical motion.
2435 It is the column where point was
2436 at the start of current run of vertical motion commands.
2437 When the `track-eol' feature is doing its job, the value is 9999.")
2438
2439 (defcustom line-move-ignore-invisible nil
2440 "*Non-nil means \\[next-line] and \\[previous-line] ignore invisible lines.
2441 Outline mode sets this."
2442 :type 'boolean
2443 :group 'editing-basics)
2444
2445 ;; This is the guts of next-line and previous-line.
2446 ;; Arg says how many lines to move.
2447 (defun line-move (arg)
2448 ;; Don't run any point-motion hooks, and disregard intangibility,
2449 ;; for intermediate positions.
2450 (let ((inhibit-point-motion-hooks t)
2451 (opoint (point))
2452 new line-end line-beg)
2453 (unwind-protect
2454 (progn
2455 (if (not (or (eq last-command 'next-line)
2456 (eq last-command 'previous-line)))
2457 (setq temporary-goal-column
2458 (if (and track-eol (eolp)
2459 ;; Don't count beg of empty line as end of line
2460 ;; unless we just did explicit end-of-line.
2461 (or (not (bolp)) (eq last-command 'end-of-line)))
2462 9999
2463 (current-column))))
2464 (if (and (not (integerp selective-display))
2465 (not line-move-ignore-invisible))
2466 ;; Use just newline characters.
2467 (or (if (> arg 0)
2468 (progn (if (> arg 1) (forward-line (1- arg)))
2469 ;; This way of moving forward ARG lines
2470 ;; verifies that we have a newline after the last one.
2471 ;; It doesn't get confused by intangible text.
2472 (end-of-line)
2473 (zerop (forward-line 1)))
2474 (and (zerop (forward-line arg))
2475 (bolp)))
2476 (signal (if (< arg 0)
2477 'beginning-of-buffer
2478 'end-of-buffer)
2479 nil))
2480 ;; Move by arg lines, but ignore invisible ones.
2481 (while (> arg 0)
2482 (end-of-line)
2483 (and (zerop (vertical-motion 1))
2484 (signal 'end-of-buffer nil))
2485 ;; If the following character is currently invisible,
2486 ;; skip all characters with that same `invisible' property value.
2487 (while (and (not (eobp))
2488 (let ((prop
2489 (get-char-property (point) 'invisible)))
2490 (if (eq buffer-invisibility-spec t)
2491 prop
2492 (or (memq prop buffer-invisibility-spec)
2493 (assq prop buffer-invisibility-spec)))))
2494 (if (get-text-property (point) 'invisible)
2495 (goto-char (next-single-property-change (point) 'invisible))
2496 (goto-char (next-overlay-change (point)))))
2497 (setq arg (1- arg)))
2498 (while (< arg 0)
2499 (beginning-of-line)
2500 (and (zerop (vertical-motion -1))
2501 (signal 'beginning-of-buffer nil))
2502 (while (and (not (bobp))
2503 (let ((prop
2504 (get-char-property (1- (point)) 'invisible)))
2505 (if (eq buffer-invisibility-spec t)
2506 prop
2507 (or (memq prop buffer-invisibility-spec)
2508 (assq prop buffer-invisibility-spec)))))
2509 (if (get-text-property (1- (point)) 'invisible)
2510 (goto-char (previous-single-property-change (point) 'invisible))
2511 (goto-char (previous-overlay-change (point)))))
2512 (setq arg (1+ arg))))
2513 (let ((buffer-invisibility-spec nil))
2514 (move-to-column (or goal-column temporary-goal-column))))
2515 (setq new (point))
2516 ;; If we are moving into some intangible text,
2517 ;; look for following text on the same line which isn't intangible
2518 ;; and move there.
2519 (setq line-end (save-excursion (end-of-line) (point)))
2520 (setq line-beg (save-excursion (beginning-of-line) (point)))
2521 (let ((after (and (< new (point-max))
2522 (get-char-property new 'intangible)))
2523 (before (and (> new (point-min))
2524 (get-char-property (1- new) 'intangible))))
2525 (when (and before (eq before after)
2526 (not (bolp)))
2527 (goto-char (point-min))
2528 (let ((inhibit-point-motion-hooks nil))
2529 (goto-char new))
2530 (if (<= new line-end)
2531 (setq new (point)))))
2532 ;; NEW is where we want to move to.
2533 ;; LINE-BEG and LINE-END are the beginning and end of the line.
2534 ;; Move there in just one step, from our starting position,
2535 ;; with intangibility and point-motion hooks enabled this time.
2536 (goto-char opoint)
2537 (setq inhibit-point-motion-hooks nil)
2538 (goto-char (constrain-to-field new opoint nil t
2539 'inhibit-line-move-field-capture))
2540 ;; If intangibility processing moved us to a different line,
2541 ;; readjust the horizontal position within the line we ended up at.
2542 (when (or (< (point) line-beg) (> (point) line-end))
2543 (setq new (point))
2544 (setq inhibit-point-motion-hooks t)
2545 (setq line-end (save-excursion (end-of-line) (point)))
2546 (beginning-of-line)
2547 (setq line-beg (point))
2548 (let ((buffer-invisibility-spec nil))
2549 (move-to-column (or goal-column temporary-goal-column)))
2550 (if (<= (point) line-end)
2551 (setq new (point)))
2552 (goto-char (point-min))
2553 (setq inhibit-point-motion-hooks nil)
2554 (goto-char (constrain-to-field new opoint nil t
2555 'inhibit-line-move-field-capture))
2556 )))
2557 nil)
2558
2559 ;;; Many people have said they rarely use this feature, and often type
2560 ;;; it by accident. Maybe it shouldn't even be on a key.
2561 (put 'set-goal-column 'disabled t)
2562
2563 (defun set-goal-column (arg)
2564 "Set the current horizontal position as a goal for \\[next-line] and \\[previous-line].
2565 Those commands will move to this position in the line moved to
2566 rather than trying to keep the same horizontal position.
2567 With a non-nil argument, clears out the goal column
2568 so that \\[next-line] and \\[previous-line] resume vertical motion.
2569 The goal column is stored in the variable `goal-column'."
2570 (interactive "P")
2571 (if arg
2572 (progn
2573 (setq goal-column nil)
2574 (message "No goal column"))
2575 (setq goal-column (current-column))
2576 (message (substitute-command-keys
2577 "Goal column %d (use \\[set-goal-column] with an arg to unset it)")
2578 goal-column))
2579 nil)
2580
2581
2582 (defun scroll-other-window-down (lines)
2583 "Scroll the \"other window\" down.
2584 For more details, see the documentation for `scroll-other-window'."
2585 (interactive "P")
2586 (scroll-other-window
2587 ;; Just invert the argument's meaning.
2588 ;; We can do that without knowing which window it will be.
2589 (if (eq lines '-) nil
2590 (if (null lines) '-
2591 (- (prefix-numeric-value lines))))))
2592 (define-key esc-map [?\C-\S-v] 'scroll-other-window-down)
2593
2594 (defun beginning-of-buffer-other-window (arg)
2595 "Move point to the beginning of the buffer in the other window.
2596 Leave mark at previous position.
2597 With arg N, put point N/10 of the way from the true beginning."
2598 (interactive "P")
2599 (let ((orig-window (selected-window))
2600 (window (other-window-for-scrolling)))
2601 ;; We use unwind-protect rather than save-window-excursion
2602 ;; because the latter would preserve the things we want to change.
2603 (unwind-protect
2604 (progn
2605 (select-window window)
2606 ;; Set point and mark in that window's buffer.
2607 (beginning-of-buffer arg)
2608 ;; Set point accordingly.
2609 (recenter '(t)))
2610 (select-window orig-window))))
2611
2612 (defun end-of-buffer-other-window (arg)
2613 "Move point to the end of the buffer in the other window.
2614 Leave mark at previous position.
2615 With arg N, put point N/10 of the way from the true end."
2616 (interactive "P")
2617 ;; See beginning-of-buffer-other-window for comments.
2618 (let ((orig-window (selected-window))
2619 (window (other-window-for-scrolling)))
2620 (unwind-protect
2621 (progn
2622 (select-window window)
2623 (end-of-buffer arg)
2624 (recenter '(t)))
2625 (select-window orig-window))))
2626
2627 (defun transpose-chars (arg)
2628 "Interchange characters around point, moving forward one character.
2629 With prefix arg ARG, effect is to take character before point
2630 and drag it forward past ARG other characters (backward if ARG negative).
2631 If no argument and at end of line, the previous two chars are exchanged."
2632 (interactive "*P")
2633 (and (null arg) (eolp) (forward-char -1))
2634 (transpose-subr 'forward-char (prefix-numeric-value arg)))
2635
2636 (defun transpose-words (arg)
2637 "Interchange words around point, leaving point at end of them.
2638 With prefix arg ARG, effect is to take word before or around point
2639 and drag it forward past ARG other words (backward if ARG negative).
2640 If ARG is zero, the words around or after point and around or after mark
2641 are interchanged."
2642 (interactive "*p")
2643 (transpose-subr 'forward-word arg))
2644
2645 (defun transpose-sexps (arg)
2646 "Like \\[transpose-words] but applies to sexps.
2647 Does not work on a sexp that point is in the middle of
2648 if it is a list or string."
2649 (interactive "*p")
2650 (transpose-subr 'forward-sexp arg))
2651
2652 (defun transpose-lines (arg)
2653 "Exchange current line and previous line, leaving point after both.
2654 With argument ARG, takes previous line and moves it past ARG lines.
2655 With argument 0, interchanges line point is in with line mark is in."
2656 (interactive "*p")
2657 (transpose-subr (function
2658 (lambda (arg)
2659 (if (> arg 0)
2660 (progn
2661 ;; Move forward over ARG lines,
2662 ;; but create newlines if necessary.
2663 (setq arg (forward-line arg))
2664 (if (/= (preceding-char) ?\n)
2665 (setq arg (1+ arg)))
2666 (if (> arg 0)
2667 (newline arg)))
2668 (forward-line arg))))
2669 arg))
2670
2671 (defvar transpose-subr-start1)
2672 (defvar transpose-subr-start2)
2673 (defvar transpose-subr-end1)
2674 (defvar transpose-subr-end2)
2675
2676 (defun transpose-subr (mover arg)
2677 (let (transpose-subr-start1
2678 transpose-subr-end1
2679 transpose-subr-start2
2680 transpose-subr-end2)
2681 (if (= arg 0)
2682 (progn
2683 (save-excursion
2684 (funcall mover 1)
2685 (setq transpose-subr-end2 (point))
2686 (funcall mover -1)
2687 (setq transpose-subr-start2 (point))
2688 (goto-char (mark))
2689 (funcall mover 1)
2690 (setq transpose-subr-end1 (point))
2691 (funcall mover -1)
2692 (setq transpose-subr-start1 (point))
2693 (transpose-subr-1))
2694 (exchange-point-and-mark))
2695 (if (> arg 0)
2696 (progn
2697 (funcall mover -1)
2698 (setq transpose-subr-start1 (point))
2699 (funcall mover 1)
2700 (setq transpose-subr-end1 (point))
2701 (funcall mover arg)
2702 (setq transpose-subr-end2 (point))
2703 (funcall mover (- arg))
2704 (setq transpose-subr-start2 (point))
2705 (transpose-subr-1)
2706 (goto-char transpose-subr-end2))
2707 (funcall mover -1)
2708 (setq transpose-subr-start2 (point))
2709 (funcall mover 1)
2710 (setq transpose-subr-end2 (point))
2711 (funcall mover (1- arg))
2712 (setq transpose-subr-start1 (point))
2713 (funcall mover (- arg))
2714 (setq transpose-subr-end1 (point))
2715 (transpose-subr-1)))))
2716
2717 (defun transpose-subr-1 ()
2718 (if (> (min transpose-subr-end1 transpose-subr-end2)
2719 (max transpose-subr-start1 transpose-subr-start2))
2720 (error "Don't have two things to transpose"))
2721 (let* ((word1 (buffer-substring transpose-subr-start1 transpose-subr-end1))
2722 (len1 (length word1))
2723 (word2 (buffer-substring transpose-subr-start2 transpose-subr-end2))
2724 (len2 (length word2)))
2725 (delete-region transpose-subr-start2 transpose-subr-end2)
2726 (goto-char transpose-subr-start2)
2727 (insert word1)
2728 (goto-char (if (< transpose-subr-start1 transpose-subr-start2)
2729 transpose-subr-start1
2730 (+ transpose-subr-start1 (- len1 len2))))
2731 (delete-region (point) (+ (point) len1))
2732 (insert word2)))
2733
2734 (defun backward-word (arg)
2735 "Move backward until encountering the end of a word.
2736 With argument, do this that many times."
2737 (interactive "p")
2738 (forward-word (- arg)))
2739
2740 (defun mark-word (arg)
2741 "Set mark arg words away from point."
2742 (interactive "p")
2743 (push-mark
2744 (save-excursion
2745 (forward-word arg)
2746 (point))
2747 nil t))
2748
2749 (defun kill-word (arg)
2750 "Kill characters forward until encountering the end of a word.
2751 With argument, do this that many times."
2752 (interactive "p")
2753 (kill-region (point) (progn (forward-word arg) (point))))
2754
2755 (defun backward-kill-word (arg)
2756 "Kill characters backward until encountering the end of a word.
2757 With argument, do this that many times."
2758 (interactive "p")
2759 (kill-word (- arg)))
2760
2761 (defun current-word (&optional strict)
2762 "Return the word point is on (or a nearby word) as a string.
2763 If optional arg STRICT is non-nil, return nil unless point is within
2764 or adjacent to a word."
2765 (save-excursion
2766 (let ((oldpoint (point)) (start (point)) (end (point)))
2767 (skip-syntax-backward "w_") (setq start (point))
2768 (goto-char oldpoint)
2769 (skip-syntax-forward "w_") (setq end (point))
2770 (if (and (eq start oldpoint) (eq end oldpoint))
2771 ;; Point is neither within nor adjacent to a word.
2772 (and (not strict)
2773 (progn
2774 ;; Look for preceding word in same line.
2775 (skip-syntax-backward "^w_"
2776 (save-excursion (beginning-of-line)
2777 (point)))
2778 (if (bolp)
2779 ;; No preceding word in same line.
2780 ;; Look for following word in same line.
2781 (progn
2782 (skip-syntax-forward "^w_"
2783 (save-excursion (end-of-line)
2784 (point)))
2785 (setq start (point))
2786 (skip-syntax-forward "w_")
2787 (setq end (point)))
2788 (setq end (point))
2789 (skip-syntax-backward "w_")
2790 (setq start (point)))
2791 (buffer-substring-no-properties start end)))
2792 (buffer-substring-no-properties start end)))))
2793
2794 (defcustom fill-prefix nil
2795 "*String for filling to insert at front of new line, or nil for none.
2796 Setting this variable automatically makes it local to the current buffer."
2797 :type '(choice (const :tag "None" nil)
2798 string)
2799 :group 'fill)
2800 (make-variable-buffer-local 'fill-prefix)
2801
2802 (defcustom auto-fill-inhibit-regexp nil
2803 "*Regexp to match lines which should not be auto-filled."
2804 :type '(choice (const :tag "None" nil)
2805 regexp)
2806 :group 'fill)
2807
2808 (defvar comment-line-break-function 'comment-indent-new-line
2809 "*Mode-specific function which line breaks and continues a comment.
2810
2811 This function is only called during auto-filling of a comment section.
2812 The function should take a single optional argument, which is a flag
2813 indicating whether it should use soft newlines.
2814
2815 Setting this variable automatically makes it local to the current buffer.")
2816
2817 ;; This function is used as the auto-fill-function of a buffer
2818 ;; when Auto-Fill mode is enabled.
2819 ;; It returns t if it really did any work.
2820 ;; (Actually some major modes use a different auto-fill function,
2821 ;; but this one is the default one.)
2822 (defun do-auto-fill ()
2823 (let (fc justify bol give-up
2824 (fill-prefix fill-prefix))
2825 (if (or (not (setq justify (current-justification)))
2826 (null (setq fc (current-fill-column)))
2827 (and (eq justify 'left)
2828 (<= (current-column) fc))
2829 (save-excursion (beginning-of-line)
2830 (setq bol (point))
2831 (and auto-fill-inhibit-regexp
2832 (looking-at auto-fill-inhibit-regexp))))
2833 nil ;; Auto-filling not required
2834 (if (memq justify '(full center right))
2835 (save-excursion (unjustify-current-line)))
2836
2837 ;; Choose a fill-prefix automatically.
2838 (if (and adaptive-fill-mode
2839 (or (null fill-prefix) (string= fill-prefix "")))
2840 (let ((prefix
2841 (fill-context-prefix
2842 (save-excursion (backward-paragraph 1) (point))
2843 (save-excursion (forward-paragraph 1) (point)))))
2844 (and prefix (not (equal prefix ""))
2845 (setq fill-prefix prefix))))
2846
2847 (while (and (not give-up) (> (current-column) fc))
2848 ;; Determine where to split the line.
2849 (let* (after-prefix
2850 (fill-point
2851 (let ((opoint (point))
2852 bounce
2853 (first t))
2854 (save-excursion
2855 (beginning-of-line)
2856 (setq after-prefix (point))
2857 (and fill-prefix
2858 (looking-at (regexp-quote fill-prefix))
2859 (setq after-prefix (match-end 0)))
2860 (move-to-column (1+ fc))
2861 ;; Move back to the point where we can break the line.
2862 ;; We break the line between word or
2863 ;; after/before the character which has character
2864 ;; category `|'. We search space, \c| followed by
2865 ;; a character, or \c| following a character. If
2866 ;; not found, place the point at beginning of line.
2867 (while (or first
2868 ;; If this is after period and a single space,
2869 ;; move back once more--we don't want to break
2870 ;; the line there and make it look like a
2871 ;; sentence end.
2872 (and (not (bobp))
2873 (not bounce)
2874 sentence-end-double-space
2875 (save-excursion (forward-char -1)
2876 (and (looking-at "\\. ")
2877 (not (looking-at "\\. ")))))
2878 (and (not (bobp))
2879 (not bounce)
2880 fill-nobreak-predicate
2881 (funcall fill-nobreak-predicate)))
2882 (setq first nil)
2883 (re-search-backward "[ \t]\\|\\c|.\\|.\\c|\\|^")
2884 ;; If we find nowhere on the line to break it,
2885 ;; break after one word. Set bounce to t
2886 ;; so we will not keep going in this while loop.
2887 (if (<= (point) after-prefix)
2888 (progn
2889 (goto-char after-prefix)
2890 (re-search-forward "[ \t]" opoint t)
2891 (setq bounce t))
2892 (if (looking-at "[ \t]")
2893 ;; Break the line at word boundary.
2894 (skip-chars-backward " \t")
2895 ;; Break the line after/before \c|.
2896 (forward-char 1))))
2897 (if enable-multibyte-characters
2898 ;; If we are going to break the line after or
2899 ;; before a non-ascii character, we may have
2900 ;; to run a special function for the charset
2901 ;; of the character to find the correct break
2902 ;; point.
2903 (if (not (and (eq (charset-after (1- (point))) 'ascii)
2904 (eq (charset-after (point)) 'ascii)))
2905 (fill-find-break-point after-prefix)))
2906
2907 ;; Let fill-point be set to the place where we end up.
2908 ;; But move back before any whitespace here.
2909 (skip-chars-backward " \t")
2910 (point)))))
2911
2912 ;; See whether the place we found is any good.
2913 (if (save-excursion
2914 (goto-char fill-point)
2915 (and (not (bolp))
2916 ;; There is no use breaking at end of line.
2917 (not (save-excursion (skip-chars-forward " ") (eolp)))
2918 ;; It is futile to split at the end of the prefix
2919 ;; since we would just insert the prefix again.
2920 (not (and after-prefix (<= (point) after-prefix)))
2921 ;; Don't split right after a comment starter
2922 ;; since we would just make another comment starter.
2923 (not (and comment-start-skip
2924 (let ((limit (point)))
2925 (beginning-of-line)
2926 (and (re-search-forward comment-start-skip
2927 limit t)
2928 (eq (point) limit)))))))
2929 ;; Ok, we have a useful place to break the line. Do it.
2930 (let ((prev-column (current-column)))
2931 ;; If point is at the fill-point, do not `save-excursion'.
2932 ;; Otherwise, if a comment prefix or fill-prefix is inserted,
2933 ;; point will end up before it rather than after it.
2934 (if (save-excursion
2935 (skip-chars-backward " \t")
2936 (= (point) fill-point))
2937 (funcall comment-line-break-function t)
2938 (save-excursion
2939 (goto-char fill-point)
2940 (funcall comment-line-break-function t)))
2941 ;; Now do justification, if required
2942 (if (not (eq justify 'left))
2943 (save-excursion
2944 (end-of-line 0)
2945 (justify-current-line justify nil t)))
2946 ;; If making the new line didn't reduce the hpos of
2947 ;; the end of the line, then give up now;
2948 ;; trying again will not help.
2949 (if (>= (current-column) prev-column)
2950 (setq give-up t)))
2951 ;; No good place to break => stop trying.
2952 (setq give-up t))))
2953 ;; Justify last line.
2954 (justify-current-line justify t t)
2955 t)))
2956
2957 (defvar normal-auto-fill-function 'do-auto-fill
2958 "The function to use for `auto-fill-function' if Auto Fill mode is turned on.
2959 Some major modes set this.")
2960
2961 (defun auto-fill-mode (&optional arg)
2962 "Toggle Auto Fill mode.
2963 With arg, turn Auto Fill mode on if and only if arg is positive.
2964 In Auto Fill mode, inserting a space at a column beyond `current-fill-column'
2965 automatically breaks the line at a previous space.
2966
2967 The value of `normal-auto-fill-function' specifies the function to use
2968 for `auto-fill-function' when turning Auto Fill mode on."
2969 (interactive "P")
2970 (prog1 (setq auto-fill-function
2971 (if (if (null arg)
2972 (not auto-fill-function)
2973 (> (prefix-numeric-value arg) 0))
2974 normal-auto-fill-function
2975 nil))
2976 (force-mode-line-update)))
2977
2978 ;; This holds a document string used to document auto-fill-mode.
2979 (defun auto-fill-function ()
2980 "Automatically break line at a previous space, in insertion of text."
2981 nil)
2982
2983 (defun turn-on-auto-fill ()
2984 "Unconditionally turn on Auto Fill mode."
2985 (auto-fill-mode 1))
2986
2987 (defun turn-off-auto-fill ()
2988 "Unconditionally turn off Auto Fill mode."
2989 (auto-fill-mode -1))
2990
2991 (custom-add-option 'text-mode-hook 'turn-on-auto-fill)
2992
2993 (defun set-fill-column (arg)
2994 "Set `fill-column' to specified argument.
2995 Use \\[universal-argument] followed by a number to specify a column.
2996 Just \\[universal-argument] as argument means to use the current column."
2997 (interactive "P")
2998 (if (consp arg)
2999 (setq arg (current-column)))
3000 (if (not (integerp arg))
3001 ;; Disallow missing argument; it's probably a typo for C-x C-f.
3002 (error "set-fill-column requires an explicit argument")
3003 (message "Fill column set to %d (was %d)" arg fill-column)
3004 (setq fill-column arg)))
3005
3006 (defun set-selective-display (arg)
3007 "Set `selective-display' to ARG; clear it if no arg.
3008 When the value of `selective-display' is a number > 0,
3009 lines whose indentation is >= that value are not displayed.
3010 The variable `selective-display' has a separate value for each buffer."
3011 (interactive "P")
3012 (if (eq selective-display t)
3013 (error "selective-display already in use for marked lines"))
3014 (let ((current-vpos
3015 (save-restriction
3016 (narrow-to-region (point-min) (point))
3017 (goto-char (window-start))
3018 (vertical-motion (window-height)))))
3019 (setq selective-display
3020 (and arg (prefix-numeric-value arg)))
3021 (recenter current-vpos))
3022 (set-window-start (selected-window) (window-start (selected-window)))
3023 (princ "selective-display set to " t)
3024 (prin1 selective-display t)
3025 (princ "." t))
3026
3027 (defvar overwrite-mode-textual " Ovwrt"
3028 "The string displayed in the mode line when in overwrite mode.")
3029 (defvar overwrite-mode-binary " Bin Ovwrt"
3030 "The string displayed in the mode line when in binary overwrite mode.")
3031
3032 (defun overwrite-mode (arg)
3033 "Toggle overwrite mode.
3034 With arg, turn overwrite mode on iff arg is positive.
3035 In overwrite mode, printing characters typed in replace existing text
3036 on a one-for-one basis, rather than pushing it to the right. At the
3037 end of a line, such characters extend the line. Before a tab,
3038 such characters insert until the tab is filled in.
3039 \\[quoted-insert] still inserts characters in overwrite mode; this
3040 is supposed to make it easier to insert characters when necessary."
3041 (interactive "P")
3042 (setq overwrite-mode
3043 (if (if (null arg) (not overwrite-mode)
3044 (> (prefix-numeric-value arg) 0))
3045 'overwrite-mode-textual))
3046 (force-mode-line-update))
3047
3048 (defun binary-overwrite-mode (arg)
3049 "Toggle binary overwrite mode.
3050 With arg, turn binary overwrite mode on iff arg is positive.
3051 In binary overwrite mode, printing characters typed in replace
3052 existing text. Newlines are not treated specially, so typing at the
3053 end of a line joins the line to the next, with the typed character
3054 between them. Typing before a tab character simply replaces the tab
3055 with the character typed.
3056 \\[quoted-insert] replaces the text at the cursor, just as ordinary
3057 typing characters do.
3058
3059 Note that binary overwrite mode is not its own minor mode; it is a
3060 specialization of overwrite-mode, entered by setting the
3061 `overwrite-mode' variable to `overwrite-mode-binary'."
3062 (interactive "P")
3063 (setq overwrite-mode
3064 (if (if (null arg)
3065 (not (eq overwrite-mode 'overwrite-mode-binary))
3066 (> (prefix-numeric-value arg) 0))
3067 'overwrite-mode-binary))
3068 (force-mode-line-update))
3069
3070 (defcustom line-number-mode t
3071 "*Non-nil means display line number in mode line."
3072 :type 'boolean
3073 :group 'editing-basics)
3074
3075 (defun line-number-mode (arg)
3076 "Toggle Line Number mode.
3077 With arg, turn Line Number mode on iff arg is positive.
3078 When Line Number mode is enabled, the line number appears
3079 in the mode line.
3080
3081 Line numbers do not appear for very large buffers, see variable
3082 `line-number-display-limit'."
3083 (interactive "P")
3084 (setq line-number-mode
3085 (if (null arg) (not line-number-mode)
3086 (> (prefix-numeric-value arg) 0)))
3087 (force-mode-line-update))
3088
3089 (defcustom column-number-mode nil
3090 "*Non-nil means display column number in mode line."
3091 :type 'boolean
3092 :group 'editing-basics)
3093
3094 (defun column-number-mode (arg)
3095 "Toggle Column Number mode.
3096 With arg, turn Column Number mode on iff arg is positive.
3097 When Column Number mode is enabled, the column number appears
3098 in the mode line."
3099 (interactive "P")
3100 (setq column-number-mode
3101 (if (null arg) (not column-number-mode)
3102 (> (prefix-numeric-value arg) 0)))
3103 (force-mode-line-update))
3104
3105 (defgroup paren-blinking nil
3106 "Blinking matching of parens and expressions."
3107 :prefix "blink-matching-"
3108 :group 'paren-matching)
3109
3110 (defcustom blink-matching-paren t
3111 "*Non-nil means show matching open-paren when close-paren is inserted."
3112 :type 'boolean
3113 :group 'paren-blinking)
3114
3115 (defcustom blink-matching-paren-on-screen t
3116 "*Non-nil means show matching open-paren when it is on screen.
3117 If nil, means don't show it (but the open-paren can still be shown
3118 when it is off screen)."
3119 :type 'boolean
3120 :group 'paren-blinking)
3121
3122 (defcustom blink-matching-paren-distance (* 25 1024)
3123 "*If non-nil, is maximum distance to search for matching open-paren."
3124 :type 'integer
3125 :group 'paren-blinking)
3126
3127 (defcustom blink-matching-delay 1
3128 "*Time in seconds to delay after showing a matching paren."
3129 :type 'number
3130 :group 'paren-blinking)
3131
3132 (defcustom blink-matching-paren-dont-ignore-comments nil
3133 "*Non-nil means `blink-matching-paren' will not ignore comments."
3134 :type 'boolean
3135 :group 'paren-blinking)
3136
3137 (defun blink-matching-open ()
3138 "Move cursor momentarily to the beginning of the sexp before point."
3139 (interactive)
3140 (and (> (point) (1+ (point-min)))
3141 blink-matching-paren
3142 ;; Verify an even number of quoting characters precede the close.
3143 (= 1 (logand 1 (- (point)
3144 (save-excursion
3145 (forward-char -1)
3146 (skip-syntax-backward "/\\")
3147 (point)))))
3148 (let* ((oldpos (point))
3149 (blinkpos)
3150 (mismatch))
3151 (save-excursion
3152 (save-restriction
3153 (if blink-matching-paren-distance
3154 (narrow-to-region (max (point-min)
3155 (- (point) blink-matching-paren-distance))
3156 oldpos))
3157 (condition-case ()
3158 (let ((parse-sexp-ignore-comments
3159 (and parse-sexp-ignore-comments
3160 (not blink-matching-paren-dont-ignore-comments))))
3161 (setq blinkpos (scan-sexps oldpos -1)))
3162 (error nil)))
3163 (and blinkpos
3164 (/= (char-syntax (char-after blinkpos))
3165 ?\$)
3166 (setq mismatch
3167 (or (null (matching-paren (char-after blinkpos)))
3168 (/= (char-after (1- oldpos))
3169 (matching-paren (char-after blinkpos))))))
3170 (if mismatch (setq blinkpos nil))
3171 (if blinkpos
3172 ;; Don't log messages about paren matching.
3173 (let (message-log-max)
3174 (goto-char blinkpos)
3175 (if (pos-visible-in-window-p)
3176 (and blink-matching-paren-on-screen
3177 (sit-for blink-matching-delay))
3178 (goto-char blinkpos)
3179 (message
3180 "Matches %s"
3181 ;; Show what precedes the open in its line, if anything.
3182 (if (save-excursion
3183 (skip-chars-backward " \t")
3184 (not (bolp)))
3185 (buffer-substring (progn (beginning-of-line) (point))
3186 (1+ blinkpos))
3187 ;; Show what follows the open in its line, if anything.
3188 (if (save-excursion
3189 (forward-char 1)
3190 (skip-chars-forward " \t")
3191 (not (eolp)))
3192 (buffer-substring blinkpos
3193 (progn (end-of-line) (point)))
3194 ;; Otherwise show the previous nonblank line,
3195 ;; if there is one.
3196 (if (save-excursion
3197 (skip-chars-backward "\n \t")
3198 (not (bobp)))
3199 (concat
3200 (buffer-substring (progn
3201 (skip-chars-backward "\n \t")
3202 (beginning-of-line)
3203 (point))
3204 (progn (end-of-line)
3205 (skip-chars-backward " \t")
3206 (point)))
3207 ;; Replace the newline and other whitespace with `...'.
3208 "..."
3209 (buffer-substring blinkpos (1+ blinkpos)))
3210 ;; There is nothing to show except the char itself.
3211 (buffer-substring blinkpos (1+ blinkpos))))))))
3212 (cond (mismatch
3213 (message "Mismatched parentheses"))
3214 ((not blink-matching-paren-distance)
3215 (message "Unmatched parenthesis"))))))))
3216
3217 ;Turned off because it makes dbx bomb out.
3218 (setq blink-paren-function 'blink-matching-open)
3219
3220 ;; This executes C-g typed while Emacs is waiting for a command.
3221 ;; Quitting out of a program does not go through here;
3222 ;; that happens in the QUIT macro at the C code level.
3223 (defun keyboard-quit ()
3224 "Signal a `quit' condition.
3225 During execution of Lisp code, this character causes a quit directly.
3226 At top-level, as an editor command, this simply beeps."
3227 (interactive)
3228 (deactivate-mark)
3229 (signal 'quit nil))
3230
3231 (define-key global-map "\C-g" 'keyboard-quit)
3232
3233 (defvar buffer-quit-function nil
3234 "Function to call to \"quit\" the current buffer, or nil if none.
3235 \\[keyboard-escape-quit] calls this function when its more local actions
3236 \(such as cancelling a prefix argument, minibuffer or region) do not apply.")
3237
3238 (defun keyboard-escape-quit ()
3239 "Exit the current \"mode\" (in a generalized sense of the word).
3240 This command can exit an interactive command such as `query-replace',
3241 can clear out a prefix argument or a region,
3242 can get out of the minibuffer or other recursive edit,
3243 cancel the use of the current buffer (for special-purpose buffers),
3244 or go back to just one window (by deleting all but the selected window)."
3245 (interactive)
3246 (cond ((eq last-command 'mode-exited) nil)
3247 ((> (minibuffer-depth) 0)
3248 (abort-recursive-edit))
3249 (current-prefix-arg
3250 nil)
3251 ((and transient-mark-mode
3252 mark-active)
3253 (deactivate-mark))
3254 ((> (recursion-depth) 0)
3255 (exit-recursive-edit))
3256 (buffer-quit-function
3257 (funcall buffer-quit-function))
3258 ((not (one-window-p t))
3259 (delete-other-windows))
3260 ((string-match "^ \\*" (buffer-name (current-buffer)))
3261 (bury-buffer))))
3262
3263 (define-key global-map "\e\e\e" 'keyboard-escape-quit)
3264
3265 (defcustom input-mode-8-bit t
3266 "Control acceptance of 8-bit keyboard input.
3267 This may be useful for inputting non-ASCII characters if your keyboard
3268 can generate them. It is not necessary to change this under a window
3269 system which can distinguish 8-bit characters and Meta keys.
3270 Setting this variable directly does not take effect;
3271 use either M-x customize or the function `set-input-mode'."
3272 :set (lambda (symbol value)
3273 (let ((mode (current-input-mode)))
3274 (set-input-mode (nth 0 mode) (nth 1 mode) value)))
3275 :initialize 'custom-initialize-default
3276 :type '(choice (const :tag "8-bit input for a Meta key" t)
3277 (const :tag "Direct 8-bit character input" 0)
3278 (const :tag "Assume top bit is parity and ignore" nil))
3279 :version "21.1"
3280 :link '(custom-manual "Single-Byte European Support")
3281 :group 'keyboard)
3282
3283 (defcustom read-mail-command 'rmail
3284 "*Your preference for a mail reading package.
3285 This is used by some keybindings which support reading mail.
3286 See also `mail-user-agent' concerning sending mail."
3287 :type '(choice (function-item rmail)
3288 (function-item gnus)
3289 (function-item mh-rmail)
3290 (function :tag "Other"))
3291 :version "21.1"
3292 :group 'mail)
3293
3294 (defcustom mail-user-agent 'sendmail-user-agent
3295 "*Your preference for a mail composition package.
3296 Various Emacs Lisp packages (e.g. Reporter) require you to compose an
3297 outgoing email message. This variable lets you specify which
3298 mail-sending package you prefer.
3299
3300 Valid values include:
3301
3302 `sendmail-user-agent' -- use the default Emacs Mail package.
3303 See Info node `(emacs)Sending Mail'.
3304 `mh-e-user-agent' -- use the Emacs interface to the MH mail system.
3305 See Info node `(mh-e)'.
3306 `message-user-agent' -- use the Gnus Message package.
3307 See Info node `(message)'.
3308 `gnus-user-agent' -- like `message-user-agent', but with Gnus
3309 paraphernalia, particularly the Gcc: header for
3310 archiving.
3311
3312 Additional valid symbols may be available; check with the author of
3313 your package for details.
3314
3315 See also `read-mail-command' concerning reading mail."
3316 :type '(radio (function-item :tag "Default Emacs mail"
3317 :format "%t\n"
3318 sendmail-user-agent)
3319 (function-item :tag "Emacs interface to MH"
3320 :format "%t\n"
3321 mh-e-user-agent)
3322 (function-item :tag "Gnus Message package"
3323 :format "%t\n"
3324 message-user-agent)
3325 (function-item :tag "Gnus Message with full Gnus features"
3326 :format "%t\n"
3327 gnus-user-agent)
3328 (function :tag "Other"))
3329 :group 'mail)
3330
3331 (defun define-mail-user-agent (symbol composefunc sendfunc
3332 &optional abortfunc hookvar)
3333 "Define a symbol to identify a mail-sending package for `mail-user-agent'.
3334
3335 SYMBOL can be any Lisp symbol. Its function definition and/or
3336 value as a variable do not matter for this usage; we use only certain
3337 properties on its property list, to encode the rest of the arguments.
3338
3339 COMPOSEFUNC is program callable function that composes an outgoing
3340 mail message buffer. This function should set up the basics of the
3341 buffer without requiring user interaction. It should populate the
3342 standard mail headers, leaving the `to:' and `subject:' headers blank
3343 by default.
3344
3345 COMPOSEFUNC should accept several optional arguments--the same
3346 arguments that `compose-mail' takes. See that function's documentation.
3347
3348 SENDFUNC is the command a user would run to send the message.
3349
3350 Optional ABORTFUNC is the command a user would run to abort the
3351 message. For mail packages that don't have a separate abort function,
3352 this can be `kill-buffer' (the equivalent of omitting this argument).
3353
3354 Optional HOOKVAR is a hook variable that gets run before the message
3355 is actually sent. Callers that use the `mail-user-agent' may
3356 install a hook function temporarily on this hook variable.
3357 If HOOKVAR is nil, `mail-send-hook' is used.
3358
3359 The properties used on SYMBOL are `composefunc', `sendfunc',
3360 `abortfunc', and `hookvar'."
3361 (put symbol 'composefunc composefunc)
3362 (put symbol 'sendfunc sendfunc)
3363 (put symbol 'abortfunc (or abortfunc 'kill-buffer))
3364 (put symbol 'hookvar (or hookvar 'mail-send-hook)))
3365
3366 (define-mail-user-agent 'sendmail-user-agent
3367 'sendmail-user-agent-compose
3368 'mail-send-and-exit)
3369
3370 (defun rfc822-goto-eoh ()
3371 ;; Go to header delimiter line in a mail message, following RFC822 rules
3372 (goto-char (point-min))
3373 (while (looking-at "^[^: \n]+:\\|^[ \t]")
3374 (forward-line 1))
3375 (point))
3376
3377 (defun sendmail-user-agent-compose (&optional to subject other-headers continue
3378 switch-function yank-action
3379 send-actions)
3380 (if switch-function
3381 (let ((special-display-buffer-names nil)
3382 (special-display-regexps nil)
3383 (same-window-buffer-names nil)
3384 (same-window-regexps nil))
3385 (funcall switch-function "*mail*")))
3386 (let ((cc (cdr (assoc-ignore-case "cc" other-headers)))
3387 (in-reply-to (cdr (assoc-ignore-case "in-reply-to" other-headers)))
3388 (body (cdr (assoc-ignore-case "body" other-headers))))
3389 (or (mail continue to subject in-reply-to cc yank-action send-actions)
3390 continue
3391 (error "Message aborted"))
3392 (save-excursion
3393 (rfc822-goto-eoh)
3394 (while other-headers
3395 (unless (member-ignore-case (car (car other-headers))
3396 '("in-reply-to" "cc" "body"))
3397 (insert (car (car other-headers)) ": "
3398 (cdr (car other-headers)) "\n"))
3399 (setq other-headers (cdr other-headers)))
3400 (when body
3401 (forward-line 1)
3402 (insert body))
3403 t)))
3404
3405 (define-mail-user-agent 'mh-e-user-agent
3406 'mh-smail-batch 'mh-send-letter 'mh-fully-kill-draft
3407 'mh-before-send-letter-hook)
3408
3409 (defun compose-mail (&optional to subject other-headers continue
3410 switch-function yank-action send-actions)
3411 "Start composing a mail message to send.
3412 This uses the user's chosen mail composition package
3413 as selected with the variable `mail-user-agent'.
3414 The optional arguments TO and SUBJECT specify recipients
3415 and the initial Subject field, respectively.
3416
3417 OTHER-HEADERS is an alist specifying additional
3418 header fields. Elements look like (HEADER . VALUE) where both
3419 HEADER and VALUE are strings.
3420
3421 CONTINUE, if non-nil, says to continue editing a message already
3422 being composed.
3423
3424 SWITCH-FUNCTION, if non-nil, is a function to use to
3425 switch to and display the buffer used for mail composition.
3426
3427 YANK-ACTION, if non-nil, is an action to perform, if and when necessary,
3428 to insert the raw text of the message being replied to.
3429 It has the form (FUNCTION . ARGS). The user agent will apply
3430 FUNCTION to ARGS, to insert the raw text of the original message.
3431 \(The user agent will also run `mail-citation-hook', *after* the
3432 original text has been inserted in this way.)
3433
3434 SEND-ACTIONS is a list of actions to call when the message is sent.
3435 Each action has the form (FUNCTION . ARGS)."
3436 (interactive
3437 (list nil nil nil current-prefix-arg))
3438 (let ((function (get mail-user-agent 'composefunc)))
3439 (funcall function to subject other-headers continue
3440 switch-function yank-action send-actions)))
3441
3442 (defun compose-mail-other-window (&optional to subject other-headers continue
3443 yank-action send-actions)
3444 "Like \\[compose-mail], but edit the outgoing message in another window."
3445 (interactive
3446 (list nil nil nil current-prefix-arg))
3447 (compose-mail to subject other-headers continue
3448 'switch-to-buffer-other-window yank-action send-actions))
3449
3450
3451 (defun compose-mail-other-frame (&optional to subject other-headers continue
3452 yank-action send-actions)
3453 "Like \\[compose-mail], but edit the outgoing message in another frame."
3454 (interactive
3455 (list nil nil nil current-prefix-arg))
3456 (compose-mail to subject other-headers continue
3457 'switch-to-buffer-other-frame yank-action send-actions))
3458
3459 (defvar set-variable-value-history nil
3460 "History of values entered with `set-variable'.")
3461
3462 (defun set-variable (var val)
3463 "Set VARIABLE to VALUE. VALUE is a Lisp object.
3464 When using this interactively, enter a Lisp object for VALUE.
3465 If you want VALUE to be a string, you must surround it with doublequotes.
3466 VALUE is used literally, not evaluated.
3467
3468 If VARIABLE has a `variable-interactive' property, that is used as if
3469 it were the arg to `interactive' (which see) to interactively read VALUE.
3470
3471 If VARIABLE has been defined with `defcustom', then the type information
3472 in the definition is used to check that VALUE is valid."
3473 (interactive
3474 (let* ((default-var (variable-at-point))
3475 (var (if (symbolp default-var)
3476 (read-variable (format "Set variable (default %s): " default-var)
3477 default-var)
3478 (read-variable "Set variable: ")))
3479 (minibuffer-help-form '(describe-variable var))
3480 (prop (get var 'variable-interactive))
3481 (prompt (format "Set %s to value: " var))
3482 (val (if prop
3483 ;; Use VAR's `variable-interactive' property
3484 ;; as an interactive spec for prompting.
3485 (call-interactively `(lambda (arg)
3486 (interactive ,prop)
3487 arg))
3488 (read
3489 (read-string prompt nil
3490 'set-variable-value-history)))))
3491 (list var val)))
3492
3493 (let ((type (get var 'custom-type)))
3494 (when type
3495 ;; Match with custom type.
3496 (require 'wid-edit)
3497 (setq type (widget-convert type))
3498 (unless (widget-apply type :match val)
3499 (error "Value `%S' does not match type %S of %S"
3500 val (car type) var))))
3501 (set var val))
3502
3503 ;; Define the major mode for lists of completions.
3504
3505 (defvar completion-list-mode-map nil
3506 "Local map for completion list buffers.")
3507 (or completion-list-mode-map
3508 (let ((map (make-sparse-keymap)))
3509 (define-key map [mouse-2] 'mouse-choose-completion)
3510 (define-key map [down-mouse-2] nil)
3511 (define-key map "\C-m" 'choose-completion)
3512 (define-key map "\e\e\e" 'delete-completion-window)
3513 (define-key map [left] 'previous-completion)
3514 (define-key map [right] 'next-completion)
3515 (setq completion-list-mode-map map)))
3516
3517 ;; Completion mode is suitable only for specially formatted data.
3518 (put 'completion-list-mode 'mode-class 'special)
3519
3520 (defvar completion-reference-buffer nil
3521 "Record the buffer that was current when the completion list was requested.
3522 This is a local variable in the completion list buffer.
3523 Initial value is nil to avoid some compiler warnings.")
3524
3525 (defvar completion-no-auto-exit nil
3526 "Non-nil means `choose-completion-string' should never exit the minibuffer.
3527 This also applies to other functions such as `choose-completion'
3528 and `mouse-choose-completion'.")
3529
3530 (defvar completion-base-size nil
3531 "Number of chars at beginning of minibuffer not involved in completion.
3532 This is a local variable in the completion list buffer
3533 but it talks about the buffer in `completion-reference-buffer'.
3534 If this is nil, it means to compare text to determine which part
3535 of the tail end of the buffer's text is involved in completion.")
3536
3537 (defun delete-completion-window ()
3538 "Delete the completion list window.
3539 Go to the window from which completion was requested."
3540 (interactive)
3541 (let ((buf completion-reference-buffer))
3542 (if (one-window-p t)
3543 (if (window-dedicated-p (selected-window))
3544 (delete-frame (selected-frame)))
3545 (delete-window (selected-window))
3546 (if (get-buffer-window buf)
3547 (select-window (get-buffer-window buf))))))
3548
3549 (defun previous-completion (n)
3550 "Move to the previous item in the completion list."
3551 (interactive "p")
3552 (next-completion (- n)))
3553
3554 (defun next-completion (n)
3555 "Move to the next item in the completion list.
3556 With prefix argument N, move N items (negative N means move backward)."
3557 (interactive "p")
3558 (let ((beg (point-min)) (end (point-max)))
3559 (while (and (> n 0) (not (eobp)))
3560 ;; If in a completion, move to the end of it.
3561 (when (get-text-property (point) 'mouse-face)
3562 (goto-char (next-single-property-change (point) 'mouse-face nil end)))
3563 ;; Move to start of next one.
3564 (unless (get-text-property (point) 'mouse-face)
3565 (goto-char (next-single-property-change (point) 'mouse-face nil end)))
3566 (setq n (1- n)))
3567 (while (and (< n 0) (not (bobp)))
3568 (let ((prop (get-text-property (1- (point)) 'mouse-face)))
3569 ;; If in a completion, move to the start of it.
3570 (when (and prop (eq prop (get-text-property (point) 'mouse-face)))
3571 (goto-char (previous-single-property-change
3572 (point) 'mouse-face nil beg)))
3573 ;; Move to end of the previous completion.
3574 (unless (or (bobp) (get-text-property (1- (point)) 'mouse-face))
3575 (goto-char (previous-single-property-change
3576 (point) 'mouse-face nil beg)))
3577 ;; Move to the start of that one.
3578 (goto-char (previous-single-property-change
3579 (point) 'mouse-face nil beg))
3580 (setq n (1+ n))))))
3581
3582 (defun choose-completion ()
3583 "Choose the completion that point is in or next to."
3584 (interactive)
3585 (let (beg end completion (buffer completion-reference-buffer)
3586 (base-size completion-base-size))
3587 (if (and (not (eobp)) (get-text-property (point) 'mouse-face))
3588 (setq end (point) beg (1+ (point))))
3589 (if (and (not (bobp)) (get-text-property (1- (point)) 'mouse-face))
3590 (setq end (1- (point)) beg (point)))
3591 (if (null beg)
3592 (error "No completion here"))
3593 (setq beg (previous-single-property-change beg 'mouse-face))
3594 (setq end (or (next-single-property-change end 'mouse-face) (point-max)))
3595 (setq completion (buffer-substring beg end))
3596 (let ((owindow (selected-window)))
3597 (if (and (one-window-p t 'selected-frame)
3598 (window-dedicated-p (selected-window)))
3599 ;; This is a special buffer's frame
3600 (iconify-frame (selected-frame))
3601 (or (window-dedicated-p (selected-window))
3602 (bury-buffer)))
3603 (select-window owindow))
3604 (choose-completion-string completion buffer base-size)))
3605
3606 ;; Delete the longest partial match for STRING
3607 ;; that can be found before POINT.
3608 (defun choose-completion-delete-max-match (string)
3609 (let ((opoint (point))
3610 (len (min (length string)
3611 (- (point) (point-min)))))
3612 (goto-char (- (point) (length string)))
3613 (if completion-ignore-case
3614 (setq string (downcase string)))
3615 (while (and (> len 0)
3616 (let ((tail (buffer-substring (point)
3617 (+ (point) len))))
3618 (if completion-ignore-case
3619 (setq tail (downcase tail)))
3620 (not (string= tail (substring string 0 len)))))
3621 (setq len (1- len))
3622 (forward-char 1))
3623 (delete-char len)))
3624
3625 ;; Switch to BUFFER and insert the completion choice CHOICE.
3626 ;; BASE-SIZE, if non-nil, says how many characters of BUFFER's text
3627 ;; to keep. If it is nil, use choose-completion-delete-max-match instead.
3628
3629 ;; If BUFFER is the minibuffer, exit the minibuffer
3630 ;; unless it is reading a file name and CHOICE is a directory,
3631 ;; or completion-no-auto-exit is non-nil.
3632 (defun choose-completion-string (choice &optional buffer base-size)
3633 (let ((buffer (or buffer completion-reference-buffer))
3634 (mini-p (string-match "\\` \\*Minibuf-[0-9]+\\*\\'" (buffer-name buffer))))
3635 ;; If BUFFER is a minibuffer, barf unless it's the currently
3636 ;; active minibuffer.
3637 (if (and mini-p
3638 (or (not (active-minibuffer-window))
3639 (not (equal buffer
3640 (window-buffer (active-minibuffer-window))))))
3641 (error "Minibuffer is not active for completion")
3642 ;; Insert the completion into the buffer where completion was requested.
3643 (set-buffer buffer)
3644 (if base-size
3645 (delete-region (+ base-size (if mini-p
3646 (minibuffer-prompt-end)
3647 (point-min)))
3648 (point))
3649 (choose-completion-delete-max-match choice))
3650 (insert choice)
3651 (remove-text-properties (- (point) (length choice)) (point)
3652 '(mouse-face nil))
3653 ;; Update point in the window that BUFFER is showing in.
3654 (let ((window (get-buffer-window buffer t)))
3655 (set-window-point window (point)))
3656 ;; If completing for the minibuffer, exit it with this choice.
3657 (and (not completion-no-auto-exit)
3658 (equal buffer (window-buffer (minibuffer-window)))
3659 minibuffer-completion-table
3660 ;; If this is reading a file name, and the file name chosen
3661 ;; is a directory, don't exit the minibuffer.
3662 (if (and (eq minibuffer-completion-table 'read-file-name-internal)
3663 (file-directory-p (field-string (point-max))))
3664 (select-window (active-minibuffer-window))
3665 (exit-minibuffer))))))
3666
3667 (defun completion-list-mode ()
3668 "Major mode for buffers showing lists of possible completions.
3669 Type \\<completion-list-mode-map>\\[choose-completion] in the completion list\
3670 to select the completion near point.
3671 Use \\<completion-list-mode-map>\\[mouse-choose-completion] to select one\
3672 with the mouse."
3673 (interactive)
3674 (kill-all-local-variables)
3675 (use-local-map completion-list-mode-map)
3676 (setq mode-name "Completion List")
3677 (setq major-mode 'completion-list-mode)
3678 (make-local-variable 'completion-base-size)
3679 (setq completion-base-size nil)
3680 (run-hooks 'completion-list-mode-hook))
3681
3682 (defvar completion-setup-hook nil
3683 "Normal hook run at the end of setting up a completion list buffer.
3684 When this hook is run, the current buffer is the one in which the
3685 command to display the completion list buffer was run.
3686 The completion list buffer is available as the value of `standard-output'.")
3687
3688 ;; This function goes in completion-setup-hook, so that it is called
3689 ;; after the text of the completion list buffer is written.
3690
3691 (defun completion-setup-function ()
3692 (save-excursion
3693 (let ((mainbuf (current-buffer)))
3694 (set-buffer standard-output)
3695 (completion-list-mode)
3696 (make-local-variable 'completion-reference-buffer)
3697 (setq completion-reference-buffer mainbuf)
3698 (if (eq minibuffer-completion-table 'read-file-name-internal)
3699 ;; For file name completion,
3700 ;; use the number of chars before the start of the
3701 ;; last file name component.
3702 (setq completion-base-size
3703 (save-excursion
3704 (set-buffer mainbuf)
3705 (goto-char (point-max))
3706 (skip-chars-backward (format "^%c" directory-sep-char))
3707 (- (point) (minibuffer-prompt-end))))
3708 ;; Otherwise, in minibuffer, the whole input is being completed.
3709 (save-match-data
3710 (if (string-match "\\` \\*Minibuf-[0-9]+\\*\\'"
3711 (buffer-name mainbuf))
3712 (setq completion-base-size 0))))
3713 (goto-char (point-min))
3714 (if (display-mouse-p)
3715 (insert (substitute-command-keys
3716 "Click \\[mouse-choose-completion] on a completion to select it.\n")))
3717 (insert (substitute-command-keys
3718 "In this buffer, type \\[choose-completion] to \
3719 select the completion near point.\n\n")))))
3720
3721 (add-hook 'completion-setup-hook 'completion-setup-function)
3722
3723 (define-key minibuffer-local-completion-map [prior]
3724 'switch-to-completions)
3725 (define-key minibuffer-local-must-match-map [prior]
3726 'switch-to-completions)
3727 (define-key minibuffer-local-completion-map "\M-v"
3728 'switch-to-completions)
3729 (define-key minibuffer-local-must-match-map "\M-v"
3730 'switch-to-completions)
3731
3732 (defun switch-to-completions ()
3733 "Select the completion list window."
3734 (interactive)
3735 ;; Make sure we have a completions window.
3736 (or (get-buffer-window "*Completions*")
3737 (minibuffer-completion-help))
3738 (let ((window (get-buffer-window "*Completions*")))
3739 (when window
3740 (select-window window)
3741 (goto-char (point-min))
3742 (search-forward "\n\n")
3743 (forward-line 1))))
3744
3745 ;; Support keyboard commands to turn on various modifiers.
3746
3747 ;; These functions -- which are not commands -- each add one modifier
3748 ;; to the following event.
3749
3750 (defun event-apply-alt-modifier (ignore-prompt)
3751 "Add the Alt modifier to the following event.
3752 For example, type \\[event-apply-alt-modifier] & to enter Alt-&."
3753 (vector (event-apply-modifier (read-event) 'alt 22 "A-")))
3754 (defun event-apply-super-modifier (ignore-prompt)
3755 "Add the Super modifier to the following event.
3756 For example, type \\[event-apply-super-modifier] & to enter Super-&."
3757 (vector (event-apply-modifier (read-event) 'super 23 "s-")))
3758 (defun event-apply-hyper-modifier (ignore-prompt)
3759 "Add the Hyper modifier to the following event.
3760 For example, type \\[event-apply-hyper-modifier] & to enter Hyper-&."
3761 (vector (event-apply-modifier (read-event) 'hyper 24 "H-")))
3762 (defun event-apply-shift-modifier (ignore-prompt)
3763 "Add the Shift modifier to the following event.
3764 For example, type \\[event-apply-shift-modifier] & to enter Shift-&."
3765 (vector (event-apply-modifier (read-event) 'shift 25 "S-")))
3766 (defun event-apply-control-modifier (ignore-prompt)
3767 "Add the Ctrl modifier to the following event.
3768 For example, type \\[event-apply-control-modifier] & to enter Ctrl-&."
3769 (vector (event-apply-modifier (read-event) 'control 26 "C-")))
3770 (defun event-apply-meta-modifier (ignore-prompt)
3771 "Add the Meta modifier to the following event.
3772 For example, type \\[event-apply-meta-modifier] & to enter Meta-&."
3773 (vector (event-apply-modifier (read-event) 'meta 27 "M-")))
3774
3775 (defun event-apply-modifier (event symbol lshiftby prefix)
3776 "Apply a modifier flag to event EVENT.
3777 SYMBOL is the name of this modifier, as a symbol.
3778 LSHIFTBY is the numeric value of this modifier, in keyboard events.
3779 PREFIX is the string that represents this modifier in an event type symbol."
3780 (if (numberp event)
3781 (cond ((eq symbol 'control)
3782 (if (and (<= (downcase event) ?z)
3783 (>= (downcase event) ?a))
3784 (- (downcase event) ?a -1)
3785 (if (and (<= (downcase event) ?Z)
3786 (>= (downcase event) ?A))
3787 (- (downcase event) ?A -1)
3788 (logior (lsh 1 lshiftby) event))))
3789 ((eq symbol 'shift)
3790 (if (and (<= (downcase event) ?z)
3791 (>= (downcase event) ?a))
3792 (upcase event)
3793 (logior (lsh 1 lshiftby) event)))
3794 (t
3795 (logior (lsh 1 lshiftby) event)))
3796 (if (memq symbol (event-modifiers event))
3797 event
3798 (let ((event-type (if (symbolp event) event (car event))))
3799 (setq event-type (intern (concat prefix (symbol-name event-type))))
3800 (if (symbolp event)
3801 event-type
3802 (cons event-type (cdr event)))))))
3803
3804 (define-key function-key-map [?\C-x ?@ ?h] 'event-apply-hyper-modifier)
3805 (define-key function-key-map [?\C-x ?@ ?s] 'event-apply-super-modifier)
3806 (define-key function-key-map [?\C-x ?@ ?m] 'event-apply-meta-modifier)
3807 (define-key function-key-map [?\C-x ?@ ?a] 'event-apply-alt-modifier)
3808 (define-key function-key-map [?\C-x ?@ ?S] 'event-apply-shift-modifier)
3809 (define-key function-key-map [?\C-x ?@ ?c] 'event-apply-control-modifier)
3810
3811 ;;;; Keypad support.
3812
3813 ;;; Make the keypad keys act like ordinary typing keys. If people add
3814 ;;; bindings for the function key symbols, then those bindings will
3815 ;;; override these, so this shouldn't interfere with any existing
3816 ;;; bindings.
3817
3818 ;; Also tell read-char how to handle these keys.
3819 (mapcar
3820 (lambda (keypad-normal)
3821 (let ((keypad (nth 0 keypad-normal))
3822 (normal (nth 1 keypad-normal)))
3823 (put keypad 'ascii-character normal)
3824 (define-key function-key-map (vector keypad) (vector normal))))
3825 '((kp-0 ?0) (kp-1 ?1) (kp-2 ?2) (kp-3 ?3) (kp-4 ?4)
3826 (kp-5 ?5) (kp-6 ?6) (kp-7 ?7) (kp-8 ?8) (kp-9 ?9)
3827 (kp-space ?\ )
3828 (kp-tab ?\t)
3829 (kp-enter ?\r)
3830 (kp-multiply ?*)
3831 (kp-add ?+)
3832 (kp-separator ?,)
3833 (kp-subtract ?-)
3834 (kp-decimal ?.)
3835 (kp-divide ?/)
3836 (kp-equal ?=)))
3837
3838 ;;;;
3839 ;;;; forking a twin copy of a buffer.
3840 ;;;;
3841
3842 (defvar clone-buffer-hook nil
3843 "Normal hook to run in the new buffer at the end of `clone-buffer'.")
3844
3845 (defun clone-process (process &optional newname)
3846 "Create a twin copy of PROCESS.
3847 If NEWNAME is nil, it defaults to PROCESS' name;
3848 NEWNAME is modified by adding or incrementing <N> at the end as necessary.
3849 If PROCESS is associated with a buffer, the new process will be associated
3850 with the current buffer instead.
3851 Returns nil if PROCESS has already terminated."
3852 (setq newname (or newname (process-name process)))
3853 (if (string-match "<[0-9]+>\\'" newname)
3854 (setq newname (substring newname 0 (match-beginning 0))))
3855 (when (memq (process-status process) '(run stop open))
3856 (let* ((process-connection-type (process-tty-name process))
3857 (old-kwoq (process-kill-without-query process nil))
3858 (new-process
3859 (if (memq (process-status process) '(open))
3860 (apply 'open-network-stream newname
3861 (if (process-buffer process) (current-buffer))
3862 (process-contact process))
3863 (apply 'start-process newname
3864 (if (process-buffer process) (current-buffer))
3865 (process-command process)))))
3866 (process-kill-without-query new-process old-kwoq)
3867 (process-kill-without-query process old-kwoq)
3868 (set-process-inherit-coding-system-flag
3869 new-process (process-inherit-coding-system-flag process))
3870 (set-process-filter new-process (process-filter process))
3871 (set-process-sentinel new-process (process-sentinel process))
3872 new-process)))
3873
3874 ;; things to maybe add (currently partly covered by `funcall mode':
3875 ;; - syntax-table
3876 ;; - overlays
3877 (defun clone-buffer (&optional newname display-flag)
3878 "Create a twin copy of the current buffer.
3879 If NEWNAME is nil, it defaults to the current buffer's name;
3880 NEWNAME is modified by adding or incrementing <N> at the end as necessary.
3881
3882 If DISPLAY-FLAG is non-nil, the new buffer is shown with `pop-to-buffer'.
3883 This runs the normal hook `clone-buffer-hook' in the new buffer
3884 after it has been set up properly in other respects."
3885 (interactive (list (if current-prefix-arg (read-string "Name: "))
3886 t))
3887 (if buffer-file-name
3888 (error "Cannot clone a file-visiting buffer"))
3889 (if (get major-mode 'no-clone)
3890 (error "Cannot clone a buffer in %s mode" mode-name))
3891 (setq newname (or newname (buffer-name)))
3892 (if (string-match "<[0-9]+>\\'" newname)
3893 (setq newname (substring newname 0 (match-beginning 0))))
3894 (let ((buf (current-buffer))
3895 (ptmin (point-min))
3896 (ptmax (point-max))
3897 (pt (point))
3898 (mk (if mark-active (mark t)))
3899 (modified (buffer-modified-p))
3900 (mode major-mode)
3901 (lvars (buffer-local-variables))
3902 (process (get-buffer-process (current-buffer)))
3903 (new (generate-new-buffer (or newname (buffer-name)))))
3904 (save-restriction
3905 (widen)
3906 (with-current-buffer new
3907 (insert-buffer-substring buf)))
3908 (with-current-buffer new
3909 (narrow-to-region ptmin ptmax)
3910 (goto-char pt)
3911 (if mk (set-mark mk))
3912 (set-buffer-modified-p modified)
3913
3914 ;; Clone the old buffer's process, if any.
3915 (when process (clone-process process))
3916
3917 ;; Now set up the major mode.
3918 (funcall mode)
3919
3920 ;; Set up other local variables.
3921 (mapcar (lambda (v)
3922 (condition-case () ;in case var is read-only
3923 (if (symbolp v)
3924 (makunbound v)
3925 (set (make-local-variable (car v)) (cdr v)))
3926 (error nil)))
3927 lvars)
3928
3929 ;; Run any hooks (typically set up by the major mode
3930 ;; for cloning to work properly).
3931 (run-hooks 'clone-buffer-hook))
3932 (if display-flag (pop-to-buffer new))
3933 new))
3934
3935
3936 (defun clone-indirect-buffer (newname display-flag &optional norecord)
3937 "Create an indirect buffer that is a twin copy of the current buffer.
3938
3939 Give the indirect buffer name NEWNAME. Interactively, read NEW-NAME
3940 from the minibuffer when invoked with a prefix arg. If NEWNAME is nil
3941 or if not called with a prefix arg, NEWNAME defaults to the current
3942 buffer's name. The name is modified by adding a `<N>' suffix to it
3943 or by incrementing the N in an existing suffix.
3944
3945 DISPLAY-FLAG non-nil means show the new buffer with `pop-to-buffer'.
3946 This is always done when called interactively.
3947
3948 Optional last arg NORECORD non-nil means do not put this buffer at the
3949 front of the list of recently selected ones."
3950 (interactive (list (if current-prefix-arg
3951 (read-string "BName of indirect buffer: "))
3952 t))
3953 (setq newname (or newname (buffer-name)))
3954 (if (string-match "<[0-9]+>\\'" newname)
3955 (setq newname (substring newname 0 (match-beginning 0))))
3956 (let* ((name (generate-new-buffer-name newname))
3957 (buffer (make-indirect-buffer (current-buffer) name t)))
3958 (when display-flag
3959 (pop-to-buffer buffer norecord))
3960 buffer))
3961
3962
3963 (defun clone-indirect-buffer-other-window (buffer &optional norecord)
3964 "Create an indirect buffer that is a twin copy of BUFFER.
3965 Select the new buffer in another window.
3966 Optional second arg NORECORD non-nil means do not put this buffer at
3967 the front of the list of recently selected ones."
3968 (interactive "bClone buffer in other window: ")
3969 (let ((popup-windows t))
3970 (set-buffer buffer)
3971 (clone-indirect-buffer nil t norecord)))
3972
3973 (define-key ctl-x-4-map "c" 'clone-indirect-buffer-other-window)
3974
3975
3976 ;;; Syntax stuff.
3977
3978 (defconst syntax-code-table
3979 '((?\ 0 "whitespace")
3980 (?- 0 "whitespace")
3981 (?. 1 "punctuation")
3982 (?w 2 "word")
3983 (?_ 3 "symbol")
3984 (?\( 4 "open parenthesis")
3985 (?\) 5 "close parenthesis")
3986 (?\' 6 "expression prefix")
3987 (?\" 7 "string quote")
3988 (?$ 8 "paired delimiter")
3989 (?\\ 9 "escape")
3990 (?/ 10 "character quote")
3991 (?< 11 "comment start")
3992 (?> 12 "comment end")
3993 (?@ 13 "inherit")
3994 (nil 14 "comment fence")
3995 (nil 15 "string fence"))
3996 "Alist of forms (CHAR CODE DESCRIPTION) mapping characters to syntax info.
3997 CHAR is a character that is allowed as first char in the string
3998 specifying the syntax when calling `modify-syntax-entry'. CODE is the
3999 corresponing syntax code as it is stored in a syntax cell, and
4000 can be used as value of a `syntax-table' property.
4001 DESCRIPTION is the descriptive string for the syntax.")
4002
4003
4004 ;;; Misc
4005
4006 (defun byte-compiling-files-p ()
4007 "Return t if currently byte-compiling files."
4008 (and (boundp 'byte-compile-current-file)
4009 (stringp byte-compile-current-file)))
4010
4011 ;;; simple.el ends here