;;; simple.el --- basic editing commands for Emacs
-;; Copyright (C) 1985, 86, 87, 93, 94, 95, 96, 97, 98, 99, 2000, 2001
+;; Copyright (C) 1985, 86, 87, 93, 94, 95, 96, 97, 98, 99,
+;; 2000, 2001, 2002, 2003
;; Free Software Foundation, Inc.
+;; Maintainer: FSF
+;; Keywords: internal
+
;; This file is part of GNU Emacs.
;; GNU Emacs is free software; you can redistribute it and/or modify
(eval-when-compile
(autoload 'widget-convert "wid-edit")
- (autoload 'shell-mode "shell")
- (require 'cl))
+ (autoload 'shell-mode "shell"))
(defgroup killing nil
"Highlight (un)matching of parens and expressions."
:group 'matching)
+(define-key global-map [?\C-x right] 'next-buffer)
+(define-key global-map [?\C-x left] 'prev-buffer)
+(defun next-buffer ()
+ "Switch to the next buffer in cyclic order."
+ (interactive)
+ (let ((buffer (current-buffer)))
+ (switch-to-buffer (other-buffer buffer))
+ (bury-buffer buffer)))
+
+(defun prev-buffer ()
+ "Switch to the previous buffer in cyclic order."
+ (interactive)
+ (let ((list (nreverse (buffer-list)))
+ found)
+ (while (and (not found) list)
+ (let ((buffer (car list)))
+ (if (and (not (get-buffer-window buffer))
+ (not (string-match "\\` " (buffer-name buffer))))
+ (setq found buffer)))
+ (setq list (cdr list)))
+ (switch-to-buffer found)))
(defun fundamental-mode ()
"Major mode not specialized for anything in particular.
(goto-char loc)
(end-of-line)))
-(defun split-line ()
- "Split current line, moving portion beyond point vertically down."
- (interactive "*")
+(defun split-line (&optional arg)
+ "Split current line, moving portion beyond point vertically down.
+If the current line starts with `fill-prefix', insert it on the new
+line as well. With prefix arg, don't insert fill-prefix on new line.
+
+When called from Lisp code, the arg may be a prefix string to copy."
+ (interactive "*P")
(skip-chars-forward " \t")
- (let ((col (current-column))
- (pos (point)))
+ (let* ((col (current-column))
+ (pos (point))
+ ;; What prefix should we check for (nil means don't).
+ (prefix (cond ((stringp arg) arg)
+ (arg nil)
+ (t fill-prefix)))
+ ;; Does this line start with it?
+ (have-prfx (and prefix
+ (save-excursion
+ (beginning-of-line)
+ (looking-at (regexp-quote prefix))))))
(newline 1)
+ (if have-prfx (insert-and-inherit prefix))
(indent-to col 0)
(goto-char pos)))
digits are interpreted as a character code. This is intended to be
useful for editing binary files."
(interactive "*p")
- (let ((char (if (or (not overwrite-mode)
- (eq overwrite-mode 'overwrite-mode-binary))
- (read-quoted-char)
- (read-char))))
+ (let* ((char (let (translation-table-for-input)
+ (if (or (not overwrite-mode)
+ (eq overwrite-mode 'overwrite-mode-binary))
+ (read-quoted-char)
+ (read-char)))))
;; Assume character codes 0240 - 0377 stand for characters in some
;; single-byte character set, and convert them to Emacs
;; characters.
(progn
(skip-chars-forward " \t")
(constrain-to-field nil orig-pos t)))))
-
+\f
(defun beginning-of-buffer (&optional arg)
"Move point to the beginning of the buffer; leave mark at previous position.
With arg N, put point N/10 of the way from the beginning.
(push-mark (point))
(push-mark (point-max) nil t)
(goto-char (point-min)))
-
+\f
;; Counting lines, one way or another.
(setq start (point))
(goto-char opoint)
(forward-line 0)
- (if (/= start 1)
+ (if (/= start (point-min))
(message "line %d (narrowed line %d)"
- (1+ (count-lines 1 (point)))
+ (1+ (count-lines (point-min) (point)))
(1+ (count-lines start (point))))
- (message "Line %d" (1+ (count-lines 1 (point)))))))))
+ (message "Line %d" (1+ (count-lines (point-min) (point)))))))))
(defun count-lines (start end)
"Return number of lines between START and END.
byte, just \"...\" is shown.
In addition, with prefix argument, show details about that character
-in *Help* buffer. See also the command `describe-char-after'."
+in *Help* buffer. See also the command `describe-char'."
(interactive "P")
(let* ((char (following-char))
(beg (point-min))
(format "(0%o, %d, 0x%x)" char char char))))
(if detail
;; We show the detailed information about CHAR.
- (describe-char-after (point)))
+ (describe-char (point)))
(if (or (/= beg 1) (/= end (1+ total)))
(message "Char: %s %s point=%d of %d (%d%%) <%d - %d> column %d %s"
(if (< char 256)
(single-key-description char)
(buffer-substring-no-properties (point) (1+ (point))))
encoding-msg pos total percent col hscroll))))))
-
+\f
(defvar read-expression-map
(let ((m (make-sparse-keymap)))
(define-key m "\M-\t" 'lisp-complete-symbol)
"Prompting with PROMPT, let user edit COMMAND and eval result.
COMMAND is a Lisp expression. Let user edit that expression in
the minibuffer, then read and evaluate the result."
- (let ((command (read-from-minibuffer prompt
- (prin1-to-string command)
- read-expression-map t
- '(command-history . 1))))
- ;; If command was added to command-history as a string,
- ;; get rid of that. We want only evaluable expressions there.
- (if (stringp (car command-history))
- (setq command-history (cdr command-history)))
+ (let ((command
+ (unwind-protect
+ (read-from-minibuffer prompt
+ (prin1-to-string command)
+ read-expression-map t
+ '(command-history . 1))
+ ;; If command was added to command-history as a string,
+ ;; get rid of that. We want only evaluable expressions there.
+ (if (stringp (car command-history))
+ (setq command-history (cdr command-history))))))
;; If command to be redone does not match front of history,
;; add it to the history.
(let ((print-level nil)
(minibuffer-history-position arg)
(minibuffer-history-sexp-flag (1+ (minibuffer-depth))))
- (read-from-minibuffer
- "Redo: " (prin1-to-string elt) read-expression-map t
- (cons 'command-history arg))))
+ (unwind-protect
+ (read-from-minibuffer
+ "Redo: " (prin1-to-string elt) read-expression-map t
+ (cons 'command-history arg))
- ;; If command was added to command-history as a string,
- ;; get rid of that. We want only evaluable expressions there.
- (if (stringp (car command-history))
- (setq command-history (cdr command-history)))
+ ;; If command was added to command-history as a
+ ;; string, get rid of that. We want only
+ ;; evaluable expressions there.
+ (if (stringp (car command-history))
+ (setq command-history (cdr command-history))))))
;; If command to be redone does not match front of history,
;; add it to the history.
(or (equal newcmd (car command-history))
(setq command-history (cons newcmd command-history)))
(eval newcmd))
- (ding))))
-
+ (if command-history
+ (error "Argument %d is beyond length of command history" arg)
+ (error "There are no previous complex commands to repeat")))))
+\f
(defvar minibuffer-history nil
"Default minibuffer history list.
This is used for all minibuffer input
;; Return the width of everything before the field at the end of
;; the buffer; this should be 0 for normal buffers.
(1- (minibuffer-prompt-end)))
-
+\f
;Put this on C-x u, so we can force that rather than C-_ into startup msg
(defalias 'advertised-undo 'undo)
(let ((modified (buffer-modified-p))
(recent-save (recent-auto-save-p)))
(or (eq (selected-window) (minibuffer-window))
- (message "Undo!"))
+ (message (if (and transient-mark-mode mark-active)
+ "Undo in region!"
+ "Undo!")))
(unless (eq last-command 'undo)
(if (if transient-mark-mode mark-active (and arg (not (numberp arg))))
(undo-start (region-beginning) (region-end))
Call `undo-start' to get ready to undo recent changes,
then call `undo-more' one or more times to undo them."
(or pending-undo-list
- (error "No further undo information"))
+ (error (format "No further undo information%s"
+ (if (and transient-mark-mode mark-active)
+ " for region" ""))))
(let ((undo-in-progress t))
(setq pending-undo-list (primitive-undo count pending-undo-list))))
If it crosses the edge, we return nil."
(cond ((integerp undo-elt)
(and (>= undo-elt start)
- (< undo-elt end)))
+ (<= undo-elt end)))
((eq undo-elt nil)
t)
((atom undo-elt)
(cons alist-elt undo-adjusted-markers)))
(and (cdr alist-elt)
(>= (cdr alist-elt) start)
- (< (cdr alist-elt) end))))
+ (<= (cdr alist-elt) end))))
((null (car undo-elt))
;; (nil PROPERTY VALUE BEG . END)
(let ((tail (nthcdr 3 undo-elt)))
(and (>= (car tail) start)
- (< (cdr tail) end))))
+ (<= (cdr tail) end))))
((integerp (car undo-elt))
;; (BEGIN . END)
(and (>= (car undo-elt) start)
- (< (cdr undo-elt) end)))))
+ (<= (cdr undo-elt) end)))))
(defun undo-elt-crosses-region (undo-elt start end)
"Test whether UNDO-ELT crosses one edge of that region START ... END.
(t
'(0 . 0)))
'(0 . 0)))
-
-(defun undo-get-state ()
- "Return a handler for the current state to which we might want to undo.
-The returned handler can then be passed to `undo-revert-to-handle'."
- (unless (eq buffer-undo-list t)
- buffer-undo-list))
-
-(defun undo-revert-to-state (handle)
- "Revert to the state HANDLE earlier grabbed with `undo-get-handle'.
-This undoing is not itself undoable (aka redoable)."
- (unless (eq buffer-undo-list t)
- (let ((new-undo-list (cons (car handle) (cdr handle))))
- ;; Truncate the undo log at `handle'.
- (when handle
- (setcar handle nil) (setcdr handle nil))
- (unless (eq last-command 'undo) (undo-start))
- ;; Make sure there's no confusion.
- (when (and handle (not (eq handle (last pending-undo-list))))
- (error "Undoing to some unrelated state"))
- ;; Undo it all.
- (while pending-undo-list (undo-more 1))
- ;; Reset the modified cons cell to its original content.
- (when handle
- (setcar handle (car new-undo-list))
- (setcdr handle (cdr new-undo-list)))
- ;; Revert the undo info to what it was when we grabbed the state.
- (setq buffer-undo-list handle))))
-
\f
(defvar shell-command-history nil
"History list for some commands that read shell commands.")
(defvar shell-command-default-error-buffer nil
"*Buffer name for `shell-command' and `shell-command-on-region' error output.
-This buffer is used when `shell-command' or 'shell-command-on-region'
+This buffer is used when `shell-command' or `shell-command-on-region'
is run interactively. A value of nil means that output to stderr and
stdout will be intermixed in the output stream.")
;; Output goes in a separate buffer.
;; Preserve the match data in case called from a program.
(save-match-data
- (if (string-match "[ \t]*&[ \t]*$" command)
+ (if (string-match "[ \t]*&[ \t]*\\'" command)
;; Command ending with ampersand means asynchronous.
(let ((buffer (get-buffer-create
(or output-buffer "*Async Shell Command*")))
(if (= (buffer-size) 0)
0
(count-lines (point-min) (point-max)))))
- (cond ((or (<= lines 1)
- (<= lines
- (if resize-mini-windows
- (cond ((floatp max-mini-window-height)
- (* (frame-height)
- max-mini-window-height))
- ((integerp max-mini-window-height)
- max-mini-window-height)
- (t
- 1))
- 1)))
+ (cond ((= lines 0))
+ ((and (or (<= lines 1)
+ (<= lines
+ (if resize-mini-windows
+ (cond ((floatp max-mini-window-height)
+ (* (frame-height)
+ max-mini-window-height))
+ ((integerp max-mini-window-height)
+ max-mini-window-height)
+ (t
+ 1))
+ 1)))
+ ;; Don't use the echo area if the output buffer is
+ ;; already dispayed in the selected frame.
+ (not (get-buffer-window (current-buffer))))
;; Echo area
(goto-char (point-max))
(when (bolp)
If it is nil, error output is mingled with regular output.
In an interactive call, the variable `shell-command-default-error-buffer'
specifies the value of ERROR-BUFFER."
- (interactive (let ((string
- ;; Do this before calling region-beginning
- ;; and region-end, in case subprocess output
- ;; relocates them while we are in the minibuffer.
- (read-from-minibuffer "Shell command on region: "
- nil nil nil
- 'shell-command-history)))
+ (interactive (let (string)
+ (unless (mark)
+ (error "The mark is not set now, so there is no region"))
+ ;; Do this before calling region-beginning
+ ;; and region-end, in case subprocess output
+ ;; relocates them while we are in the minibuffer.
+ (setq string (read-from-minibuffer "Shell command on region: "
+ nil nil nil
+ 'shell-command-history))
;; call-interactively recognizes region-beginning and
;; region-end specially, leaving them in the history.
(list (region-beginning) (region-end)
(let ((swap (and replace (< start end))))
;; Don't muck with mark unless REPLACE says we should.
(goto-char start)
- (and replace (push-mark))
+ (and replace (push-mark (point) 'nomsg))
(setq exit-status
(call-process-region start end shell-file-name t
(if error-file
;; No prefix argument: put the output in a temp buffer,
;; replacing its entire contents.
(let ((buffer (get-buffer-create
- (or output-buffer "*Shell Command Output*")))
- (success nil))
+ (or output-buffer "*Shell Command Output*"))))
(unwind-protect
(if (eq buffer (current-buffer))
;; If the input is the same buffer as the output,
(list buffer error-file)
buffer)
nil shell-command-switch command)))
- (setq success (and exit-status (equal 0 exit-status)))
;; Report the output.
+ (with-current-buffer buffer
+ (setq mode-line-process
+ (cond ((null exit-status)
+ " - Error")
+ ((stringp exit-status)
+ (format " - Signal [%s]" exit-status))
+ ((not (equal 0 exit-status))
+ (format " - Exit [%d]" exit-status)))))
(if (with-current-buffer buffer (> (point-max) (point-min)))
;; There's some output, display it
- (progn
- (if (not success)
- (with-current-buffer buffer
- (save-excursion
- (goto-char (point-max))
- (insert "...Shell command failed"))))
- (display-message-or-buffer buffer))
+ (display-message-or-buffer buffer)
;; No output; error?
- (message (if (and error-file
- (< 0 (nth 7 (file-attributes error-file))))
- "(Shell command %sed with some error output)"
- "(Shell command %sed with no output)")
- (if (equal 0 exit-status) "succeed" "fail"))
+ (let ((output
+ (if (and error-file
+ (< 0 (nth 7 (file-attributes error-file))))
+ "some error output"
+ "no output")))
+ (cond ((null exit-status)
+ (message "(Shell command failed with error)"))
+ ((equal 0 exit-status)
+ (message "(Shell command succeeded with %s)"
+ output))
+ ((stringp exit-status)
+ (message "(Shell command killed by signal %s)"
+ exit-status))
+ (t
+ (message "(Shell command failed with code %d and %s)"
+ exit-status output))))
;; Don't kill: there might be useful info in the undo-log.
;; (kill-buffer buffer)
))))
(with-current-buffer
standard-output
(call-process shell-file-name nil t nil shell-command-switch command))))
-
+\f
(defvar universal-argument-map
(let ((map (make-sparse-keymap)))
(define-key map [t] 'universal-argument-other-key)
unread-command-events)))
(reset-this-command-lengths)
(setq overriding-terminal-local-map nil))
-
+\f
;;;; Window system cut and paste hooks.
(defvar interprogram-cut-function nil
difficult to tell whether Emacs or some other program provided the
current string, it is probably good enough to return nil if the string
is equal (according to `string=') to the last text Emacs provided.")
-
+\f
;;;; The kill ring data structure.
(defun kill-new (string &optional replace)
"Make STRING the latest kill in the kill ring.
-Set the kill-ring-yank pointer to point to it.
+Set `kill-ring-yank-pointer' to point to it.
If `interprogram-cut-function' is non-nil, apply it to STRING.
Optional second argument REPLACE non-nil means that STRING will replace
the front of the kill ring, rather than being added to the list."
it."
(kill-new (if before-p
(concat string (car kill-ring))
- (concat (car kill-ring) string)) t))
+ (concat (car kill-ring) string))
+ t))
(defun current-kill (n &optional do-not-move)
"Rotate the yanking point by N places, and then return that kill.
(setq this-command 'kill-region)
(message "If the next command is a kill, it will append"))
(setq last-command 'kill-region)))
-
+\f
;; Yanking.
+;; This is actually used in subr.el but defcustom does not work there.
+(defcustom yank-excluded-properties
+ '(read-only invisible intangible field mouse-face help-echo local-map keymap)
+ "*Text properties to discard when yanking."
+ :type '(choice (const :tag "All" t) (repeat symbol))
+ :group 'editing
+ :version "21.4")
+
+(defvar yank-window-start nil)
+
(defun yank-pop (arg)
"Replace just-yanked stretch of killed text with a different stretch.
This command is allowed only immediately after a `yank' or a `yank-pop'.
(before (< (point) (mark t))))
(delete-region (point) (mark t))
(set-marker (mark-marker) (point) (current-buffer))
- (let ((opoint (point)))
- (insert (current-kill arg))
- (let ((inhibit-read-only t))
- (remove-text-properties opoint (point) '(read-only nil))))
+ (insert-for-yank (current-kill arg))
+ ;; Set the window start back where it was in the yank command,
+ ;; if possible.
+ (set-window-start (selected-window) yank-window-start t)
(if before
;; This is like exchange-point-and-mark, but doesn't activate the mark.
;; It is cleaner to avoid activation, even though the command
"Reinsert the last stretch of killed text.
More precisely, reinsert the stretch of killed text most recently
killed OR yanked. Put point at end, and set mark at beginning.
-With just C-u as argument, same but put point at beginning (and mark at end).
+With just \\[universal-argument] as argument, same but put point at beginning (and mark at end).
With argument N, reinsert the Nth most recently killed stretch of killed
text.
See also the command \\[yank-pop]."
(interactive "*P")
+ (setq yank-window-start (window-start))
;; If we don't get all the way thru, make last-command indicate that
;; for the following command.
(setq this-command t)
(push-mark (point))
- (let ((opoint (point)))
- (insert (current-kill (cond
- ((listp arg) 0)
- ((eq arg '-) -1)
- (t (1- arg)))))
- (let ((inhibit-read-only t))
- (remove-text-properties opoint (point) '(read-only nil))))
+ (insert-for-yank (current-kill (cond
+ ((listp arg) 0)
+ ((eq arg '-) -1)
+ (t (1- arg)))))
(if (consp arg)
;; This is like exchange-point-and-mark, but doesn't activate the mark.
;; It is cleaner to avoid activation, even though the command
With argument, rotate that many kills forward (or backward, if negative)."
(interactive "p")
(current-kill arg))
-
+\f
;; Some kill commands.
;; Internal subroutine of delete-char
(forward-visible-line (prefix-numeric-value arg))
(if (eobp)
(signal 'end-of-buffer nil))
- (if (or (looking-at "[ \t]*$") (and kill-whole-line (bolp)))
- (forward-visible-line 1)
- (end-of-visible-line)))
+ (let ((end
+ (save-excursion
+ (end-of-visible-line) (point))))
+ (if (or (save-excursion
+ (skip-chars-forward " \t" end)
+ (= (point) end))
+ (and kill-whole-line (bolp)))
+ (forward-visible-line 1)
+ (goto-char end))))
(point))))
+
(defun forward-visible-line (arg)
"Move forward by ARG lines, ignoring currently invisible newlines only.
If ARG is negative, move backward -ARG lines.
If ARG is zero, move to the beginning of the current line."
(condition-case nil
(if (> arg 0)
- (while (> arg 0)
- (or (zerop (forward-line 1))
- (signal 'end-of-buffer nil))
- ;; If the following character is currently invisible,
- ;; skip all characters with that same `invisible' property value,
- ;; then find the next newline.
- (while (and (not (eobp))
- (let ((prop
- (get-char-property (point) 'invisible)))
- (if (eq buffer-invisibility-spec t)
- prop
- (or (memq prop buffer-invisibility-spec)
- (assq prop buffer-invisibility-spec)))))
- (goto-char
- (if (get-text-property (point) 'invisible)
- (or (next-single-property-change (point) 'invisible)
- (point-max))
- (next-overlay-change (point))))
+ (progn
+ (while (> arg 0)
(or (zerop (forward-line 1))
- (signal 'end-of-buffer nil)))
- (setq arg (1- arg)))
+ (signal 'end-of-buffer nil))
+ ;; If the newline we just skipped is invisible,
+ ;; don't count it.
+ (let ((prop
+ (get-char-property (1- (point)) 'invisible)))
+ (if (if (eq buffer-invisibility-spec t)
+ prop
+ (or (memq prop buffer-invisibility-spec)
+ (assq prop buffer-invisibility-spec)))
+ (setq arg (1+ arg))))
+ (setq arg (1- arg)))
+ ;; If invisible text follows, and it is a number of complete lines,
+ ;; skip it.
+ (let ((opoint (point)))
+ (while (and (not (eobp))
+ (let ((prop
+ (get-char-property (point) 'invisible)))
+ (if (eq buffer-invisibility-spec t)
+ prop
+ (or (memq prop buffer-invisibility-spec)
+ (assq prop buffer-invisibility-spec)))))
+ (goto-char
+ (if (get-text-property (point) 'invisible)
+ (or (next-single-property-change (point) 'invisible)
+ (point-max))
+ (next-overlay-change (point)))))
+ (unless (bolp)
+ (goto-char opoint))))
(let ((first t))
(while (or first (< arg 0))
(if (zerop arg)
(beginning-of-line)
(or (zerop (forward-line -1))
(signal 'beginning-of-buffer nil)))
+ ;; If the newline we just moved to is invisible,
+ ;; don't count it.
+ (unless (bobp)
+ (let ((prop
+ (get-char-property (1- (point)) 'invisible)))
+ (if (if (eq buffer-invisibility-spec t)
+ prop
+ (or (memq prop buffer-invisibility-spec)
+ (assq prop buffer-invisibility-spec)))
+ (setq arg (1+ arg)))))
+ (setq first nil)
+ (setq arg (1+ arg)))
+ ;; If invisible text follows, and it is a number of complete lines,
+ ;; skip it.
+ (let ((opoint (point)))
(while (and (not (bobp))
(let ((prop
(get-char-property (1- (point)) 'invisible)))
(if (get-text-property (1- (point)) 'invisible)
(or (previous-single-property-change (point) 'invisible)
(point-min))
- (previous-overlay-change (point))))
- (or (zerop (forward-line -1))
- (signal 'beginning-of-buffer nil)))
- (setq first nil)
- (setq arg (1+ arg)))))
+ (previous-overlay-change (point)))))
+ (unless (bolp)
+ (goto-char opoint)))))
((beginning-of-buffer end-of-buffer)
nil)))
;; skip all characters with that same `invisible' property value,
;; then find the next newline.
(while (and (not (eobp))
- (let ((prop
- (get-char-property (point) 'invisible)))
- (if (eq buffer-invisibility-spec t)
- prop
- (or (memq prop buffer-invisibility-spec)
- (assq prop buffer-invisibility-spec)))))
+ (save-excursion
+ (skip-chars-forward "^\n")
+ (let ((prop
+ (get-char-property (point) 'invisible)))
+ (if (eq buffer-invisibility-spec t)
+ prop
+ (or (memq prop buffer-invisibility-spec)
+ (assq prop buffer-invisibility-spec))))))
+ (skip-chars-forward "^\n")
(if (get-text-property (point) 'invisible)
(goto-char (next-single-property-change (point) 'invisible))
(goto-char (next-overlay-change (point))))
(end-of-line)))
-
+\f
(defun insert-buffer (buffer)
"Insert after point the contents of BUFFER.
Puts mark after the inserted text.
(erase-buffer)
(save-excursion
(insert-buffer-substring oldbuf start end)))))
-
+\f
(put 'mark-inactive 'error-conditions '(mark-inactive error))
(put 'mark-inactive 'error-message "The mark is not active now")
"Deactivate the mark by setting `mark-active' to nil.
\(That makes a difference only in Transient Mark mode.)
Also runs the hook `deactivate-mark-hook'."
- (if transient-mark-mode
- (progn
- (setq mark-active nil)
- (run-hooks 'deactivate-mark-hook))))
+ (cond
+ ((eq transient-mark-mode 'lambda)
+ (setq transient-mark-mode nil))
+ (transient-mark-mode
+ (setq mark-active nil)
+ (run-hooks 'deactivate-mark-hook))))
(defun set-mark (pos)
"Set this buffer's mark to POS. Don't use this function!
:type 'integer
:group 'editing-basics)
+(defun pop-to-mark-command ()
+ "Jump to mark, and pop a new position for mark off the ring
+\(does not affect global mark ring\)."
+ (interactive)
+ (if (null (mark t))
+ (error "No mark set in this buffer")
+ (goto-char (mark t))
+ (pop-mark)))
+
+(defun push-mark-command (arg &optional nomsg)
+ "Set mark at where point is.
+If no prefix arg and mark is already set there, just activate it.
+Display `Mark set' unless the optional second arg NOMSG is non-nil."
+ (interactive "P")
+ (let ((mark (marker-position (mark-marker))))
+ (if (or arg (null mark) (/= mark (point)))
+ (push-mark nil nomsg t)
+ (setq mark-active t)
+ (unless nomsg
+ (message "Mark activated")))))
+
(defun set-mark-command (arg)
"Set mark at where point is, or jump to mark.
With no prefix argument, set mark, push old mark position on local mark
-ring, and push mark on global mark ring.
+ring, and push mark on global mark ring. Immediately repeating the
+command activates `transient-mark-mode' temporarily.
+
With argument, jump to mark, and pop a new position for mark off the ring
-\(does not affect global mark ring\).
+\(does not affect global mark ring\). Repeating the command without
+an argument jumps to the next position off the mark ring.
Novice Emacs Lisp programmers often try to use the mark for the wrong
purposes. See the documentation of `set-mark' for more information."
(interactive "P")
- (if (null arg)
- (progn
- (push-mark nil nil t))
- (if (null (mark t))
- (error "No mark set in this buffer")
- (goto-char (mark t))
- (pop-mark))))
+ (if (eq transient-mark-mode 'lambda)
+ (setq transient-mark-mode nil))
+ (cond
+ ((not (eq this-command 'set-mark-command))
+ (if arg
+ (pop-to-mark-command)
+ (push-mark-command t)))
+ ((eq last-command 'pop-to-mark-command)
+ (if (and (consp arg) (> (prefix-numeric-value arg) 4))
+ (push-mark-command nil)
+ (setq this-command 'pop-to-mark-command)
+ (pop-to-mark-command)))
+ (arg
+ (setq this-command 'pop-to-mark-command)
+ (pop-to-mark-command))
+ ((and (eq last-command 'set-mark-command)
+ mark-active (null transient-mark-mode))
+ (setq transient-mark-mode 'lambda)
+ (message "Transient-mark-mode temporarily enabled"))
+ (t
+ (push-mark-command nil))))
(defun push-mark (&optional location nomsg activate)
"Set mark at LOCATION (point, by default) and push old mark on mark ring.
(setq mark-ring (cdr mark-ring)))))
(defalias 'exchange-dot-and-mark 'exchange-point-and-mark)
-(defun exchange-point-and-mark ()
+(defun exchange-point-and-mark (&optional arg)
"Put the mark where point is now, and point where the mark is now.
This command works even when the mark is not active,
-and it reactivates the mark."
- (interactive nil)
- (let ((omark (mark t)))
- (if (null omark)
- (error "No mark set in this buffer"))
- (set-mark (point))
- (goto-char omark)
- nil))
-
-(defun transient-mark-mode (arg)
+and it reactivates the mark.
+With prefix arg, `transient-mark-mode' is enabled temporarily."
+ (interactive "P")
+ (if arg
+ (if mark-active
+ (if (null transient-mark-mode)
+ (setq transient-mark-mode 'lambda))
+ (setq arg nil)))
+ (unless arg
+ (let ((omark (mark t)))
+ (if (null omark)
+ (error "No mark set in this buffer"))
+ (set-mark (point))
+ (goto-char omark)
+ nil)))
+
+(define-minor-mode transient-mark-mode
"Toggle Transient Mark mode.
With arg, turn Transient Mark mode on if arg is positive, off otherwise.
\\[apropos-documentation] and type \"transient\" or \"mark.*active\" at
the prompt, to see the documentation of commands which are sensitive to
the Transient Mark mode."
- (interactive "P")
- (setq transient-mark-mode
- (if (null arg)
- (not transient-mark-mode)
- (> (prefix-numeric-value arg) 0)))
- (if (interactive-p)
- (if transient-mark-mode
- (message "Transient Mark mode enabled")
- (message "Transient Mark mode disabled"))))
+ :global t :group 'editing-basics :require nil)
(defun pop-global-mark ()
"Pop off global mark ring and jump to the top location."
(widen))
(goto-char position)
(switch-to-buffer buffer)))
-
+\f
(defcustom next-line-add-newlines nil
"*If non-nil, `next-line' inserts newline to avoid `end of buffer' error."
:type 'boolean
new line-end line-beg)
(unwind-protect
(progn
- (if (not (or (eq last-command 'next-line)
- (eq last-command 'previous-line)))
+ (if (not (memq last-command '(next-line previous-line)))
(setq temporary-goal-column
(if (and track-eol (eolp)
;; Don't count beg of empty line as end of line
(if (and (not (integerp selective-display))
(not line-move-ignore-invisible))
;; Use just newline characters.
+ ;; Set ARG to 0 if we move as many lines as requested.
(or (if (> arg 0)
(progn (if (> arg 1) (forward-line (1- arg)))
;; This way of moving forward ARG lines
;; verifies that we have a newline after the last one.
;; It doesn't get confused by intangible text.
(end-of-line)
- (zerop (forward-line 1)))
+ (if (zerop (forward-line 1))
+ (setq arg 0)))
(and (zerop (forward-line arg))
- (bolp)))
+ (bolp)
+ (setq arg 0)))
(signal (if (< arg 0)
'beginning-of-buffer
-a 'end-of-buffer)
+ 'end-of-buffer)
nil))
;; Move by arg lines, but ignore invisible ones.
(while (> arg 0)
(while (and (not (bobp)) (line-move-invisible (1- (point))))
(goto-char (previous-char-property-change (point)))))))
- (line-move-finish (or goal-column temporary-goal-column) opoint)))
+ (cond ((> arg 0)
+ ;; If we did not move down as far as desired,
+ ;; at least go to end of line.
+ (end-of-line))
+ ((< arg 0)
+ ;; If we did not move down as far as desired,
+ ;; at least go to end of line.
+ (beginning-of-line))
+ (t
+ (line-move-finish (or goal-column temporary-goal-column) opoint)))))
nil)
(defun line-move-finish (column opoint)
;; Set REPEAT to t to repeat the whole thing.
(setq repeat nil)
- ;; Move to the desired column.
- (line-move-to-column column)
-
- (let ((new (point))
+ (let (new
(line-beg (save-excursion (beginning-of-line) (point)))
- (line-end (save-excursion (end-of-line) (point))))
+ (line-end
+ ;; Compute the end of the line
+ ;; ignoring effectively intangible newlines.
+ (let ((inhibit-point-motion-hooks nil)
+ (inhibit-field-text-motion t))
+ (save-excursion (end-of-line) (point)))))
+
+ ;; Move to the desired column.
+ (line-move-to-column column)
+ (setq new (point))
;; Process intangibility within a line.
;; Move to the chosen destination position from above,
;; If intangibility moves us to a different (later) place
;; in the same line, use that as the destination.
(if (<= (point) line-end)
- (setq new (point))))
+ (setq new (point))
+ ;; If that position is "too late",
+ ;; try the previous allowable position.
+ ;; See if it is ok.
+ (backward-char)
+ (if (<= (point) line-end)
+ (setq new (point))
+ ;; As a last resort, use the end of the line.
+ (setq new line-end))))
;; Now move to the updated destination, processing fields
;; as well as intangibility.
(constrain-to-field new opoint nil t
'inhibit-line-move-field-capture)))
- ;; If intangibility processing moved us to a different line,
+ ;; If all this moved us to a different line,
;; retry everything within that new line.
(when (or (< (point) line-beg) (> (point) line-end))
;; Repeat the intangibility and field processing.
This function works only in certain cases,
because what we really need is for `move-to-column'
and `current-column' to be able to ignore invisible text."
- (move-to-column col)
+ (if (zerop col)
+ (beginning-of-line)
+ (move-to-column col))
(when (and line-move-ignore-invisible
(not (bolp)) (line-move-invisible (1- (point))))
"Goal column %d (use \\[set-goal-column] with an arg to unset it)")
goal-column))
nil)
-
+\f
(defun scroll-other-window-down (lines)
"Scroll the \"other window\" down.
(end-of-buffer arg)
(recenter '(t)))
(select-window orig-window))))
-
+\f
(defun transpose-chars (arg)
"Interchange characters around point, moving forward one character.
With prefix arg ARG, effect is to take character before point
and drag it forward past ARG other words (backward if ARG negative).
If ARG is zero, the words around or after point and around or after mark
are interchanged."
+ ;; FIXME: `foo a!nd bar' should transpose into `bar and foo'.
(interactive "*p")
(transpose-subr 'forward-word arg))
Does not work on a sexp that point is in the middle of
if it is a list or string."
(interactive "*p")
- (transpose-subr 'forward-sexp arg))
+ (transpose-subr
+ (lambda (arg)
+ ;; Here we should try to simulate the behavior of
+ ;; (cons (progn (forward-sexp x) (point))
+ ;; (progn (forward-sexp (- x)) (point)))
+ ;; Except that we don't want to rely on the second forward-sexp
+ ;; putting us back to where we want to be, since forward-sexp-function
+ ;; might do funny things like infix-precedence.
+ (if (if (> arg 0)
+ (looking-at "\\sw\\|\\s_")
+ (and (not (bobp))
+ (save-excursion (forward-char -1) (looking-at "\\sw\\|\\s_"))))
+ ;; Jumping over a symbol. We might be inside it, mind you.
+ (progn (funcall (if (> arg 0)
+ 'skip-syntax-backward 'skip-syntax-forward)
+ "w_")
+ (cons (save-excursion (forward-sexp arg) (point)) (point)))
+ ;; Otherwise, we're between sexps. Take a step back before jumping
+ ;; to make sure we'll obey the same precedence no matter which direction
+ ;; we're going.
+ (funcall (if (> arg 0) 'skip-syntax-backward 'skip-syntax-forward) " .")
+ (cons (save-excursion (forward-sexp arg) (point))
+ (progn (while (or (forward-comment (if (> arg 0) 1 -1))
+ (not (zerop (funcall (if (> arg 0)
+ 'skip-syntax-forward
+ 'skip-syntax-backward)
+ ".")))))
+ (point)))))
+ arg 'special))
(defun transpose-lines (arg)
"Exchange current line and previous line, leaving point after both.
(let ((swap pos1))
(setq pos1 pos2 pos2 swap)))
(if (> (cdr pos1) (car pos2)) (error "Don't have two things to transpose"))
- (let ((word2 (delete-and-extract-region (car pos2) (cdr pos2))))
- (goto-char (car pos2))
- (insert (delete-and-extract-region (car pos1) (cdr pos1)))
- (goto-char (car pos1))
- (insert word2)))
-
+ (atomic-change-group
+ (let (word2)
+ (setq word2 (delete-and-extract-region (car pos2) (cdr pos2)))
+ (goto-char (car pos2))
+ (insert (delete-and-extract-region (car pos1) (cdr pos1)))
+ (goto-char (car pos1))
+ (insert word2))))
+\f
(defun backward-word (arg)
"Move backward until encountering the beginning of a word.
With argument, do this that many times."
(forward-word (- arg)))
(defun mark-word (arg)
- "Set mark arg words away from point."
+ "Set mark arg words away from point.
+If this command is repeated, it marks the next ARG words after the ones
+already marked."
(interactive "p")
- (push-mark
- (save-excursion
- (forward-word arg)
- (point))
- nil t))
+ (cond ((and (eq last-command this-command) (mark t))
+ (set-mark
+ (save-excursion
+ (goto-char (mark))
+ (forward-word arg)
+ (point))))
+ (t
+ (push-mark
+ (save-excursion
+ (forward-word arg)
+ (point))
+ nil t))))
(defun kill-word (arg)
"Kill characters forward until encountering the end of a word.
(setq start (point)))
(buffer-substring-no-properties start end)))
(buffer-substring-no-properties start end)))))
-
+\f
(defcustom fill-prefix nil
"*String for filling to insert at front of new line, or nil for none."
:type '(choice (const :tag "None" nil)
(and prefix (not (equal prefix ""))
;; Use auto-indentation rather than a guessed empty prefix.
(not (and fill-indent-according-to-mode
- (string-match "[ \t]*" prefix)))
+ (string-match "\\`[ \t]*\\'" prefix)))
(setq fill-prefix prefix))))
(while (and (not give-up) (> (current-column) fc))
;; Determine where to split the line.
(let* (after-prefix
(fill-point
- (let ((opoint (point))
- bounce
- (first t))
+ (let ((opoint (point)))
(save-excursion
(beginning-of-line)
(setq after-prefix (point))
(looking-at (regexp-quote fill-prefix))
(setq after-prefix (match-end 0)))
(move-to-column (1+ fc))
- ;; Move back to the point where we can break the line.
- ;; We break the line between word or
- ;; after/before the character which has character
- ;; category `|'. We search space, \c| followed by
- ;; a character, or \c| following a character. If
- ;; not found, place the point at beginning of line.
- (while (or first
- (and (not (bobp))
- (not bounce)
- (fill-nobreak-p)))
- (setq first nil)
- (re-search-backward "[ \t]\\|\\c|.\\|.\\c|\\|^")
- ;; If we find nowhere on the line to break it,
- ;; break after one word. Set bounce to t
- ;; so we will not keep going in this while loop.
- (if (<= (point) after-prefix)
- (progn
- (goto-char after-prefix)
- (re-search-forward "[ \t]" opoint t)
- (setq bounce t))
- (if (looking-at "[ \t]")
- ;; Break the line at word boundary.
- (skip-chars-backward " \t")
- ;; Break the line after/before \c|.
- (forward-char 1))))
- (if enable-multibyte-characters
- ;; If we are going to break the line after or
- ;; before a non-ascii character, we may have
- ;; to run a special function for the charset
- ;; of the character to find the correct break
- ;; point.
- (if (not (and (eq (charset-after (1- (point))) 'ascii)
- (eq (charset-after (point)) 'ascii)))
- (fill-find-break-point after-prefix)))
-
- ;; Let fill-point be set to the place where we end up.
- ;; But move back before any whitespace here.
- (skip-chars-backward " \t")
+ (fill-move-to-break-point after-prefix)
(point)))))
;; See whether the place we found is any good.
(if (save-excursion
(goto-char fill-point)
- (and (not (bolp))
- ;; There is no use breaking at end of line.
- (not (save-excursion (skip-chars-forward " ") (eolp)))
- ;; It is futile to split at the end of the prefix
- ;; since we would just insert the prefix again.
- (not (and after-prefix (<= (point) after-prefix)))
- ;; Don't split right after a comment starter
- ;; since we would just make another comment starter.
- (not (and comment-start-skip
- (let ((limit (point)))
- (beginning-of-line)
- (and (re-search-forward comment-start-skip
- limit t)
- (eq (point) limit)))))))
- ;; Ok, we have a useful place to break the line. Do it.
- (let ((prev-column (current-column)))
- ;; If point is at the fill-point, do not `save-excursion'.
- ;; Otherwise, if a comment prefix or fill-prefix is inserted,
- ;; point will end up before it rather than after it.
- (if (save-excursion
- (skip-chars-backward " \t")
- (= (point) fill-point))
- (funcall comment-line-break-function t)
+ (or (bolp)
+ ;; There is no use breaking at end of line.
+ (save-excursion (skip-chars-forward " ") (eolp))
+ ;; It is futile to split at the end of the prefix
+ ;; since we would just insert the prefix again.
+ (and after-prefix (<= (point) after-prefix))
+ ;; Don't split right after a comment starter
+ ;; since we would just make another comment starter.
+ (and comment-start-skip
+ (let ((limit (point)))
+ (beginning-of-line)
+ (and (re-search-forward comment-start-skip
+ limit t)
+ (eq (point) limit))))))
+ ;; No good place to break => stop trying.
+ (setq give-up t)
+ ;; Ok, we have a useful place to break the line. Do it.
+ (let ((prev-column (current-column)))
+ ;; If point is at the fill-point, do not `save-excursion'.
+ ;; Otherwise, if a comment prefix or fill-prefix is inserted,
+ ;; point will end up before it rather than after it.
+ (if (save-excursion
+ (skip-chars-backward " \t")
+ (= (point) fill-point))
+ (funcall comment-line-break-function t)
+ (save-excursion
+ (goto-char fill-point)
+ (funcall comment-line-break-function t)))
+ ;; Now do justification, if required
+ (if (not (eq justify 'left))
(save-excursion
- (goto-char fill-point)
- (funcall comment-line-break-function t)))
- ;; Now do justification, if required
- (if (not (eq justify 'left))
- (save-excursion
(end-of-line 0)
(justify-current-line justify nil t)))
- ;; If making the new line didn't reduce the hpos of
- ;; the end of the line, then give up now;
- ;; trying again will not help.
- (if (>= (current-column) prev-column)
- (setq give-up t)))
- ;; No good place to break => stop trying.
- (setq give-up t))))
+ ;; If making the new line didn't reduce the hpos of
+ ;; the end of the line, then give up now;
+ ;; trying again will not help.
+ (if (>= (current-column) prev-column)
+ (setq give-up t))))))
;; Justify last line.
(justify-current-line justify t t)
t)))
"The function to use for `auto-fill-function' if Auto Fill mode is turned on.
Some major modes set this.")
+;; FIXME: turn into a proper minor mode.
+;; Add a global minor mode version of it.
(defun auto-fill-mode (&optional arg)
"Toggle Auto Fill mode.
With arg, turn Auto Fill mode on if and only if arg is positive.
(error "set-fill-column requires an explicit argument")
(message "Fill column set to %d (was %d)" arg fill-column)
(setq fill-column arg)))
-
+\f
(defun set-selective-display (arg)
"Set `selective-display' to ARG; clear it if no arg.
When the value of `selective-display' is a number > 0,
(prin1 selective-display t)
(princ "." t))
+(defvaralias 'indicate-unused-lines 'indicate-empty-lines)
+(defvaralias 'default-indicate-unused-lines 'default-indicate-empty-lines)
+
+(defun toggle-truncate-lines (arg)
+ "Toggle whether to fold or truncate long lines on the screen.
+With arg, truncate long lines iff arg is positive.
+Note that in side-by-side windows, truncation is always enabled."
+ (interactive "P")
+ (setq truncate-lines
+ (if (null arg)
+ (not truncate-lines)
+ (> (prefix-numeric-value arg) 0)))
+ (force-mode-line-update)
+ (unless truncate-lines
+ (let ((buffer (current-buffer)))
+ (walk-windows (lambda (window)
+ (if (eq buffer (window-buffer window))
+ (set-window-hscroll window 0)))
+ nil t)))
+ (message "Truncate long lines %s"
+ (if truncate-lines "enabled" "disabled")))
+
(defvar overwrite-mode-textual " Ovwrt"
"The string displayed in the mode line when in overwrite mode.")
(defvar overwrite-mode-binary " Bin Ovwrt"
'overwrite-mode-binary))
(force-mode-line-update))
-(defcustom line-number-mode t
- "*Non-nil means display line number in mode line."
- :type 'boolean
- :group 'editing-basics)
-
-(defun line-number-mode (arg)
+(define-minor-mode line-number-mode
"Toggle Line Number mode.
With arg, turn Line Number mode on iff arg is positive.
When Line Number mode is enabled, the line number appears
Line numbers do not appear for very large buffers and buffers
with very long lines; see variables `line-number-display-limit'
and `line-number-display-limit-width'."
- (interactive "P")
- (setq line-number-mode
- (if (null arg) (not line-number-mode)
- (> (prefix-numeric-value arg) 0)))
- (force-mode-line-update))
-
-(defcustom column-number-mode nil
- "*Non-nil means display column number in mode line."
- :type 'boolean
- :group 'editing-basics)
+ :init-value t :global t :group 'editing-basics :require nil)
-(defun column-number-mode (arg)
+(define-minor-mode column-number-mode
"Toggle Column Number mode.
With arg, turn Column Number mode on iff arg is positive.
When Column Number mode is enabled, the column number appears
in the mode line."
- (interactive "P")
- (setq column-number-mode
- (if (null arg) (not column-number-mode)
- (> (prefix-numeric-value arg) 0)))
- (force-mode-line-update))
-
+ :global t :group 'editing-basics :require nil)
+\f
(defgroup paren-blinking nil
"Blinking matching of parens and expressions."
:prefix "blink-matching-"
;Turned off because it makes dbx bomb out.
(setq blink-paren-function 'blink-matching-open)
-
+\f
;; This executes C-g typed while Emacs is waiting for a command.
;; Quitting out of a program does not go through here;
;; that happens in the QUIT macro at the C code level.
At top-level, as an editor command, this simply beeps."
(interactive)
(deactivate-mark)
+ (setq defining-kbd-macro nil)
(signal 'quit nil))
(define-key global-map "\C-g" 'keyboard-quit)
((string-match "^ \\*" (buffer-name (current-buffer)))
(bury-buffer))))
+(defun play-sound-file (file &optional volume device)
+ "Play sound stored in FILE.
+VOLUME and DEVICE correspond to the keywords of the sound
+specification for `play-sound'."
+ (interactive "fPlay sound file: ")
+ (let ((sound (list :file file)))
+ (if volume
+ (plist-put sound :volume volume))
+ (if device
+ (plist-put sound :device device))
+ (push 'sound sound)
+ (play-sound sound)))
+
(define-key global-map "\e\e\e" 'keyboard-escape-quit)
(defcustom read-mail-command 'rmail
(function :tag "Other"))
:group 'mail)
-(defun define-mail-user-agent (symbol composefunc sendfunc
- &optional abortfunc hookvar)
- "Define a symbol to identify a mail-sending package for `mail-user-agent'.
-
-SYMBOL can be any Lisp symbol. Its function definition and/or
-value as a variable do not matter for this usage; we use only certain
-properties on its property list, to encode the rest of the arguments.
-
-COMPOSEFUNC is program callable function that composes an outgoing
-mail message buffer. This function should set up the basics of the
-buffer without requiring user interaction. It should populate the
-standard mail headers, leaving the `to:' and `subject:' headers blank
-by default.
-
-COMPOSEFUNC should accept several optional arguments--the same
-arguments that `compose-mail' takes. See that function's documentation.
-
-SENDFUNC is the command a user would run to send the message.
-
-Optional ABORTFUNC is the command a user would run to abort the
-message. For mail packages that don't have a separate abort function,
-this can be `kill-buffer' (the equivalent of omitting this argument).
-
-Optional HOOKVAR is a hook variable that gets run before the message
-is actually sent. Callers that use the `mail-user-agent' may
-install a hook function temporarily on this hook variable.
-If HOOKVAR is nil, `mail-send-hook' is used.
-
-The properties used on SYMBOL are `composefunc', `sendfunc',
-`abortfunc', and `hookvar'."
- (put symbol 'composefunc composefunc)
- (put symbol 'sendfunc sendfunc)
- (put symbol 'abortfunc (or abortfunc 'kill-buffer))
- (put symbol 'hookvar (or hookvar 'mail-send-hook)))
-
(define-mail-user-agent 'sendmail-user-agent
'sendmail-user-agent-compose
'mail-send-and-exit)
(defvar set-variable-value-history nil
"History of values entered with `set-variable'.")
-(defun set-variable (var val)
+(defun set-variable (var val &optional make-local)
"Set VARIABLE to VALUE. VALUE is a Lisp object.
When using this interactively, enter a Lisp object for VALUE.
If you want VALUE to be a string, you must surround it with doublequotes.
it were the arg to `interactive' (which see) to interactively read VALUE.
If VARIABLE has been defined with `defcustom', then the type information
-in the definition is used to check that VALUE is valid."
+in the definition is used to check that VALUE is valid.
+
+With a prefix argument, set VARIABLE to VALUE buffer-locally."
(interactive
(let* ((default-var (variable-at-point))
(var (if (symbolp default-var)
(read-variable "Set variable: ")))
(minibuffer-help-form '(describe-variable var))
(prop (get var 'variable-interactive))
- (prompt (format "Set %s to value: " var))
+ (prompt (format "Set %s%s to value: " var
+ (cond ((local-variable-p var)
+ " (buffer-local)")
+ ((or current-prefix-arg
+ (local-variable-if-set-p var))
+ " buffer-locally")
+ (t " globally"))))
(val (if prop
;; Use VAR's `variable-interactive' property
;; as an interactive spec for prompting.
(read
(read-string prompt nil
'set-variable-value-history)))))
- (list var val)))
+ (list var val current-prefix-arg)))
(let ((type (get var 'custom-type)))
(when type
(unless (widget-apply type :match val)
(error "Value `%S' does not match type %S of %S"
val (car type) var))))
+
+ (if make-local
+ (make-local-variable var))
+
(set var val)
;; Force a thorough redisplay for the case that the variable
;; that can be found before POINT.
(defun choose-completion-delete-max-match (string)
(let ((opoint (point))
- (len (min (length string)
- (- (point) (point-min)))))
- (goto-char (- (point) (length string)))
+ len)
+ ;; Try moving back by the length of the string.
+ (goto-char (max (- (point) (length string))
+ (minibuffer-prompt-end)))
+ ;; See how far back we were actually able to move. That is the
+ ;; upper bound on how much we can match and delete.
+ (setq len (- opoint (point)))
(if completion-ignore-case
(setq string (downcase string)))
(while (and (> len 0)
- (let ((tail (buffer-substring (point)
- (+ (point) len))))
+ (let ((tail (buffer-substring (point) opoint)))
(if completion-ignore-case
(setq tail (downcase tail)))
(not (string= tail (substring string 0 len)))))
(forward-char 1))
(delete-char len)))
-;; Switch to BUFFER and insert the completion choice CHOICE.
-;; BASE-SIZE, if non-nil, says how many characters of BUFFER's text
-;; to keep. If it is nil, use choose-completion-delete-max-match instead.
+(defvar choose-completion-string-functions nil
+ "Functions that may override the normal insertion of a completion choice.
+These functions are called in order with four arguments:
+CHOICE - the string to insert in the buffer,
+BUFFER - the buffer in which the choice should be inserted,
+MINI-P - non-nil iff BUFFER is a minibuffer, and
+BASE-SIZE - the number of characters in BUFFER before
+the string being completed.
+
+If a function in the list returns non-nil, that function is supposed
+to have inserted the CHOICE in the BUFFER, and possibly exited
+the minibuffer; no further functions will be called.
+
+If all functions in the list return nil, that means to use
+the default method of inserting the completion in BUFFER.")
-;; If BUFFER is the minibuffer, exit the minibuffer
-;; unless it is reading a file name and CHOICE is a directory,
-;; or completion-no-auto-exit is non-nil.
(defun choose-completion-string (choice &optional buffer base-size)
+ "Switch to BUFFER and insert the completion choice CHOICE.
+BASE-SIZE, if non-nil, says how many characters of BUFFER's text
+to keep. If it is nil, we call `choose-completion-delete-max-match'
+to decide what to delete."
+
+ ;; If BUFFER is the minibuffer, exit the minibuffer
+ ;; unless it is reading a file name and CHOICE is a directory,
+ ;; or completion-no-auto-exit is non-nil.
+
(let ((buffer (or buffer completion-reference-buffer))
- (mini-p (string-match "\\` \\*Minibuf-[0-9]+\\*\\'" (buffer-name buffer))))
+ (mini-p (string-match "\\` \\*Minibuf-[0-9]+\\*\\'"
+ (buffer-name buffer))))
;; If BUFFER is a minibuffer, barf unless it's the currently
;; active minibuffer.
(if (and mini-p
(not (equal buffer
(window-buffer (active-minibuffer-window))))))
(error "Minibuffer is not active for completion")
- ;; Insert the completion into the buffer where completion was requested.
- (set-buffer buffer)
- (if base-size
- (delete-region (+ base-size (if mini-p
- (minibuffer-prompt-end)
- (point-min)))
- (point))
- (choose-completion-delete-max-match choice))
- (insert choice)
- (remove-text-properties (- (point) (length choice)) (point)
- '(mouse-face nil))
- ;; Update point in the window that BUFFER is showing in.
- (let ((window (get-buffer-window buffer t)))
- (set-window-point window (point)))
- ;; If completing for the minibuffer, exit it with this choice.
- (and (not completion-no-auto-exit)
- (equal buffer (window-buffer (minibuffer-window)))
- minibuffer-completion-table
- ;; If this is reading a file name, and the file name chosen
- ;; is a directory, don't exit the minibuffer.
- (if (and (eq minibuffer-completion-table 'read-file-name-internal)
- (file-directory-p (field-string (point-max))))
- (let ((mini (active-minibuffer-window)))
- (select-window mini)
- (when minibuffer-auto-raise
- (raise-frame (window-frame mini))))
- (exit-minibuffer))))))
+ (unless (run-hook-with-args-until-success
+ 'choose-completion-string-functions
+ choice buffer mini-p base-size)
+ ;; Insert the completion into the buffer where it was requested.
+ (set-buffer buffer)
+ (if base-size
+ (delete-region (+ base-size (if mini-p
+ (minibuffer-prompt-end)
+ (point-min)))
+ (point))
+ (choose-completion-delete-max-match choice))
+ (insert choice)
+ (remove-text-properties (- (point) (length choice)) (point)
+ '(mouse-face nil))
+ ;; Update point in the window that BUFFER is showing in.
+ (let ((window (get-buffer-window buffer t)))
+ (set-window-point window (point)))
+ ;; If completing for the minibuffer, exit it with this choice.
+ (and (not completion-no-auto-exit)
+ (equal buffer (window-buffer (minibuffer-window)))
+ minibuffer-completion-table
+ ;; If this is reading a file name, and the file name chosen
+ ;; is a directory, don't exit the minibuffer.
+ (if (and (eq minibuffer-completion-table 'read-file-name-internal)
+ (file-directory-p (field-string (point-max))))
+ (let ((mini (active-minibuffer-window)))
+ (select-window mini)
+ (when minibuffer-auto-raise
+ (raise-frame (window-frame mini))))
+ (exit-minibuffer)))))))
(defun completion-list-mode ()
"Major mode for buffers showing lists of possible completions.
(completion-list-mode)
(make-local-variable 'completion-reference-buffer)
(setq completion-reference-buffer mainbuf)
- (if (eq minibuffer-completion-table 'read-file-name-internal)
+ (if minibuffer-completing-file-name
;; For file name completion,
;; use the number of chars before the start of the
;; last file name component.
(save-excursion
(set-buffer mainbuf)
(goto-char (point-max))
- (skip-chars-backward (format "^%c" directory-sep-char))
+ (skip-chars-backward "^/")
(- (point) (minibuffer-prompt-end))))
;; Otherwise, in minibuffer, the whole input is being completed.
(save-match-data
(kp-decimal ?.)
(kp-divide ?/)
(kp-equal ?=)))
-
+\f
;;;;
;;;; forking a twin copy of a buffer.
;;;;
(setq newname (substring newname 0 (match-beginning 0))))
(when (memq (process-status process) '(run stop open))
(let* ((process-connection-type (process-tty-name process))
- (old-kwoq (process-kill-without-query process nil))
(new-process
(if (memq (process-status process) '(open))
- (apply 'open-network-stream newname
- (if (process-buffer process) (current-buffer))
- (process-contact process))
+ (let ((args (process-contact process t)))
+ (setq args (plist-put args :name newname))
+ (setq args (plist-put args :buffer
+ (if (process-buffer process) (current-buffer))))
+ (apply 'make-network-process args))
(apply 'start-process newname
(if (process-buffer process) (current-buffer))
(process-command process)))))
- (process-kill-without-query new-process old-kwoq)
- (process-kill-without-query process old-kwoq)
+ (set-process-query-on-exit-flag
+ new-process (process-query-on-exit-flag process))
(set-process-inherit-coding-system-flag
new-process (process-inherit-coding-system-flag process))
(set-process-filter new-process (process-filter process))
(set-process-sentinel new-process (process-sentinel process))
new-process)))
-;; things to maybe add (currently partly covered by `funcall mode':
+;; things to maybe add (currently partly covered by `funcall mode'):
;; - syntax-table
;; - overlays
(defun clone-buffer (&optional newname display-flag)
Optional second arg NORECORD non-nil means do not put this buffer at
the front of the list of recently selected ones."
(interactive "bClone buffer in other window: ")
- (let ((popup-windows t))
+ (let ((pop-up-windows t))
(set-buffer buffer)
(clone-indirect-buffer nil t norecord)))
(define-key ctl-x-4-map "c" 'clone-indirect-buffer-other-window)
-
-
-;;; Syntax stuff.
-
-(defconst syntax-code-table
- '((?\ 0 "whitespace")
- (?- 0 "whitespace")
- (?. 1 "punctuation")
- (?w 2 "word")
- (?_ 3 "symbol")
- (?\( 4 "open parenthesis")
- (?\) 5 "close parenthesis")
- (?\' 6 "expression prefix")
- (?\" 7 "string quote")
- (?$ 8 "paired delimiter")
- (?\\ 9 "escape")
- (?/ 10 "character quote")
- (?< 11 "comment start")
- (?> 12 "comment end")
- (?@ 13 "inherit")
- (nil 14 "comment fence")
- (nil 15 "string fence"))
- "Alist of forms (CHAR CODE DESCRIPTION) mapping characters to syntax info.
-CHAR is a character that is allowed as first char in the string
-specifying the syntax when calling `modify-syntax-entry'. CODE is the
-corresponing syntax code as it is stored in a syntax cell, and
-can be used as value of a `syntax-table' property.
-DESCRIPTION is the descriptive string for the syntax.")
-
-
+\f
;;; Handling of Backspace and Delete keys.
(defcustom normal-erase-is-backspace nil
(if normal-erase-is-backspace "forward" "backward"))))
-;;; Misc
-
-(defun byte-compiling-files-p ()
- "Return t if currently byte-compiling files."
- (and (boundp 'byte-compile-current-file)
- (stringp byte-compile-current-file)))
-
-
;; Minibuffer prompt stuff.
;(defun minibuffer-prompt-modification (start end)
; 'insert-in-front-hooks '(minibuffer-prompt-insertion)))
;
+(provide 'simple)
;;; simple.el ends here