LCOV - code coverage report
Current view: top level - lisp - simple.el (source / functions) Hit Total Coverage
Test: tramp-tests.info Lines: 183 3616 5.1 %
Date: 2017-08-27 09:44:50 Functions: 27 300 9.0 %

          Line data    Source code
       1             : ;;; simple.el --- basic editing commands for Emacs  -*- lexical-binding: t -*-
       2             : 
       3             : ;; Copyright (C) 1985-1987, 1993-2017 Free Software Foundation, Inc.
       4             : 
       5             : ;; Maintainer: emacs-devel@gnu.org
       6             : ;; Keywords: internal
       7             : ;; Package: emacs
       8             : 
       9             : ;; This file is part of GNU Emacs.
      10             : 
      11             : ;; GNU Emacs is free software: you can redistribute it and/or modify
      12             : ;; it under the terms of the GNU General Public License as published by
      13             : ;; the Free Software Foundation, either version 3 of the License, or
      14             : ;; (at your option) any later version.
      15             : 
      16             : ;; GNU Emacs is distributed in the hope that it will be useful,
      17             : ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
      18             : ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
      19             : ;; GNU General Public License for more details.
      20             : 
      21             : ;; You should have received a copy of the GNU General Public License
      22             : ;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.
      23             : 
      24             : ;;; Commentary:
      25             : 
      26             : ;; A grab-bag of basic Emacs commands not specifically related to some
      27             : ;; major mode or to file-handling.
      28             : 
      29             : ;;; Code:
      30             : 
      31             : (eval-when-compile (require 'cl-lib))
      32             : 
      33             : (declare-function widget-convert "wid-edit" (type &rest args))
      34             : (declare-function shell-mode "shell" ())
      35             : 
      36             : ;;; From compile.el
      37             : (defvar compilation-current-error)
      38             : (defvar compilation-context-lines)
      39             : 
      40             : (defcustom shell-command-dont-erase-buffer nil
      41             :   "If non-nil, output buffer is not erased between shell commands.
      42             : Also, a non-nil value set the point in the output buffer
      43             : once the command complete.
      44             : The value `beg-last-out' set point at the beginning of the output,
      45             : `end-last-out' set point at the end of the buffer, `save-point'
      46             : restore the buffer position before the command."
      47             :   :type '(choice
      48             :           (const :tag "Erase buffer" nil)
      49             :           (const :tag "Set point to beginning of last output" beg-last-out)
      50             :           (const :tag "Set point to end of last output" end-last-out)
      51             :           (const :tag "Save point" save-point))
      52             :   :group 'shell
      53             :   :version "26.1")
      54             : 
      55             : (defvar shell-command-saved-pos nil
      56             :   "Point position in the output buffer after command complete.
      57             : It is an alist (BUFFER . POS), where BUFFER is the output
      58             : buffer, and POS is the point position in BUFFER once the command finish.
      59             : This variable is used when `shell-command-dont-erase-buffer' is non-nil.")
      60             : 
      61             : (defcustom idle-update-delay 0.5
      62             :   "Idle time delay before updating various things on the screen.
      63             : Various Emacs features that update auxiliary information when point moves
      64             : wait this many seconds after Emacs becomes idle before doing an update."
      65             :   :type 'number
      66             :   :group 'display
      67             :   :version "22.1")
      68             : 
      69             : (defgroup killing nil
      70             :   "Killing and yanking commands."
      71             :   :group 'editing)
      72             : 
      73             : (defgroup paren-matching nil
      74             :   "Highlight (un)matching of parens and expressions."
      75             :   :group 'matching)
      76             : 
      77             : ;;; next-error support framework
      78             : 
      79             : (defgroup next-error nil
      80             :   "`next-error' support framework."
      81             :   :group 'compilation
      82             :   :version "22.1")
      83             : 
      84             : (defface next-error
      85             :   '((t (:inherit region)))
      86             :   "Face used to highlight next error locus."
      87             :   :group 'next-error
      88             :   :version "22.1")
      89             : 
      90             : (defcustom next-error-highlight 0.5
      91             :   "Highlighting of locations in selected source buffers.
      92             : If a number, highlight the locus in `next-error' face for the given time
      93             : in seconds, or until the next command is executed.
      94             : If t, highlight the locus until the next command is executed, or until
      95             : some other locus replaces it.
      96             : If nil, don't highlight the locus in the source buffer.
      97             : If `fringe-arrow', indicate the locus by the fringe arrow
      98             : indefinitely until some other locus replaces it."
      99             :   :type '(choice (number :tag "Highlight for specified time")
     100             :                  (const :tag "Semipermanent highlighting" t)
     101             :                  (const :tag "No highlighting" nil)
     102             :                  (const :tag "Fringe arrow" fringe-arrow))
     103             :   :group 'next-error
     104             :   :version "22.1")
     105             : 
     106             : (defcustom next-error-highlight-no-select 0.5
     107             :   "Highlighting of locations in `next-error-no-select'.
     108             : If number, highlight the locus in `next-error' face for given time in seconds.
     109             : If t, highlight the locus indefinitely until some other locus replaces it.
     110             : If nil, don't highlight the locus in the source buffer.
     111             : If `fringe-arrow', indicate the locus by the fringe arrow
     112             : indefinitely until some other locus replaces it."
     113             :   :type '(choice (number :tag "Highlight for specified time")
     114             :                  (const :tag "Semipermanent highlighting" t)
     115             :                  (const :tag "No highlighting" nil)
     116             :                  (const :tag "Fringe arrow" fringe-arrow))
     117             :   :group 'next-error
     118             :   :version "22.1")
     119             : 
     120             : (defcustom next-error-recenter nil
     121             :   "Display the line in the visited source file recentered as specified.
     122             : If non-nil, the value is passed directly to `recenter'."
     123             :   :type '(choice (integer :tag "Line to recenter to")
     124             :                  (const :tag "Center of window" (4))
     125             :                  (const :tag "No recentering" nil))
     126             :   :group 'next-error
     127             :   :version "23.1")
     128             : 
     129             : (defcustom next-error-hook nil
     130             :   "List of hook functions run by `next-error' after visiting source file."
     131             :   :type 'hook
     132             :   :group 'next-error)
     133             : 
     134             : (defvar next-error-highlight-timer nil)
     135             : 
     136             : (defvar next-error-overlay-arrow-position nil)
     137             : (put 'next-error-overlay-arrow-position 'overlay-arrow-string (purecopy "=>"))
     138             : (add-to-list 'overlay-arrow-variable-list 'next-error-overlay-arrow-position)
     139             : 
     140             : (defvar next-error-last-buffer nil
     141             :   "The most recent `next-error' buffer.
     142             : A buffer becomes most recent when its compilation, grep, or
     143             : similar mode is started, or when it is used with \\[next-error]
     144             : or \\[compile-goto-error].")
     145             : 
     146             : (defvar next-error-function nil
     147             :   "Function to use to find the next error in the current buffer.
     148             : The function is called with 2 parameters:
     149             : ARG is an integer specifying by how many errors to move.
     150             : RESET is a boolean which, if non-nil, says to go back to the beginning
     151             : of the errors before moving.
     152             : Major modes providing compile-like functionality should set this variable
     153             : to indicate to `next-error' that this is a candidate buffer and how
     154             : to navigate in it.")
     155             : (make-variable-buffer-local 'next-error-function)
     156             : 
     157             : (defvar next-error-move-function nil
     158             :   "Function to use to move to an error locus.
     159             : It takes two arguments, a buffer position in the error buffer
     160             : and a buffer position in the error locus buffer.
     161             : The buffer for the error locus should already be current.
     162             : nil means use goto-char using the second argument position.")
     163             : (make-variable-buffer-local 'next-error-move-function)
     164             : 
     165             : (defsubst next-error-buffer-p (buffer
     166             :                                &optional avoid-current
     167             :                                extra-test-inclusive
     168             :                                extra-test-exclusive)
     169             :   "Return non-nil if BUFFER is a `next-error' capable buffer.
     170             : If AVOID-CURRENT is non-nil, and BUFFER is the current buffer,
     171             : return nil.
     172             : 
     173             : The function EXTRA-TEST-INCLUSIVE, if non-nil, is called if
     174             : BUFFER would not normally qualify.  If it returns non-nil, BUFFER
     175             : is considered `next-error' capable, anyway, and the function
     176             : returns non-nil.
     177             : 
     178             : The function EXTRA-TEST-EXCLUSIVE, if non-nil, is called if the
     179             : buffer would normally qualify.  If it returns nil, BUFFER is
     180             : rejected, and the function returns nil."
     181           0 :   (and (buffer-name buffer)             ;First make sure it's live.
     182           0 :        (not (and avoid-current (eq buffer (current-buffer))))
     183           0 :        (with-current-buffer buffer
     184           0 :          (if next-error-function   ; This is the normal test.
     185             :              ;; Optionally reject some buffers.
     186           0 :              (if extra-test-exclusive
     187           0 :                  (funcall extra-test-exclusive)
     188           0 :                t)
     189             :            ;; Optionally accept some other buffers.
     190           0 :            (and extra-test-inclusive
     191           0 :                 (funcall extra-test-inclusive))))))
     192             : 
     193             : (defun next-error-find-buffer (&optional avoid-current
     194             :                                          extra-test-inclusive
     195             :                                          extra-test-exclusive)
     196             :   "Return a `next-error' capable buffer.
     197             : 
     198             : If AVOID-CURRENT is non-nil, treat the current buffer
     199             : as an absolute last resort only.
     200             : 
     201             : The function EXTRA-TEST-INCLUSIVE, if non-nil, is called in each buffer
     202             : that normally would not qualify.  If it returns t, the buffer
     203             : in question is treated as usable.
     204             : 
     205             : The function EXTRA-TEST-EXCLUSIVE, if non-nil, is called in each buffer
     206             : that would normally be considered usable.  If it returns nil,
     207             : that buffer is rejected."
     208           0 :   (or
     209             :    ;; 1. If one window on the selected frame displays such buffer, return it.
     210           0 :    (let ((window-buffers
     211           0 :           (delete-dups
     212           0 :            (delq nil (mapcar (lambda (w)
     213           0 :                                (if (next-error-buffer-p
     214           0 :                                     (window-buffer w)
     215           0 :                                     avoid-current
     216           0 :                                     extra-test-inclusive extra-test-exclusive)
     217           0 :                                    (window-buffer w)))
     218           0 :                              (window-list))))))
     219           0 :      (if (eq (length window-buffers) 1)
     220           0 :          (car window-buffers)))
     221             :    ;; 2. If next-error-last-buffer is an acceptable buffer, use that.
     222           0 :    (if (and next-error-last-buffer
     223           0 :             (next-error-buffer-p next-error-last-buffer avoid-current
     224           0 :                                  extra-test-inclusive extra-test-exclusive))
     225           0 :        next-error-last-buffer)
     226             :    ;; 3. If the current buffer is acceptable, choose it.
     227           0 :    (if (next-error-buffer-p (current-buffer) avoid-current
     228           0 :                             extra-test-inclusive extra-test-exclusive)
     229           0 :        (current-buffer))
     230             :    ;; 4. Look for any acceptable buffer.
     231           0 :    (let ((buffers (buffer-list)))
     232           0 :      (while (and buffers
     233           0 :                  (not (next-error-buffer-p
     234           0 :                        (car buffers) avoid-current
     235           0 :                        extra-test-inclusive extra-test-exclusive)))
     236           0 :        (setq buffers (cdr buffers)))
     237           0 :      (car buffers))
     238             :    ;; 5. Use the current buffer as a last resort if it qualifies,
     239             :    ;; even despite AVOID-CURRENT.
     240           0 :    (and avoid-current
     241           0 :         (next-error-buffer-p (current-buffer) nil
     242           0 :                              extra-test-inclusive extra-test-exclusive)
     243           0 :         (progn
     244           0 :           (message "This is the only buffer with error message locations")
     245           0 :           (current-buffer)))
     246             :    ;; 6. Give up.
     247           0 :    (error "No buffers contain error message locations")))
     248             : 
     249             : (defun next-error (&optional arg reset)
     250             :   "Visit next `next-error' message and corresponding source code.
     251             : 
     252             : If all the error messages parsed so far have been processed already,
     253             : the message buffer is checked for new ones.
     254             : 
     255             : A prefix ARG specifies how many error messages to move;
     256             : negative means move back to previous error messages.
     257             : Just \\[universal-argument] as a prefix means reparse the error message buffer
     258             : and start at the first error.
     259             : 
     260             : The RESET argument specifies that we should restart from the beginning.
     261             : 
     262             : \\[next-error] normally uses the most recently started
     263             : compilation, grep, or occur buffer.  It can also operate on any
     264             : buffer with output from the \\[compile], \\[grep] commands, or,
     265             : more generally, on any buffer in Compilation mode or with
     266             : Compilation Minor mode enabled, or any buffer in which
     267             : `next-error-function' is bound to an appropriate function.
     268             : To specify use of a particular buffer for error messages, type
     269             : \\[next-error] in that buffer when it is the only one displayed
     270             : in the current frame.
     271             : 
     272             : Once \\[next-error] has chosen the buffer for error messages, it
     273             : runs `next-error-hook' with `run-hooks', and stays with that buffer
     274             : until you use it in some other buffer which uses Compilation mode
     275             : or Compilation Minor mode.
     276             : 
     277             : To control which errors are matched, customize the variable
     278             : `compilation-error-regexp-alist'."
     279             :   (interactive "P")
     280           0 :   (if (consp arg) (setq reset t arg nil))
     281           0 :   (when (setq next-error-last-buffer (next-error-find-buffer))
     282             :     ;; we know here that next-error-function is a valid symbol we can funcall
     283           0 :     (with-current-buffer next-error-last-buffer
     284           0 :       (funcall next-error-function (prefix-numeric-value arg) reset)
     285           0 :       (when next-error-recenter
     286           0 :         (recenter next-error-recenter))
     287           0 :       (run-hooks 'next-error-hook))))
     288             : 
     289             : (defun next-error-internal ()
     290             :   "Visit the source code corresponding to the `next-error' message at point."
     291           0 :   (setq next-error-last-buffer (current-buffer))
     292             :   ;; we know here that next-error-function is a valid symbol we can funcall
     293           0 :   (with-current-buffer next-error-last-buffer
     294           0 :     (funcall next-error-function 0 nil)
     295           0 :     (when next-error-recenter
     296           0 :       (recenter next-error-recenter))
     297           0 :     (run-hooks 'next-error-hook)))
     298             : 
     299             : (defalias 'goto-next-locus 'next-error)
     300             : (defalias 'next-match 'next-error)
     301             : 
     302             : (defun previous-error (&optional n)
     303             :   "Visit previous `next-error' message and corresponding source code.
     304             : 
     305             : Prefix arg N says how many error messages to move backwards (or
     306             : forwards, if negative).
     307             : 
     308             : This operates on the output from the \\[compile] and \\[grep] commands."
     309             :   (interactive "p")
     310           0 :   (next-error (- (or n 1))))
     311             : 
     312             : (defun first-error (&optional n)
     313             :   "Restart at the first error.
     314             : Visit corresponding source code.
     315             : With prefix arg N, visit the source code of the Nth error.
     316             : This operates on the output from the \\[compile] command, for instance."
     317             :   (interactive "p")
     318           0 :   (next-error n t))
     319             : 
     320             : (defun next-error-no-select (&optional n)
     321             :   "Move point to the next error in the `next-error' buffer and highlight match.
     322             : Prefix arg N says how many error messages to move forwards (or
     323             : backwards, if negative).
     324             : Finds and highlights the source line like \\[next-error], but does not
     325             : select the source buffer."
     326             :   (interactive "p")
     327           0 :   (let ((next-error-highlight next-error-highlight-no-select))
     328           0 :     (next-error n))
     329           0 :   (pop-to-buffer next-error-last-buffer))
     330             : 
     331             : (defun previous-error-no-select (&optional n)
     332             :   "Move point to the previous error in the `next-error' buffer and highlight match.
     333             : Prefix arg N says how many error messages to move backwards (or
     334             : forwards, if negative).
     335             : Finds and highlights the source line like \\[previous-error], but does not
     336             : select the source buffer."
     337             :   (interactive "p")
     338           0 :   (next-error-no-select (- (or n 1))))
     339             : 
     340             : ;; Internal variable for `next-error-follow-mode-post-command-hook'.
     341             : (defvar next-error-follow-last-line nil)
     342             : 
     343             : (define-minor-mode next-error-follow-minor-mode
     344             :   "Minor mode for compilation, occur and diff modes.
     345             : With a prefix argument ARG, enable mode if ARG is positive, and
     346             : disable it otherwise.  If called from Lisp, enable mode if ARG is
     347             : omitted or nil.
     348             : When turned on, cursor motion in the compilation, grep, occur or diff
     349             : buffer causes automatic display of the corresponding source code location."
     350             :   :group 'next-error :init-value nil :lighter " Fol"
     351           0 :   (if (not next-error-follow-minor-mode)
     352           0 :       (remove-hook 'post-command-hook 'next-error-follow-mode-post-command-hook t)
     353           0 :     (add-hook 'post-command-hook 'next-error-follow-mode-post-command-hook nil t)
     354           0 :     (make-local-variable 'next-error-follow-last-line)))
     355             : 
     356             : ;; Used as a `post-command-hook' by `next-error-follow-mode'
     357             : ;; for the *Compilation* *grep* and *Occur* buffers.
     358             : (defun next-error-follow-mode-post-command-hook ()
     359           0 :   (unless (equal next-error-follow-last-line (line-number-at-pos))
     360           0 :     (setq next-error-follow-last-line (line-number-at-pos))
     361           0 :     (condition-case nil
     362           0 :         (let ((compilation-context-lines nil))
     363           0 :           (setq compilation-current-error (point))
     364           0 :           (next-error-no-select 0))
     365           0 :       (error t))))
     366             : 
     367             : 
     368             : ;;;
     369             : 
     370             : (defun fundamental-mode ()
     371             :   "Major mode not specialized for anything in particular.
     372             : Other major modes are defined by comparison with this one."
     373             :   (interactive)
     374           0 :   (kill-all-local-variables)
     375           0 :   (run-mode-hooks))
     376             : 
     377             : ;; Special major modes to view specially formatted data rather than files.
     378             : 
     379             : (defvar special-mode-map
     380             :   (let ((map (make-sparse-keymap)))
     381             :     (suppress-keymap map)
     382             :     (define-key map "q" 'quit-window)
     383             :     (define-key map " " 'scroll-up-command)
     384             :     (define-key map [?\S-\ ] 'scroll-down-command)
     385             :     (define-key map "\C-?" 'scroll-down-command)
     386             :     (define-key map "?" 'describe-mode)
     387             :     (define-key map "h" 'describe-mode)
     388             :     (define-key map ">" 'end-of-buffer)
     389             :     (define-key map "<" 'beginning-of-buffer)
     390             :     (define-key map "g" 'revert-buffer)
     391             :     map))
     392             : 
     393             : (put 'special-mode 'mode-class 'special)
     394             : (define-derived-mode special-mode nil "Special"
     395             :   "Parent major mode from which special major modes should inherit."
     396           0 :   (setq buffer-read-only t))
     397             : 
     398             : ;; Making and deleting lines.
     399             : 
     400             : (defvar self-insert-uses-region-functions nil
     401             :   "Special hook to tell if `self-insert-command' will use the region.
     402             : It must be called via `run-hook-with-args-until-success' with no arguments.
     403             : Any `post-self-insert-command' which consumes the region should
     404             : register a function on this hook so that things like `delete-selection-mode'
     405             : can refrain from consuming the region.")
     406             : 
     407             : (defvar hard-newline (propertize "\n" 'hard t 'rear-nonsticky '(hard))
     408             :   "Propertized string representing a hard newline character.")
     409             : 
     410             : (defun newline (&optional arg interactive)
     411             :   "Insert a newline, and move to left margin of the new line if it's blank.
     412             : If option `use-hard-newlines' is non-nil, the newline is marked with the
     413             : text-property `hard'.
     414             : With ARG, insert that many newlines.
     415             : 
     416             : If `electric-indent-mode' is enabled, this indents the final new line
     417             : that it adds, and reindents the preceding line.  To just insert
     418             : a newline, use \\[electric-indent-just-newline].
     419             : 
     420             : Calls `auto-fill-function' if the current column number is greater
     421             : than the value of `fill-column' and ARG is nil.
     422             : A non-nil INTERACTIVE argument means to run the `post-self-insert-hook'."
     423             :   (interactive "*P\np")
     424         404 :   (barf-if-buffer-read-only)
     425             :   ;; Call self-insert so that auto-fill, abbrev expansion etc. happens.
     426             :   ;; Set last-command-event to tell self-insert what to insert.
     427         404 :   (let* ((was-page-start (and (bolp) (looking-at page-delimiter)))
     428         404 :          (beforepos (point))
     429             :          (last-command-event ?\n)
     430             :          ;; Don't auto-fill if we have a numeric argument.
     431         404 :          (auto-fill-function (if arg nil auto-fill-function))
     432         404 :          (arg (prefix-numeric-value arg))
     433             :          (postproc
     434             :           ;; Do the rest in post-self-insert-hook, because we want to do it
     435             :           ;; *before* other functions on that hook.
     436             :           (lambda ()
     437             :             ;; We are not going to insert any newlines if arg is
     438             :             ;; non-positive.
     439         404 :             (or (and (numberp arg) (<= arg 0))
     440         404 :                 (cl-assert (eq ?\n (char-before))))
     441             :             ;; Mark the newline(s) `hard'.
     442         404 :             (if use-hard-newlines
     443           0 :                 (set-hard-newline-properties
     444         404 :                  (- (point) arg) (point)))
     445             :             ;; If the newline leaves the previous line blank, and we
     446             :             ;; have a left margin, delete that from the blank line.
     447         404 :             (save-excursion
     448         404 :               (goto-char beforepos)
     449         404 :               (beginning-of-line)
     450         404 :               (and (looking-at "[ \t]$")
     451           0 :                    (> (current-left-margin) 0)
     452           0 :                    (delete-region (point)
     453         404 :                                   (line-end-position))))
     454             :             ;; Indent the line after the newline, except in one case:
     455             :             ;; when we added the newline at the beginning of a line which
     456             :             ;; starts a page.
     457         404 :             (or was-page-start
     458         404 :                 (move-to-left-margin nil t)))))
     459         404 :     (unwind-protect
     460         404 :         (if (not interactive)
     461             :             ;; FIXME: For non-interactive uses, many calls actually
     462             :             ;; just want (insert "\n"), so maybe we should do just
     463             :             ;; that, so as to avoid the risk of filling or running
     464             :             ;; abbrevs unexpectedly.
     465         404 :             (let ((post-self-insert-hook (list postproc)))
     466         404 :               (self-insert-command arg))
     467           0 :           (unwind-protect
     468           0 :               (progn
     469           0 :                 (add-hook 'post-self-insert-hook postproc nil t)
     470           0 :                 (self-insert-command arg))
     471             :             ;; We first used let-binding to protect the hook, but that
     472             :             ;; was naive since add-hook affects the symbol-default
     473             :             ;; value of the variable, whereas the let-binding might
     474             :             ;; only protect the buffer-local value.
     475         404 :             (remove-hook 'post-self-insert-hook postproc t)))
     476         404 :       (cl-assert (not (member postproc post-self-insert-hook)))
     477         404 :       (cl-assert (not (member postproc (default-value 'post-self-insert-hook))))))
     478             :   nil)
     479             : 
     480             : (defun set-hard-newline-properties (from to)
     481           0 :   (let ((sticky (get-text-property from 'rear-nonsticky)))
     482           0 :     (put-text-property from to 'hard 't)
     483             :     ;; If rear-nonsticky is not "t", add 'hard to rear-nonsticky list
     484           0 :     (if (and (listp sticky) (not (memq 'hard sticky)))
     485           0 :         (put-text-property from (point) 'rear-nonsticky
     486           0 :                            (cons 'hard sticky)))))
     487             : 
     488             : (defun open-line (n)
     489             :   "Insert a newline and leave point before it.
     490             : If there is a fill prefix and/or a `left-margin', insert them on
     491             : the new line if the line would have been blank.
     492             : With arg N, insert N newlines."
     493             :   (interactive "*p")
     494           0 :   (let* ((do-fill-prefix (and fill-prefix (bolp)))
     495           0 :          (do-left-margin (and (bolp) (> (current-left-margin) 0)))
     496           0 :          (loc (point-marker))
     497             :          ;; Don't expand an abbrev before point.
     498             :          (abbrev-mode nil))
     499           0 :     (newline n)
     500           0 :     (goto-char loc)
     501           0 :     (while (> n 0)
     502           0 :       (cond ((bolp)
     503           0 :              (if do-left-margin (indent-to (current-left-margin)))
     504           0 :              (if do-fill-prefix (insert-and-inherit fill-prefix))))
     505           0 :       (forward-line 1)
     506           0 :       (setq n (1- n)))
     507           0 :     (goto-char loc)
     508             :     ;; Necessary in case a margin or prefix was inserted.
     509           0 :     (end-of-line)))
     510             : 
     511             : (defun split-line (&optional arg)
     512             :   "Split current line, moving portion beyond point vertically down.
     513             : If the current line starts with `fill-prefix', insert it on the new
     514             : line as well.  With prefix ARG, don't insert `fill-prefix' on new line.
     515             : 
     516             : When called from Lisp code, ARG may be a prefix string to copy."
     517             :   (interactive "*P")
     518           0 :   (skip-chars-forward " \t")
     519           0 :   (let* ((col (current-column))
     520           0 :          (pos (point))
     521             :          ;; What prefix should we check for (nil means don't).
     522           0 :          (prefix (cond ((stringp arg) arg)
     523           0 :                        (arg nil)
     524           0 :                        (t fill-prefix)))
     525             :          ;; Does this line start with it?
     526           0 :          (have-prfx (and prefix
     527           0 :                          (save-excursion
     528           0 :                            (beginning-of-line)
     529           0 :                            (looking-at (regexp-quote prefix))))))
     530           0 :     (newline 1)
     531           0 :     (if have-prfx (insert-and-inherit prefix))
     532           0 :     (indent-to col 0)
     533           0 :     (goto-char pos)))
     534             : 
     535             : (defun delete-indentation (&optional arg)
     536             :   "Join this line to previous and fix up whitespace at join.
     537             : If there is a fill prefix, delete it from the beginning of this line.
     538             : With argument, join this line to following line."
     539             :   (interactive "*P")
     540           0 :   (beginning-of-line)
     541           0 :   (if arg (forward-line 1))
     542           0 :   (if (eq (preceding-char) ?\n)
     543           0 :       (progn
     544           0 :         (delete-region (point) (1- (point)))
     545             :         ;; If the second line started with the fill prefix,
     546             :         ;; delete the prefix.
     547           0 :         (if (and fill-prefix
     548           0 :                  (<= (+ (point) (length fill-prefix)) (point-max))
     549           0 :                  (string= fill-prefix
     550           0 :                           (buffer-substring (point)
     551           0 :                                             (+ (point) (length fill-prefix)))))
     552           0 :             (delete-region (point) (+ (point) (length fill-prefix))))
     553           0 :         (fixup-whitespace))))
     554             : 
     555             : (defalias 'join-line #'delete-indentation) ; easier to find
     556             : 
     557             : (defun delete-blank-lines ()
     558             :   "On blank line, delete all surrounding blank lines, leaving just one.
     559             : On isolated blank line, delete that one.
     560             : On nonblank line, delete any immediately following blank lines."
     561             :   (interactive "*")
     562           0 :   (let (thisblank singleblank)
     563           0 :     (save-excursion
     564           0 :       (beginning-of-line)
     565           0 :       (setq thisblank (looking-at "[ \t]*$"))
     566             :       ;; Set singleblank if there is just one blank line here.
     567           0 :       (setq singleblank
     568           0 :             (and thisblank
     569           0 :                  (not (looking-at "[ \t]*\n[ \t]*$"))
     570           0 :                  (or (bobp)
     571           0 :                      (progn (forward-line -1)
     572           0 :                             (not (looking-at "[ \t]*$")))))))
     573             :     ;; Delete preceding blank lines, and this one too if it's the only one.
     574           0 :     (if thisblank
     575           0 :         (progn
     576           0 :           (beginning-of-line)
     577           0 :           (if singleblank (forward-line 1))
     578           0 :           (delete-region (point)
     579           0 :                          (if (re-search-backward "[^ \t\n]" nil t)
     580           0 :                              (progn (forward-line 1) (point))
     581           0 :                            (point-min)))))
     582             :     ;; Delete following blank lines, unless the current line is blank
     583             :     ;; and there are no following blank lines.
     584           0 :     (if (not (and thisblank singleblank))
     585           0 :         (save-excursion
     586           0 :           (end-of-line)
     587           0 :           (forward-line 1)
     588           0 :           (delete-region (point)
     589           0 :                          (if (re-search-forward "[^ \t\n]" nil t)
     590           0 :                              (progn (beginning-of-line) (point))
     591           0 :                            (point-max)))))
     592             :     ;; Handle the special case where point is followed by newline and eob.
     593             :     ;; Delete the line, leaving point at eob.
     594           0 :     (if (looking-at "^[ \t]*\n\\'")
     595           0 :         (delete-region (point) (point-max)))))
     596             : 
     597             : (defcustom delete-trailing-lines t
     598             :   "If non-nil, \\[delete-trailing-whitespace] deletes trailing lines.
     599             : Trailing lines are deleted only if `delete-trailing-whitespace'
     600             : is called on the entire buffer (rather than an active region)."
     601             :   :type 'boolean
     602             :   :group 'editing
     603             :   :version "24.3")
     604             : 
     605             : (defun region-modifiable-p (start end)
     606             :   "Return non-nil if the region contains no read-only text."
     607           0 :   (and (not (get-text-property start 'read-only))
     608           0 :        (eq end (next-single-property-change start 'read-only nil end))))
     609             : 
     610             : (defun delete-trailing-whitespace (&optional start end)
     611             :   "Delete trailing whitespace between START and END.
     612             : If called interactively, START and END are the start/end of the
     613             : region if the mark is active, or of the buffer's accessible
     614             : portion if the mark is inactive.
     615             : 
     616             : This command deletes whitespace characters after the last
     617             : non-whitespace character in each line between START and END.  It
     618             : does not consider formfeed characters to be whitespace.
     619             : 
     620             : If this command acts on the entire buffer (i.e. if called
     621             : interactively with the mark inactive, or called from Lisp with
     622             : END nil), it also deletes all trailing lines at the end of the
     623             : buffer if the variable `delete-trailing-lines' is non-nil."
     624           0 :   (interactive (progn
     625           0 :                  (barf-if-buffer-read-only)
     626           0 :                  (if (use-region-p)
     627           0 :                      (list (region-beginning) (region-end))
     628           0 :                    (list nil nil))))
     629           0 :   (save-match-data
     630           0 :     (save-excursion
     631           0 :       (let ((end-marker (and end (copy-marker end))))
     632           0 :         (goto-char (or start (point-min)))
     633           0 :         (with-syntax-table (make-syntax-table (syntax-table))
     634             :           ;; Don't delete formfeeds, even if they are considered whitespace.
     635           0 :           (modify-syntax-entry ?\f "_")
     636           0 :           (while (re-search-forward "\\s-$" end-marker t)
     637           0 :             (skip-syntax-backward "-" (line-beginning-position))
     638           0 :             (let ((b (point)) (e (match-end 0)))
     639           0 :               (when (region-modifiable-p b e)
     640           0 :                 (delete-region b e)))))
     641           0 :         (if end
     642           0 :             (set-marker end-marker nil)
     643             :           ;; Delete trailing empty lines.
     644           0 :           (and delete-trailing-lines
     645             :                ;; Really the end of buffer.
     646           0 :                (= (goto-char (point-max)) (1+ (buffer-size)))
     647           0 :                (<= (skip-chars-backward "\n") -2)
     648           0 :                (region-modifiable-p (1+ (point)) (point-max))
     649           0 :                (delete-region (1+ (point)) (point-max)))))))
     650             :   ;; Return nil for the benefit of `write-file-functions'.
     651             :   nil)
     652             : 
     653             : (defun newline-and-indent ()
     654             :   "Insert a newline, then indent according to major mode.
     655             : Indentation is done using the value of `indent-line-function'.
     656             : In programming language modes, this is the same as TAB.
     657             : In some text modes, where TAB inserts a tab, this command indents to the
     658             : column specified by the function `current-left-margin'."
     659             :   (interactive "*")
     660           0 :   (delete-horizontal-space t)
     661           0 :   (newline nil t)
     662           0 :   (indent-according-to-mode))
     663             : 
     664             : (defun reindent-then-newline-and-indent ()
     665             :   "Reindent current line, insert newline, then indent the new line.
     666             : Indentation of both lines is done according to the current major mode,
     667             : which means calling the current value of `indent-line-function'.
     668             : In programming language modes, this is the same as TAB.
     669             : In some text modes, where TAB inserts a tab, this indents to the
     670             : column specified by the function `current-left-margin'."
     671             :   (interactive "*")
     672           0 :   (let ((pos (point)))
     673             :     ;; Be careful to insert the newline before indenting the line.
     674             :     ;; Otherwise, the indentation might be wrong.
     675           0 :     (newline)
     676           0 :     (save-excursion
     677           0 :       (goto-char pos)
     678             :       ;; We are at EOL before the call to indent-according-to-mode, and
     679             :       ;; after it we usually are as well, but not always.  We tried to
     680             :       ;; address it with `save-excursion' but that uses a normal marker
     681             :       ;; whereas we need `move after insertion', so we do the save/restore
     682             :       ;; by hand.
     683           0 :       (setq pos (copy-marker pos t))
     684           0 :       (indent-according-to-mode)
     685           0 :       (goto-char pos)
     686             :       ;; Remove the trailing white-space after indentation because
     687             :       ;; indentation may introduce the whitespace.
     688           0 :       (delete-horizontal-space t))
     689           0 :     (indent-according-to-mode)))
     690             : 
     691             : (defcustom read-quoted-char-radix 8
     692             :   "Radix for \\[quoted-insert] and other uses of `read-quoted-char'.
     693             : Legitimate radix values are 8, 10 and 16."
     694             :  :type '(choice (const 8) (const 10) (const 16))
     695             :  :group 'editing-basics)
     696             : 
     697             : (defun read-quoted-char (&optional prompt)
     698             :   "Like `read-char', but do not allow quitting.
     699             : Also, if the first character read is an octal digit,
     700             : we read any number of octal digits and return the
     701             : specified character code.  Any nondigit terminates the sequence.
     702             : If the terminator is RET, it is discarded;
     703             : any other terminator is used itself as input.
     704             : 
     705             : The optional argument PROMPT specifies a string to use to prompt the user.
     706             : The variable `read-quoted-char-radix' controls which radix to use
     707             : for numeric input."
     708           0 :   (let ((message-log-max nil)
     709           0 :         (help-events (delq nil (mapcar (lambda (c) (unless (characterp c) c))
     710           0 :                                        help-event-list)))
     711             :         done (first t) (code 0) char translated)
     712           0 :     (while (not done)
     713           0 :       (let ((inhibit-quit first)
     714             :             ;; Don't let C-h or other help chars get the help
     715             :             ;; message--only help function keys.  See bug#16617.
     716             :             (help-char nil)
     717           0 :             (help-event-list help-events)
     718             :             (help-form
     719             :              "Type the special character you want to use,
     720             : or the octal character code.
     721             : RET terminates the character code and is discarded;
     722             : any other non-digit terminates the character code and is then used as input."))
     723           0 :         (setq char (read-event (and prompt (format "%s-" prompt)) t))
     724           0 :         (if inhibit-quit (setq quit-flag nil)))
     725             :       ;; Translate TAB key into control-I ASCII character, and so on.
     726             :       ;; Note: `read-char' does it using the `ascii-character' property.
     727             :       ;; We tried using read-key instead, but that disables the keystroke
     728             :       ;; echo produced by 'C-q', see bug#24635.
     729           0 :       (let ((translation (lookup-key local-function-key-map (vector char))))
     730           0 :         (setq translated (if (arrayp translation)
     731           0 :                              (aref translation 0)
     732           0 :                            char)))
     733           0 :       (if (integerp translated)
     734           0 :           (setq translated (char-resolve-modifiers translated)))
     735           0 :       (cond ((null translated))
     736           0 :             ((not (integerp translated))
     737           0 :              (setq unread-command-events (list char)
     738           0 :                    done t))
     739           0 :             ((/= (logand translated ?\M-\^@) 0)
     740             :              ;; Turn a meta-character into a character with the 0200 bit set.
     741           0 :              (setq code (logior (logand translated (lognot ?\M-\^@)) 128)
     742           0 :                    done t))
     743           0 :             ((and (<= ?0 translated)
     744           0 :                   (< translated (+ ?0 (min 10 read-quoted-char-radix))))
     745           0 :              (setq code (+ (* code read-quoted-char-radix) (- translated ?0)))
     746           0 :              (and prompt (setq prompt (message "%s %c" prompt translated))))
     747           0 :             ((and (<= ?a (downcase translated))
     748           0 :                   (< (downcase translated)
     749           0 :                      (+ ?a -10 (min 36 read-quoted-char-radix))))
     750           0 :              (setq code (+ (* code read-quoted-char-radix)
     751           0 :                            (+ 10 (- (downcase translated) ?a))))
     752           0 :              (and prompt (setq prompt (message "%s %c" prompt translated))))
     753           0 :             ((and (not first) (eq translated ?\C-m))
     754           0 :              (setq done t))
     755           0 :             ((not first)
     756           0 :              (setq unread-command-events (list char)
     757           0 :                    done t))
     758           0 :             (t (setq code translated
     759           0 :                      done t)))
     760           0 :       (setq first nil))
     761           0 :     code))
     762             : 
     763             : (defun quoted-insert (arg)
     764             :   "Read next input character and insert it.
     765             : This is useful for inserting control characters.
     766             : With argument, insert ARG copies of the character.
     767             : 
     768             : If the first character you type after this command is an octal digit,
     769             : you should type a sequence of octal digits which specify a character code.
     770             : Any nondigit terminates the sequence.  If the terminator is a RET,
     771             : it is discarded; any other terminator is used itself as input.
     772             : The variable `read-quoted-char-radix' specifies the radix for this feature;
     773             : set it to 10 or 16 to use decimal or hex instead of octal.
     774             : 
     775             : In overwrite mode, this function inserts the character anyway, and
     776             : does not handle octal digits specially.  This means that if you use
     777             : overwrite as your normal editing mode, you can use this function to
     778             : insert characters when necessary.
     779             : 
     780             : In binary overwrite mode, this function does overwrite, and octal
     781             : digits are interpreted as a character code.  This is intended to be
     782             : useful for editing binary files."
     783             :   (interactive "*p")
     784           0 :   (let* ((char
     785             :           ;; Avoid "obsolete" warnings for translation-table-for-input.
     786           0 :           (with-no-warnings
     787           0 :             (let (translation-table-for-input input-method-function)
     788           0 :               (if (or (not overwrite-mode)
     789           0 :                       (eq overwrite-mode 'overwrite-mode-binary))
     790           0 :                   (read-quoted-char)
     791           0 :                 (read-char))))))
     792             :     ;; This used to assume character codes 0240 - 0377 stand for
     793             :     ;; characters in some single-byte character set, and converted them
     794             :     ;; to Emacs characters.  But in 23.1 this feature is deprecated
     795             :     ;; in favor of inserting the corresponding Unicode characters.
     796             :     ;; (if (and enable-multibyte-characters
     797             :     ;;          (>= char ?\240)
     798             :     ;;          (<= char ?\377))
     799             :     ;;     (setq char (unibyte-char-to-multibyte char)))
     800           0 :     (unless (characterp char)
     801           0 :       (user-error "%s is not a valid character"
     802           0 :                   (key-description (vector char))))
     803           0 :     (if (> arg 0)
     804           0 :         (if (eq overwrite-mode 'overwrite-mode-binary)
     805           0 :             (delete-char arg)))
     806           0 :     (while (> arg 0)
     807           0 :       (insert-and-inherit char)
     808           0 :       (setq arg (1- arg)))))
     809             : 
     810             : (defun forward-to-indentation (&optional arg)
     811             :   "Move forward ARG lines and position at first nonblank character."
     812             :   (interactive "^p")
     813           0 :   (forward-line (or arg 1))
     814           0 :   (skip-chars-forward " \t"))
     815             : 
     816             : (defun backward-to-indentation (&optional arg)
     817             :   "Move backward ARG lines and position at first nonblank character."
     818             :   (interactive "^p")
     819           0 :   (forward-line (- (or arg 1)))
     820           0 :   (skip-chars-forward " \t"))
     821             : 
     822             : (defun back-to-indentation ()
     823             :   "Move point to the first non-whitespace character on this line."
     824             :   (interactive "^")
     825         404 :   (beginning-of-line 1)
     826         404 :   (skip-syntax-forward " " (line-end-position))
     827             :   ;; Move back over chars that have whitespace syntax but have the p flag.
     828         404 :   (backward-prefix-chars))
     829             : 
     830             : (defun fixup-whitespace ()
     831             :   "Fixup white space between objects around point.
     832             : Leave one space or none, according to the context."
     833             :   (interactive "*")
     834           0 :   (save-excursion
     835           0 :     (delete-horizontal-space)
     836           0 :     (if (or (looking-at "^\\|$\\|\\s)")
     837           0 :             (save-excursion (forward-char -1)
     838           0 :                             (looking-at "$\\|\\s(\\|\\s'")))
     839             :         nil
     840           0 :       (insert ?\s))))
     841             : 
     842             : (defun delete-horizontal-space (&optional backward-only)
     843             :   "Delete all spaces and tabs around point.
     844             : If BACKWARD-ONLY is non-nil, only delete them before point."
     845             :   (interactive "*P")
     846           0 :   (let ((orig-pos (point)))
     847           0 :     (delete-region
     848           0 :      (if backward-only
     849           0 :          orig-pos
     850           0 :        (progn
     851           0 :          (skip-chars-forward " \t")
     852           0 :          (constrain-to-field nil orig-pos t)))
     853           0 :      (progn
     854           0 :        (skip-chars-backward " \t")
     855           0 :        (constrain-to-field nil orig-pos)))))
     856             : 
     857             : (defun just-one-space (&optional n)
     858             :   "Delete all spaces and tabs around point, leaving one space (or N spaces).
     859             : If N is negative, delete newlines as well, leaving -N spaces.
     860             : See also `cycle-spacing'."
     861             :   (interactive "*p")
     862           0 :   (cycle-spacing n nil 'single-shot))
     863             : 
     864             : (defvar cycle-spacing--context nil
     865             :   "Store context used in consecutive calls to `cycle-spacing' command.
     866             : The first time `cycle-spacing' runs, it saves in this variable:
     867             : its N argument, the original point position, and the original spacing
     868             : around point.")
     869             : 
     870             : (defun cycle-spacing (&optional n preserve-nl-back mode)
     871             :   "Manipulate whitespace around point in a smart way.
     872             : In interactive use, this function behaves differently in successive
     873             : consecutive calls.
     874             : 
     875             : The first call in a sequence acts like `just-one-space'.
     876             : It deletes all spaces and tabs around point, leaving one space
     877             : \(or N spaces).  N is the prefix argument.  If N is negative,
     878             : it deletes newlines as well, leaving -N spaces.
     879             : \(If PRESERVE-NL-BACK is non-nil, it does not delete newlines before point.)
     880             : 
     881             : The second call in a sequence deletes all spaces.
     882             : 
     883             : The third call in a sequence restores the original whitespace (and point).
     884             : 
     885             : If MODE is `single-shot', it only performs the first step in the sequence.
     886             : If MODE is `fast' and the first step would not result in any change
     887             : \(i.e., there are exactly (abs N) spaces around point),
     888             : the function goes straight to the second step.
     889             : 
     890             : Repeatedly calling the function with different values of N starts a
     891             : new sequence each time."
     892             :   (interactive "*p")
     893           0 :   (let ((orig-pos        (point))
     894           0 :         (skip-characters (if (and n (< n 0)) " \t\n\r" " \t"))
     895           0 :         (num             (abs (or n 1))))
     896           0 :     (skip-chars-backward (if preserve-nl-back " \t" skip-characters))
     897           0 :     (constrain-to-field nil orig-pos)
     898           0 :     (cond
     899             :      ;; Command run for the first time, single-shot mode or different argument
     900           0 :      ((or (eq 'single-shot mode)
     901           0 :           (not (equal last-command this-command))
     902           0 :           (not cycle-spacing--context)
     903           0 :           (not (eq (car cycle-spacing--context) n)))
     904           0 :       (let* ((start (point))
     905           0 :              (num   (- num (skip-chars-forward " " (+ num (point)))))
     906           0 :              (mid   (point))
     907           0 :              (end   (progn
     908           0 :                       (skip-chars-forward skip-characters)
     909           0 :                       (constrain-to-field nil orig-pos t))))
     910           0 :         (setq cycle-spacing--context  ;; Save for later.
     911             :               ;; Special handling for case where there was no space at all.
     912           0 :               (unless (= start end)
     913           0 :                 (cons n (cons orig-pos (buffer-substring start (point))))))
     914             :         ;; If this run causes no change in buffer content, delete all spaces,
     915             :         ;; otherwise delete all excess spaces.
     916           0 :         (delete-region (if (and (eq mode 'fast) (zerop num) (= mid end))
     917           0 :                            start mid) end)
     918           0 :         (insert (make-string num ?\s))))
     919             : 
     920             :      ;; Command run for the second time.
     921           0 :      ((not (equal orig-pos (point)))
     922           0 :       (delete-region (point) orig-pos))
     923             : 
     924             :      ;; Command run for the third time.
     925             :      (t
     926           0 :       (insert (cddr cycle-spacing--context))
     927           0 :       (goto-char (cadr cycle-spacing--context))
     928           0 :       (setq cycle-spacing--context nil)))))
     929             : 
     930             : (defun beginning-of-buffer (&optional arg)
     931             :   "Move point to the beginning of the buffer.
     932             : With numeric arg N, put point N/10 of the way from the beginning.
     933             : If the buffer is narrowed, this command uses the beginning of the
     934             : accessible part of the buffer.
     935             : 
     936             : Push mark at previous position, unless either a \\[universal-argument] prefix
     937             : is supplied, or Transient Mark mode is enabled and the mark is active."
     938             :   (declare (interactive-only "use `(goto-char (point-min))' instead."))
     939             :   (interactive "^P")
     940           0 :   (or (consp arg)
     941           0 :       (region-active-p)
     942           0 :       (push-mark))
     943           0 :   (let ((size (- (point-max) (point-min))))
     944           0 :     (goto-char (if (and arg (not (consp arg)))
     945           0 :                    (+ (point-min)
     946           0 :                       (if (> size 10000)
     947             :                           ;; Avoid overflow for large buffer sizes!
     948           0 :                           (* (prefix-numeric-value arg)
     949           0 :                              (/ size 10))
     950           0 :                         (/ (+ 10 (* size (prefix-numeric-value arg))) 10)))
     951           0 :                  (point-min))))
     952           0 :   (if (and arg (not (consp arg))) (forward-line 1)))
     953             : 
     954             : (defun end-of-buffer (&optional arg)
     955             :   "Move point to the end of the buffer.
     956             : With numeric arg N, put point N/10 of the way from the end.
     957             : If the buffer is narrowed, this command uses the end of the
     958             : accessible part of the buffer.
     959             : 
     960             : Push mark at previous position, unless either a \\[universal-argument] prefix
     961             : is supplied, or Transient Mark mode is enabled and the mark is active."
     962             :   (declare (interactive-only "use `(goto-char (point-max))' instead."))
     963             :   (interactive "^P")
     964           0 :   (or (consp arg) (region-active-p) (push-mark))
     965           0 :   (let ((size (- (point-max) (point-min))))
     966           0 :     (goto-char (if (and arg (not (consp arg)))
     967           0 :                    (- (point-max)
     968           0 :                       (if (> size 10000)
     969             :                           ;; Avoid overflow for large buffer sizes!
     970           0 :                           (* (prefix-numeric-value arg)
     971           0 :                              (/ size 10))
     972           0 :                         (/ (* size (prefix-numeric-value arg)) 10)))
     973           0 :                  (point-max))))
     974             :   ;; If we went to a place in the middle of the buffer,
     975             :   ;; adjust it to the beginning of a line.
     976           0 :   (cond ((and arg (not (consp arg))) (forward-line 1))
     977           0 :         ((and (eq (current-buffer) (window-buffer))
     978           0 :               (> (point) (window-end nil t)))
     979             :          ;; If the end of the buffer is not already on the screen,
     980             :          ;; then scroll specially to put it near, but not at, the bottom.
     981           0 :          (overlay-recenter (point))
     982           0 :          (recenter -3))))
     983             : 
     984             : (defcustom delete-active-region t
     985             :   "Whether single-char deletion commands delete an active region.
     986             : This has an effect only if Transient Mark mode is enabled, and
     987             : affects `delete-forward-char' and `delete-backward-char', though
     988             : not `delete-char'.
     989             : 
     990             : If the value is the symbol `kill', the active region is killed
     991             : instead of deleted."
     992             :   :type '(choice (const :tag "Delete active region" t)
     993             :                  (const :tag "Kill active region" kill)
     994             :                  (const :tag "Do ordinary deletion" nil))
     995             :   :group 'killing
     996             :   :version "24.1")
     997             : 
     998             : (defvar region-extract-function
     999             :   (lambda (method)
    1000             :     (when (region-beginning)
    1001             :       (cond
    1002             :        ((eq method 'bounds)
    1003             :         (list (cons (region-beginning) (region-end))))
    1004             :        ((eq method 'delete-only)
    1005             :         (delete-region (region-beginning) (region-end)))
    1006             :        (t
    1007             :         (filter-buffer-substring (region-beginning) (region-end) method)))))
    1008             :   "Function to get the region's content.
    1009             : Called with one argument METHOD.
    1010             : If METHOD is `delete-only', then delete the region; the return value
    1011             : is undefined.  If METHOD is nil, then return the content as a string.
    1012             : If METHOD is `bounds', then return the boundaries of the region
    1013             : as a list of the form (START . END).
    1014             : If METHOD is anything else, delete the region and return its content
    1015             : as a string, after filtering it with `filter-buffer-substring', which
    1016             : is called with METHOD as its 3rd argument.")
    1017             : 
    1018             : (defvar region-insert-function
    1019             :   (lambda (lines)
    1020             :     (let ((first t))
    1021             :       (while lines
    1022             :         (or first
    1023             :             (insert ?\n))
    1024             :         (insert-for-yank (car lines))
    1025             :         (setq lines (cdr lines)
    1026             :               first nil))))
    1027             :   "Function to insert the region's content.
    1028             : Called with one argument LINES.
    1029             : Insert the region as a list of lines.")
    1030             : 
    1031             : (defun delete-backward-char (n &optional killflag)
    1032             :   "Delete the previous N characters (following if N is negative).
    1033             : If Transient Mark mode is enabled, the mark is active, and N is 1,
    1034             : delete the text in the region and deactivate the mark instead.
    1035             : To disable this, set option `delete-active-region' to nil.
    1036             : 
    1037             : Optional second arg KILLFLAG, if non-nil, means to kill (save in
    1038             : kill ring) instead of delete.  Interactively, N is the prefix
    1039             : arg, and KILLFLAG is set if N is explicitly specified.
    1040             : 
    1041             : When killing, the killed text is filtered by
    1042             : `filter-buffer-substring' before it is saved in the kill ring, so
    1043             : the actual saved text might be different from what was killed.
    1044             : 
    1045             : In Overwrite mode, single character backward deletion may replace
    1046             : tabs with spaces so as to back over columns, unless point is at
    1047             : the end of the line."
    1048             :   (declare (interactive-only delete-char))
    1049             :   (interactive "p\nP")
    1050           0 :   (unless (integerp n)
    1051           0 :     (signal 'wrong-type-argument (list 'integerp n)))
    1052           0 :   (cond ((and (use-region-p)
    1053           0 :               delete-active-region
    1054           0 :               (= n 1))
    1055             :          ;; If a region is active, kill or delete it.
    1056           0 :          (if (eq delete-active-region 'kill)
    1057           0 :              (kill-region (region-beginning) (region-end) 'region)
    1058           0 :            (funcall region-extract-function 'delete-only)))
    1059             :         ;; In Overwrite mode, maybe untabify while deleting
    1060           0 :         ((null (or (null overwrite-mode)
    1061           0 :                    (<= n 0)
    1062           0 :                    (memq (char-before) '(?\t ?\n))
    1063           0 :                    (eobp)
    1064           0 :                    (eq (char-after) ?\n)))
    1065           0 :          (let ((ocol (current-column)))
    1066           0 :            (delete-char (- n) killflag)
    1067           0 :            (save-excursion
    1068           0 :              (insert-char ?\s (- ocol (current-column)) nil))))
    1069             :         ;; Otherwise, do simple deletion.
    1070           0 :         (t (delete-char (- n) killflag))))
    1071             : 
    1072             : (defun delete-forward-char (n &optional killflag)
    1073             :   "Delete the following N characters (previous if N is negative).
    1074             : If Transient Mark mode is enabled, the mark is active, and N is 1,
    1075             : delete the text in the region and deactivate the mark instead.
    1076             : To disable this, set variable `delete-active-region' to nil.
    1077             : 
    1078             : Optional second arg KILLFLAG non-nil means to kill (save in kill
    1079             : ring) instead of delete.  Interactively, N is the prefix arg, and
    1080             : KILLFLAG is set if N was explicitly specified.
    1081             : 
    1082             : When killing, the killed text is filtered by
    1083             : `filter-buffer-substring' before it is saved in the kill ring, so
    1084             : the actual saved text might be different from what was killed."
    1085             :   (declare (interactive-only delete-char))
    1086             :   (interactive "p\nP")
    1087           0 :   (unless (integerp n)
    1088           0 :     (signal 'wrong-type-argument (list 'integerp n)))
    1089           0 :   (cond ((and (use-region-p)
    1090           0 :               delete-active-region
    1091           0 :               (= n 1))
    1092             :          ;; If a region is active, kill or delete it.
    1093           0 :          (if (eq delete-active-region 'kill)
    1094           0 :              (kill-region (region-beginning) (region-end) 'region)
    1095           0 :            (funcall region-extract-function 'delete-only)))
    1096             : 
    1097             :         ;; Otherwise, do simple deletion.
    1098           0 :         (t (delete-char n killflag))))
    1099             : 
    1100             : (defun mark-whole-buffer ()
    1101             :   "Put point at beginning and mark at end of buffer.
    1102             : If narrowing is in effect, only uses the accessible part of the buffer.
    1103             : You probably should not use this function in Lisp programs;
    1104             : it is usually a mistake for a Lisp function to use any subroutine
    1105             : that uses or sets the mark."
    1106             :   (declare (interactive-only t))
    1107             :   (interactive)
    1108           0 :   (push-mark)
    1109           0 :   (push-mark (point-max) nil t)
    1110             :   ;; This is really `point-min' in most cases, but if we're in the
    1111             :   ;; minibuffer, this is at the end of the prompt.
    1112           0 :   (goto-char (minibuffer-prompt-end)))
    1113             : 
    1114             : 
    1115             : ;; Counting lines, one way or another.
    1116             : 
    1117             : (defun goto-line (line &optional buffer)
    1118             :   "Go to LINE, counting from line 1 at beginning of buffer.
    1119             : If called interactively, a numeric prefix argument specifies
    1120             : LINE; without a numeric prefix argument, read LINE from the
    1121             : minibuffer.
    1122             : 
    1123             : If optional argument BUFFER is non-nil, switch to that buffer and
    1124             : move to line LINE there.  If called interactively with \\[universal-argument]
    1125             : as argument, BUFFER is the most recently selected other buffer.
    1126             : 
    1127             : Prior to moving point, this function sets the mark (without
    1128             : activating it), unless Transient Mark mode is enabled and the
    1129             : mark is already active.
    1130             : 
    1131             : This function is usually the wrong thing to use in a Lisp program.
    1132             : What you probably want instead is something like:
    1133             :   (goto-char (point-min))
    1134             :   (forward-line (1- N))
    1135             : If at all possible, an even better solution is to use char counts
    1136             : rather than line counts."
    1137             :   (declare (interactive-only forward-line))
    1138             :   (interactive
    1139           0 :    (if (and current-prefix-arg (not (consp current-prefix-arg)))
    1140           0 :        (list (prefix-numeric-value current-prefix-arg))
    1141             :      ;; Look for a default, a number in the buffer at point.
    1142           0 :      (let* ((default
    1143           0 :               (save-excursion
    1144           0 :                 (skip-chars-backward "0-9")
    1145           0 :                 (if (looking-at "[0-9]")
    1146           0 :                     (string-to-number
    1147           0 :                      (buffer-substring-no-properties
    1148           0 :                       (point)
    1149           0 :                       (progn (skip-chars-forward "0-9")
    1150           0 :                              (point)))))))
    1151             :             ;; Decide if we're switching buffers.
    1152             :             (buffer
    1153           0 :              (if (consp current-prefix-arg)
    1154           0 :                  (other-buffer (current-buffer) t)))
    1155             :             (buffer-prompt
    1156           0 :              (if buffer
    1157           0 :                  (concat " in " (buffer-name buffer))
    1158           0 :                "")))
    1159             :        ;; Read the argument, offering that number (if any) as default.
    1160           0 :        (list (read-number (format "Goto line%s: " buffer-prompt)
    1161           0 :                           (list default (line-number-at-pos)))
    1162           0 :              buffer))))
    1163             :   ;; Switch to the desired buffer, one way or another.
    1164           0 :   (if buffer
    1165           0 :       (let ((window (get-buffer-window buffer)))
    1166           0 :         (if window (select-window window)
    1167           0 :           (switch-to-buffer-other-window buffer))))
    1168             :   ;; Leave mark at previous position
    1169           0 :   (or (region-active-p) (push-mark))
    1170             :   ;; Move to the specified line number in that buffer.
    1171           0 :   (save-restriction
    1172           0 :     (widen)
    1173           0 :     (goto-char (point-min))
    1174           0 :     (if (eq selective-display t)
    1175           0 :         (re-search-forward "[\n\C-m]" nil 'end (1- line))
    1176           0 :       (forward-line (1- line)))))
    1177             : 
    1178             : (defun count-words-region (start end &optional arg)
    1179             :   "Count the number of words in the region.
    1180             : If called interactively, print a message reporting the number of
    1181             : lines, words, and characters in the region (whether or not the
    1182             : region is active); with prefix ARG, report for the entire buffer
    1183             : rather than the region.
    1184             : 
    1185             : If called from Lisp, return the number of words between positions
    1186             : START and END."
    1187           0 :   (interactive (if current-prefix-arg
    1188           0 :                    (list nil nil current-prefix-arg)
    1189           0 :                  (list (region-beginning) (region-end) nil)))
    1190           0 :   (cond ((not (called-interactively-p 'any))
    1191           0 :          (count-words start end))
    1192           0 :         (arg
    1193           0 :          (count-words--buffer-message))
    1194             :         (t
    1195           0 :          (count-words--message "Region" start end))))
    1196             : 
    1197             : (defun count-words (start end)
    1198             :   "Count words between START and END.
    1199             : If called interactively, START and END are normally the start and
    1200             : end of the buffer; but if the region is active, START and END are
    1201             : the start and end of the region.  Print a message reporting the
    1202             : number of lines, words, and chars.
    1203             : 
    1204             : If called from Lisp, return the number of words between START and
    1205             : END, without printing any message."
    1206           0 :   (interactive (list nil nil))
    1207           0 :   (cond ((not (called-interactively-p 'any))
    1208           0 :          (let ((words 0))
    1209           0 :            (save-excursion
    1210           0 :              (save-restriction
    1211           0 :                (narrow-to-region start end)
    1212           0 :                (goto-char (point-min))
    1213           0 :                (while (forward-word-strictly 1)
    1214           0 :                  (setq words (1+ words)))))
    1215           0 :            words))
    1216           0 :         ((use-region-p)
    1217           0 :          (call-interactively 'count-words-region))
    1218             :         (t
    1219           0 :          (count-words--buffer-message))))
    1220             : 
    1221             : (defun count-words--buffer-message ()
    1222           0 :   (count-words--message
    1223           0 :    (if (buffer-narrowed-p) "Narrowed part of buffer" "Buffer")
    1224           0 :    (point-min) (point-max)))
    1225             : 
    1226             : (defun count-words--message (str start end)
    1227           0 :   (let ((lines (count-lines start end))
    1228           0 :         (words (count-words start end))
    1229           0 :         (chars (- end start)))
    1230           0 :     (message "%s has %d line%s, %d word%s, and %d character%s."
    1231           0 :              str
    1232           0 :              lines (if (= lines 1) "" "s")
    1233           0 :              words (if (= words 1) "" "s")
    1234           0 :              chars (if (= chars 1) "" "s"))))
    1235             : 
    1236             : (define-obsolete-function-alias 'count-lines-region 'count-words-region "24.1")
    1237             : 
    1238             : (defun what-line ()
    1239             :   "Print the current buffer line number and narrowed line number of point."
    1240             :   (interactive)
    1241           0 :   (let ((start (point-min))
    1242           0 :         (n (line-number-at-pos)))
    1243           0 :     (if (= start 1)
    1244           0 :         (message "Line %d" n)
    1245           0 :       (save-excursion
    1246           0 :         (save-restriction
    1247           0 :           (widen)
    1248           0 :           (message "line %d (narrowed line %d)"
    1249           0 :                    (+ n (line-number-at-pos start) -1) n))))))
    1250             : 
    1251             : (defun count-lines (start end)
    1252             :   "Return number of lines between START and END.
    1253             : This is usually the number of newlines between them,
    1254             : but can be one more if START is not equal to END
    1255             : and the greater of them is not at the start of a line."
    1256        7152 :   (save-excursion
    1257        7152 :     (save-restriction
    1258        7152 :       (narrow-to-region start end)
    1259        7152 :       (goto-char (point-min))
    1260        7152 :       (if (eq selective-display t)
    1261           0 :           (save-match-data
    1262           0 :             (let ((done 0))
    1263           0 :                      (while (re-search-forward "[\n\C-m]" nil t 40)
    1264           0 :                        (setq done (+ 40 done)))
    1265           0 :                      (while (re-search-forward "[\n\C-m]" nil t 1)
    1266           0 :                        (setq done (+ 1 done)))
    1267           0 :                      (goto-char (point-max))
    1268           0 :                      (if (and (/= start end)
    1269           0 :                        (not (bolp)))
    1270           0 :                   (1+ done)
    1271           0 :                 done)))
    1272        7152 :         (- (buffer-size) (forward-line (buffer-size)))))))
    1273             : 
    1274             : (defun line-number-at-pos (&optional pos absolute)
    1275             :   "Return buffer line number at position POS.
    1276             : If POS is nil, use current buffer location.
    1277             : 
    1278             : If ABSOLUTE is nil, the default, counting starts
    1279             : at (point-min), so the value refers to the contents of the
    1280             : accessible portion of the (potentially narrowed) buffer.  If
    1281             : ABSOLUTE is non-nil, ignore any narrowing and return the
    1282             : absolute line number."
    1283        7153 :   (save-restriction
    1284        7153 :     (when absolute
    1285        7153 :       (widen))
    1286        7153 :     (let ((opoint (or pos (point))) start)
    1287        7153 :       (save-excursion
    1288        7153 :         (goto-char (point-min))
    1289        7153 :         (setq start (point))
    1290        7153 :         (goto-char opoint)
    1291        7153 :         (forward-line 0)
    1292        7153 :         (1+ (count-lines start (point)))))))
    1293             : 
    1294             : (defun what-cursor-position (&optional detail)
    1295             :   "Print info on cursor position (on screen and within buffer).
    1296             : Also describe the character after point, and give its character code
    1297             : in octal, decimal and hex.
    1298             : 
    1299             : For a non-ASCII multibyte character, also give its encoding in the
    1300             : buffer's selected coding system if the coding system encodes the
    1301             : character safely.  If the character is encoded into one byte, that
    1302             : code is shown in hex.  If the character is encoded into more than one
    1303             : byte, just \"...\" is shown.
    1304             : 
    1305             : In addition, with prefix argument, show details about that character
    1306             : in *Help* buffer.  See also the command `describe-char'."
    1307             :   (interactive "P")
    1308           0 :   (let* ((char (following-char))
    1309             :          (bidi-fixer
    1310             :           ;; If the character is one of LRE, LRO, RLE, RLO, it will
    1311             :           ;; start a directional embedding, which could completely
    1312             :           ;; disrupt the rest of the line (e.g., RLO will display the
    1313             :           ;; rest of the line right-to-left).  So we put an invisible
    1314             :           ;; PDF character after these characters, to end the
    1315             :           ;; embedding, which eliminates any effects on the rest of
    1316             :           ;; the line.  For RLE and RLO we also append an invisible
    1317             :           ;; LRM, to avoid reordering the following numerical
    1318             :           ;; characters.  For LRI/RLI/FSI we append a PDI.
    1319           0 :           (cond ((memq char '(?\x202a ?\x202d))
    1320           0 :                  (propertize (string ?\x202c) 'invisible t))
    1321           0 :                 ((memq char '(?\x202b ?\x202e))
    1322           0 :                  (propertize (string ?\x202c ?\x200e) 'invisible t))
    1323           0 :                 ((memq char '(?\x2066 ?\x2067 ?\x2068))
    1324           0 :                  (propertize (string ?\x2069) 'invisible t))
    1325             :                 ;; Strong right-to-left characters cause reordering of
    1326             :                 ;; the following numerical characters which show the
    1327             :                 ;; codepoint, so append LRM to countermand that.
    1328           0 :                 ((memq (get-char-code-property char 'bidi-class) '(R AL))
    1329           0 :                  (propertize (string ?\x200e) 'invisible t))
    1330             :                 (t
    1331           0 :                  "")))
    1332           0 :          (beg (point-min))
    1333           0 :          (end (point-max))
    1334           0 :          (pos (point))
    1335           0 :          (total (buffer-size))
    1336           0 :          (percent (round (* 100.0 (1- pos)) (max 1 total)))
    1337           0 :          (hscroll (if (= (window-hscroll) 0)
    1338             :                       ""
    1339           0 :                     (format " Hscroll=%d" (window-hscroll))))
    1340           0 :          (col (current-column)))
    1341           0 :     (if (= pos end)
    1342           0 :         (if (or (/= beg 1) (/= end (1+ total)))
    1343           0 :             (message "point=%d of %d (%d%%) <%d-%d> column=%d%s"
    1344           0 :                      pos total percent beg end col hscroll)
    1345           0 :           (message "point=%d of %d (EOB) column=%d%s"
    1346           0 :                    pos total col hscroll))
    1347           0 :       (let ((coding buffer-file-coding-system)
    1348             :             encoded encoding-msg display-prop under-display)
    1349           0 :         (if (or (not coding)
    1350           0 :                 (eq (coding-system-type coding) t))
    1351           0 :             (setq coding (default-value 'buffer-file-coding-system)))
    1352           0 :         (if (eq (char-charset char) 'eight-bit)
    1353           0 :             (setq encoding-msg
    1354           0 :                   (format "(%d, #o%o, #x%x, raw-byte)" char char char))
    1355             :           ;; Check if the character is displayed with some `display'
    1356             :           ;; text property.  In that case, set under-display to the
    1357             :           ;; buffer substring covered by that property.
    1358           0 :           (setq display-prop (get-char-property pos 'display))
    1359           0 :           (if display-prop
    1360           0 :               (let ((to (or (next-single-char-property-change pos 'display)
    1361           0 :                             (point-max))))
    1362           0 :                 (if (< to (+ pos 4))
    1363           0 :                     (setq under-display "")
    1364           0 :                   (setq under-display "..."
    1365           0 :                         to (+ pos 4)))
    1366           0 :                 (setq under-display
    1367           0 :                       (concat (buffer-substring-no-properties pos to)
    1368           0 :                               under-display)))
    1369           0 :             (setq encoded (and (>= char 128) (encode-coding-char char coding))))
    1370           0 :           (setq encoding-msg
    1371           0 :                 (if display-prop
    1372           0 :                     (if (not (stringp display-prop))
    1373           0 :                         (format "(%d, #o%o, #x%x, part of display \"%s\")"
    1374           0 :                                 char char char under-display)
    1375           0 :                       (format "(%d, #o%o, #x%x, part of display \"%s\"->\"%s\")"
    1376           0 :                               char char char under-display display-prop))
    1377           0 :                   (if encoded
    1378           0 :                       (format "(%d, #o%o, #x%x, file %s)"
    1379           0 :                               char char char
    1380           0 :                               (if (> (length encoded) 1)
    1381             :                                   "..."
    1382           0 :                                 (encoded-string-description encoded coding)))
    1383           0 :                     (format "(%d, #o%o, #x%x)" char char char)))))
    1384           0 :         (if detail
    1385             :             ;; We show the detailed information about CHAR.
    1386           0 :             (describe-char (point)))
    1387           0 :         (if (or (/= beg 1) (/= end (1+ total)))
    1388           0 :             (message "Char: %s%s %s point=%d of %d (%d%%) <%d-%d> column=%d%s"
    1389           0 :                      (if (< char 256)
    1390           0 :                          (single-key-description char)
    1391           0 :                        (buffer-substring-no-properties (point) (1+ (point))))
    1392           0 :                      bidi-fixer
    1393           0 :                      encoding-msg pos total percent beg end col hscroll)
    1394           0 :           (message "Char: %s%s %s point=%d of %d (%d%%) column=%d%s"
    1395           0 :                    (if enable-multibyte-characters
    1396           0 :                        (if (< char 128)
    1397           0 :                            (single-key-description char)
    1398           0 :                          (buffer-substring-no-properties (point) (1+ (point))))
    1399           0 :                      (single-key-description char))
    1400           0 :                    bidi-fixer encoding-msg pos total percent col hscroll))))))
    1401             : 
    1402             : ;; Initialize read-expression-map.  It is defined at C level.
    1403             : (defvar read-expression-map
    1404             :   (let ((m (make-sparse-keymap)))
    1405             :     (define-key m "\M-\t" 'completion-at-point)
    1406             :     ;; Might as well bind TAB to completion, since inserting a TAB char is
    1407             :     ;; much too rarely useful.
    1408             :     (define-key m "\t" 'completion-at-point)
    1409             :     (set-keymap-parent m minibuffer-local-map)
    1410             :     m))
    1411             : 
    1412             : (defun read-minibuffer (prompt &optional initial-contents)
    1413             :   "Return a Lisp object read using the minibuffer, unevaluated.
    1414             : Prompt with PROMPT.  If non-nil, optional second arg INITIAL-CONTENTS
    1415             : is a string to insert in the minibuffer before reading.
    1416             : \(INITIAL-CONTENTS can also be a cons of a string and an integer.
    1417             : Such arguments are used as in `read-from-minibuffer'.)"
    1418             :   ;; Used for interactive spec `x'.
    1419           0 :   (read-from-minibuffer prompt initial-contents minibuffer-local-map
    1420           0 :                         t 'minibuffer-history))
    1421             : 
    1422             : (defun eval-minibuffer (prompt &optional initial-contents)
    1423             :   "Return value of Lisp expression read using the minibuffer.
    1424             : Prompt with PROMPT.  If non-nil, optional second arg INITIAL-CONTENTS
    1425             : is a string to insert in the minibuffer before reading.
    1426             : \(INITIAL-CONTENTS can also be a cons of a string and an integer.
    1427             : Such arguments are used as in `read-from-minibuffer'.)"
    1428             :   ;; Used for interactive spec `X'.
    1429           0 :   (eval (read--expression prompt initial-contents)))
    1430             : 
    1431             : (defvar minibuffer-completing-symbol nil
    1432             :   "Non-nil means completing a Lisp symbol in the minibuffer.")
    1433             : (make-obsolete-variable 'minibuffer-completing-symbol nil "24.1" 'get)
    1434             : 
    1435             : (defvar minibuffer-default nil
    1436             :   "The current default value or list of default values in the minibuffer.
    1437             : The functions `read-from-minibuffer' and `completing-read' bind
    1438             : this variable locally.")
    1439             : 
    1440             : (defcustom eval-expression-print-level 4
    1441             :   "Value for `print-level' while printing value in `eval-expression'.
    1442             : A value of nil means no limit."
    1443             :   :group 'lisp
    1444             :   :type '(choice (const :tag "No Limit" nil) integer)
    1445             :   :version "21.1")
    1446             : 
    1447             : (defcustom eval-expression-print-length 12
    1448             :   "Value for `print-length' while printing value in `eval-expression'.
    1449             : A value of nil means no limit."
    1450             :   :group 'lisp
    1451             :   :type '(choice (const :tag "No Limit" nil) integer)
    1452             :   :version "21.1")
    1453             : 
    1454             : (defcustom eval-expression-debug-on-error t
    1455             :   "If non-nil set `debug-on-error' to t in `eval-expression'.
    1456             : If nil, don't change the value of `debug-on-error'."
    1457             :   :group 'lisp
    1458             :   :type 'boolean
    1459             :   :version "21.1")
    1460             : 
    1461             : (defcustom eval-expression-print-maximum-character 127
    1462             :   "The largest integer that will be displayed as a character.
    1463             : This affects printing by `eval-expression' (via
    1464             : `eval-expression-print-format')."
    1465             :   :group 'lisp
    1466             :   :type 'integer
    1467             :   :version "26.1")
    1468             : 
    1469             : (defun eval-expression-print-format (value)
    1470             :   "If VALUE in an integer, return a specially formatted string.
    1471             : This string will typically look like \" (#o1, #x1, ?\\C-a)\".
    1472             : If VALUE is not an integer, nil is returned.
    1473             : This function is used by commands like `eval-expression' that
    1474             : display the result of expression evaluation."
    1475           0 :   (when (integerp value)
    1476           0 :     (let ((char-string
    1477           0 :            (and (characterp value)
    1478           0 :                 (<= value eval-expression-print-maximum-character)
    1479           0 :                 (char-displayable-p value)
    1480           0 :                 (prin1-char value))))
    1481           0 :       (if char-string
    1482           0 :           (format " (#o%o, #x%x, %s)" value value char-string)
    1483           0 :         (format " (#o%o, #x%x)" value value)))))
    1484             : 
    1485             : (defvar eval-expression-minibuffer-setup-hook nil
    1486             :   "Hook run by `eval-expression' when entering the minibuffer.")
    1487             : 
    1488             : (defun read--expression (prompt &optional initial-contents)
    1489           0 :   (let ((minibuffer-completing-symbol t))
    1490           0 :     (minibuffer-with-setup-hook
    1491             :         (lambda ()
    1492             :           ;; FIXME: call emacs-lisp-mode?
    1493           0 :           (add-function :before-until (local 'eldoc-documentation-function)
    1494           0 :                         #'elisp-eldoc-documentation-function)
    1495           0 :           (eldoc-mode 1)
    1496           0 :           (add-hook 'completion-at-point-functions
    1497           0 :                     #'elisp-completion-at-point nil t)
    1498           0 :           (run-hooks 'eval-expression-minibuffer-setup-hook))
    1499           0 :       (read-from-minibuffer prompt initial-contents
    1500           0 :                             read-expression-map t
    1501           0 :                             'read-expression-history))))
    1502             : 
    1503             : (defun eval-expression-get-print-arguments (prefix-argument)
    1504             :   "Get arguments for commands that print an expression result.
    1505             : Returns a list (INSERT-VALUE NO-TRUNCATE CHAR-PRINT-LIMIT)
    1506             : based on PREFIX-ARG.  This function determines the interpretation
    1507             : of the prefix argument for `eval-expression' and
    1508             : `eval-last-sexp'."
    1509           0 :   (let ((num (prefix-numeric-value prefix-argument)))
    1510           0 :     (list (not (memq prefix-argument '(- nil)))
    1511           0 :           (= num 0)
    1512           0 :           (cond ((not (memq prefix-argument '(0 -1 - nil))) nil)
    1513           0 :                 ((= num -1) most-positive-fixnum)
    1514           0 :                 (t eval-expression-print-maximum-character)))))
    1515             : 
    1516             : ;; We define this, rather than making `eval' interactive,
    1517             : ;; for the sake of completion of names like eval-region, eval-buffer.
    1518             : (defun eval-expression (exp &optional insert-value no-truncate char-print-limit)
    1519             :   "Evaluate EXP and print value in the echo area.
    1520             : When called interactively, read an Emacs Lisp expression and
    1521             : evaluate it.  Value is also consed on to front of the variable
    1522             : `values'.  Optional argument INSERT-VALUE non-nil (interactively,
    1523             : with a non `-' prefix argument) means insert the result into the
    1524             : current buffer instead of printing it in the echo area.
    1525             : 
    1526             : Normally, this function truncates long output according to the
    1527             : value of the variables `eval-expression-print-length' and
    1528             : `eval-expression-print-level'.  When NO-TRUNCATE is
    1529             : non-nil (interactively, with a prefix argument of zero), however,
    1530             : there is no such truncation.
    1531             : 
    1532             : If the resulting value is an integer, and CHAR-PRINT-LIMIT is
    1533             : non-nil (interactively, unless given a positive prefix argument)
    1534             : it will be printed in several additional formats (octal,
    1535             : hexadecimal, and character).  The character format is only used
    1536             : if the value is below CHAR-PRINT-LIMIT (interactively, if the
    1537             : prefix argument is -1 or the value is below
    1538             : `eval-expression-print-maximum-character').
    1539             : 
    1540             : Runs the hook `eval-expression-minibuffer-setup-hook' on entering the
    1541             : minibuffer.
    1542             : 
    1543             : If `eval-expression-debug-on-error' is non-nil, which is the default,
    1544             : this command arranges for all errors to enter the debugger."
    1545             :   (interactive
    1546           0 :    (cons (read--expression "Eval: ")
    1547           0 :          (eval-expression-get-print-arguments current-prefix-arg)))
    1548             : 
    1549           0 :   (if (null eval-expression-debug-on-error)
    1550           0 :       (push (eval exp lexical-binding) values)
    1551           0 :     (let ((old-value (make-symbol "t")) new-value)
    1552             :       ;; Bind debug-on-error to something unique so that we can
    1553             :       ;; detect when evalled code changes it.
    1554           0 :       (let ((debug-on-error old-value))
    1555           0 :         (push (eval (macroexpand-all exp) lexical-binding) values)
    1556           0 :         (setq new-value debug-on-error))
    1557             :       ;; If evalled code has changed the value of debug-on-error,
    1558             :       ;; propagate that change to the global binding.
    1559           0 :       (unless (eq old-value new-value)
    1560           0 :         (setq debug-on-error new-value))))
    1561             : 
    1562           0 :   (let ((print-length (unless no-truncate eval-expression-print-length))
    1563           0 :         (print-level  (unless no-truncate eval-expression-print-level))
    1564           0 :         (eval-expression-print-maximum-character char-print-limit)
    1565             :         (deactivate-mark))
    1566           0 :     (let ((out (if insert-value (current-buffer) t)))
    1567           0 :       (prog1
    1568           0 :           (prin1 (car values) out)
    1569           0 :         (let ((str (and char-print-limit
    1570           0 :                         (eval-expression-print-format (car values)))))
    1571           0 :           (when str (princ str out)))))))
    1572             : 
    1573             : (defun edit-and-eval-command (prompt command)
    1574             :   "Prompting with PROMPT, let user edit COMMAND and eval result.
    1575             : COMMAND is a Lisp expression.  Let user edit that expression in
    1576             : the minibuffer, then read and evaluate the result."
    1577           0 :   (let ((command
    1578           0 :          (let ((print-level nil)
    1579           0 :                (minibuffer-history-sexp-flag (1+ (minibuffer-depth))))
    1580           0 :            (unwind-protect
    1581           0 :                (read-from-minibuffer prompt
    1582           0 :                                      (prin1-to-string command)
    1583           0 :                                      read-expression-map t
    1584           0 :                                      'command-history)
    1585             :              ;; If command was added to command-history as a string,
    1586             :              ;; get rid of that.  We want only evaluable expressions there.
    1587           0 :              (if (stringp (car command-history))
    1588           0 :                  (setq command-history (cdr command-history)))))))
    1589             : 
    1590             :     ;; If command to be redone does not match front of history,
    1591             :     ;; add it to the history.
    1592           0 :     (or (equal command (car command-history))
    1593           0 :         (setq command-history (cons command command-history)))
    1594           0 :     (eval command)))
    1595             : 
    1596             : (defun repeat-complex-command (arg)
    1597             :   "Edit and re-evaluate last complex command, or ARGth from last.
    1598             : A complex command is one which used the minibuffer.
    1599             : The command is placed in the minibuffer as a Lisp form for editing.
    1600             : The result is executed, repeating the command as changed.
    1601             : If the command has been changed or is not the most recent previous
    1602             : command it is added to the front of the command history.
    1603             : You can use the minibuffer history commands \
    1604             : \\<minibuffer-local-map>\\[next-history-element] and \\[previous-history-element]
    1605             : to get different commands to edit and resubmit."
    1606             :   (interactive "p")
    1607           0 :   (let ((elt (nth (1- arg) command-history))
    1608             :         newcmd)
    1609           0 :     (if elt
    1610           0 :         (progn
    1611           0 :           (setq newcmd
    1612           0 :                 (let ((print-level nil)
    1613           0 :                       (minibuffer-history-position arg)
    1614           0 :                       (minibuffer-history-sexp-flag (1+ (minibuffer-depth))))
    1615           0 :                   (unwind-protect
    1616           0 :                       (read-from-minibuffer
    1617           0 :                        "Redo: " (prin1-to-string elt) read-expression-map t
    1618           0 :                        (cons 'command-history arg))
    1619             : 
    1620             :                     ;; If command was added to command-history as a
    1621             :                     ;; string, get rid of that.  We want only
    1622             :                     ;; evaluable expressions there.
    1623           0 :                     (if (stringp (car command-history))
    1624           0 :                         (setq command-history (cdr command-history))))))
    1625             : 
    1626             :           ;; If command to be redone does not match front of history,
    1627             :           ;; add it to the history.
    1628           0 :           (or (equal newcmd (car command-history))
    1629           0 :               (setq command-history (cons newcmd command-history)))
    1630           0 :           (apply #'funcall-interactively
    1631           0 :                  (car newcmd)
    1632           0 :                  (mapcar (lambda (e) (eval e t)) (cdr newcmd))))
    1633           0 :       (if command-history
    1634           0 :           (error "Argument %d is beyond length of command history" arg)
    1635           0 :         (error "There are no previous complex commands to repeat")))))
    1636             : 
    1637             : 
    1638             : (defvar extended-command-history nil)
    1639             : (defvar execute-extended-command--last-typed nil)
    1640             : 
    1641             : (defun read-extended-command ()
    1642             :   "Read command name to invoke in `execute-extended-command'."
    1643           0 :   (minibuffer-with-setup-hook
    1644             :       (lambda ()
    1645           0 :         (add-hook 'post-self-insert-hook
    1646             :                   (lambda ()
    1647           0 :                     (setq execute-extended-command--last-typed
    1648           0 :                               (minibuffer-contents)))
    1649           0 :                   nil 'local)
    1650           0 :         (set (make-local-variable 'minibuffer-default-add-function)
    1651             :              (lambda ()
    1652             :                ;; Get a command name at point in the original buffer
    1653             :                ;; to propose it after M-n.
    1654           0 :                (with-current-buffer (window-buffer (minibuffer-selected-window))
    1655           0 :                  (and (commandp (function-called-at-point))
    1656           0 :                       (format "%S" (function-called-at-point)))))))
    1657             :     ;; Read a string, completing from and restricting to the set of
    1658             :     ;; all defined commands.  Don't provide any initial input.
    1659             :     ;; Save the command read on the extended-command history list.
    1660           0 :     (completing-read
    1661           0 :      (concat (cond
    1662           0 :               ((eq current-prefix-arg '-) "- ")
    1663           0 :               ((and (consp current-prefix-arg)
    1664           0 :                     (eq (car current-prefix-arg) 4)) "C-u ")
    1665           0 :               ((and (consp current-prefix-arg)
    1666           0 :                     (integerp (car current-prefix-arg)))
    1667           0 :                (format "%d " (car current-prefix-arg)))
    1668           0 :               ((integerp current-prefix-arg)
    1669           0 :                (format "%d " current-prefix-arg)))
    1670             :              ;; This isn't strictly correct if `execute-extended-command'
    1671             :              ;; is bound to anything else (e.g. [menu]).
    1672             :              ;; It could use (key-description (this-single-command-keys)),
    1673             :              ;; but actually a prompt other than "M-x" would be confusing,
    1674             :              ;; because "M-x" is a well-known prompt to read a command
    1675             :              ;; and it serves as a shorthand for "Extended command: ".
    1676           0 :              "M-x ")
    1677             :      (lambda (string pred action)
    1678           0 :        (let ((pred
    1679           0 :               (if (memq action '(nil t))
    1680             :                   ;; Exclude obsolete commands from completions.
    1681             :                   (lambda (sym)
    1682           0 :                     (and (funcall pred sym)
    1683           0 :                          (or (equal string (symbol-name sym))
    1684           0 :                              (not (get sym 'byte-obsolete-info)))))
    1685           0 :                 pred)))
    1686           0 :          (complete-with-action action obarray string pred)))
    1687           0 :      #'commandp t nil 'extended-command-history)))
    1688             : 
    1689             : (defcustom suggest-key-bindings t
    1690             :   "Non-nil means show the equivalent key-binding when M-x command has one.
    1691             : The value can be a length of time to show the message for.
    1692             : If the value is non-nil and not a number, we wait 2 seconds."
    1693             :   :group 'keyboard
    1694             :   :type '(choice (const :tag "off" nil)
    1695             :                  (integer :tag "time" 2)
    1696             :                  (other :tag "on")))
    1697             : 
    1698             : (defcustom extended-command-suggest-shorter t
    1699             :   "If non-nil, show a shorter M-x invocation when there is one."
    1700             :   :group 'keyboard
    1701             :   :type 'boolean
    1702             :   :version "26.1")
    1703             : 
    1704             : (defun execute-extended-command--shorter-1 (name length)
    1705           0 :   (cond
    1706           0 :    ((zerop length) (list ""))
    1707           0 :    ((equal name "") nil)
    1708             :    (t
    1709           0 :     (nconc (mapcar (lambda (s) (concat (substring name 0 1) s))
    1710           0 :                    (execute-extended-command--shorter-1
    1711           0 :                     (substring name 1) (1- length)))
    1712           0 :            (when (string-match "\\`\\(-\\)?[^-]*" name)
    1713           0 :              (execute-extended-command--shorter-1
    1714           0 :               (substring name (match-end 0)) length))))))
    1715             : 
    1716             : (defun execute-extended-command--shorter (name typed)
    1717           0 :   (let ((candidates '())
    1718           0 :         (max (length typed))
    1719             :         (len 1)
    1720             :         binding)
    1721           0 :     (while (and (not binding)
    1722           0 :                 (progn
    1723           0 :                   (unless candidates
    1724           0 :                     (setq len (1+ len))
    1725           0 :                     (setq candidates (execute-extended-command--shorter-1
    1726           0 :                                       name len)))
    1727             :                   ;; Don't show the help message if the binding isn't
    1728             :                   ;; significantly shorter than the M-x command the user typed.
    1729           0 :                   (< len (- max 5))))
    1730           0 :       (input-pending-p)    ;Dummy call to trigger input-processing, bug#23002.
    1731           0 :       (let ((candidate (pop candidates)))
    1732           0 :         (when (equal name
    1733           0 :                        (car-safe (completion-try-completion
    1734           0 :                                   candidate obarray 'commandp len)))
    1735           0 :           (setq binding candidate))))
    1736           0 :     binding))
    1737             : 
    1738             : (defun execute-extended-command (prefixarg &optional command-name typed)
    1739             :   ;; Based on Fexecute_extended_command in keyboard.c of Emacs.
    1740             :   ;; Aaron S. Hawley <aaron.s.hawley(at)gmail.com> 2009-08-24
    1741             :   "Read a command name, then read the arguments and call the command.
    1742             : To pass a prefix argument to the command you are
    1743             : invoking, give a prefix argument to `execute-extended-command'."
    1744             :   (declare (interactive-only command-execute))
    1745             :   ;; FIXME: Remember the actual text typed by the user before completion,
    1746             :   ;; so that we don't later on suggest the same shortening.
    1747             :   (interactive
    1748           0 :    (let ((execute-extended-command--last-typed nil))
    1749           0 :      (list current-prefix-arg
    1750           0 :            (read-extended-command)
    1751           0 :            execute-extended-command--last-typed)))
    1752             :   ;; Emacs<24 calling-convention was with a single `prefixarg' argument.
    1753           0 :   (unless command-name
    1754           0 :     (let ((current-prefix-arg prefixarg) ; for prompt
    1755             :           (execute-extended-command--last-typed nil))
    1756           0 :       (setq command-name (read-extended-command))
    1757           0 :       (setq typed execute-extended-command--last-typed)))
    1758           0 :   (let* ((function (and (stringp command-name) (intern-soft command-name)))
    1759           0 :          (binding (and suggest-key-bindings
    1760           0 :                        (not executing-kbd-macro)
    1761           0 :                        (where-is-internal function overriding-local-map t))))
    1762           0 :     (unless (commandp function)
    1763           0 :       (error "`%s' is not a valid command name" command-name))
    1764             :     ;; Some features, such as novice.el, rely on this-command-keys
    1765             :     ;; including M-x COMMAND-NAME RET.
    1766           0 :     (set--this-command-keys (concat "\M-x" (symbol-name function) "\r"))
    1767           0 :     (setq this-command function)
    1768             :     ;; Normally `real-this-command' should never be changed, but here we really
    1769             :     ;; want to pretend that M-x <cmd> RET is nothing more than a "key
    1770             :     ;; binding" for <cmd>, so the command the user really wanted to run is
    1771             :     ;; `function' and not `execute-extended-command'.  The difference is
    1772             :     ;; visible in cases such as M-x <cmd> RET and then C-x z (bug#11506).
    1773           0 :     (setq real-this-command function)
    1774           0 :     (let ((prefix-arg prefixarg))
    1775           0 :       (command-execute function 'record))
    1776             :     ;; If enabled, show which key runs this command.
    1777             :     ;; But first wait, and skip the message if there is input.
    1778           0 :     (let* ((waited
    1779             :             ;; If this command displayed something in the echo area;
    1780             :             ;; wait a few seconds, then display our suggestion message.
    1781             :             ;; FIXME: Wait *after* running post-command-hook!
    1782             :             ;; FIXME: Don't wait if execute-extended-command--shorter won't
    1783             :             ;; find a better answer anyway!
    1784           0 :             (when suggest-key-bindings
    1785           0 :               (sit-for (cond
    1786           0 :                         ((zerop (length (current-message))) 0)
    1787           0 :                         ((numberp suggest-key-bindings) suggest-key-bindings)
    1788           0 :                         (t 2))))))
    1789           0 :       (when (and waited (not (consp unread-command-events)))
    1790           0 :         (unless (or (not extended-command-suggest-shorter)
    1791           0 :                     binding executing-kbd-macro (not (symbolp function))
    1792           0 :                     (<= (length (symbol-name function)) 2))
    1793             :           ;; There's no binding for CMD.  Let's try and find the shortest
    1794             :           ;; string to use in M-x.
    1795             :           ;; FIXME: Can be slow.  Cache it maybe?
    1796           0 :           (while-no-input
    1797           0 :             (setq binding (execute-extended-command--shorter
    1798           0 :                            (symbol-name function) typed))))
    1799           0 :         (when binding
    1800           0 :           (with-temp-message
    1801           0 :               (format-message "You can run the command `%s' with %s"
    1802           0 :                               function
    1803           0 :                               (if (stringp binding)
    1804           0 :                                   (concat "M-x " binding " RET")
    1805           0 :                                 (key-description binding)))
    1806           0 :             (sit-for (if (numberp suggest-key-bindings)
    1807           0 :                          suggest-key-bindings
    1808           0 :                        2))))))))
    1809             : 
    1810             : (defun command-execute (cmd &optional record-flag keys special)
    1811             :   ;; BEWARE: Called directly from the C code.
    1812             :   "Execute CMD as an editor command.
    1813             : CMD must be a symbol that satisfies the `commandp' predicate.
    1814             : Optional second arg RECORD-FLAG non-nil
    1815             : means unconditionally put this command in the variable `command-history'.
    1816             : Otherwise, that is done only if an arg is read using the minibuffer.
    1817             : The argument KEYS specifies the value to use instead of (this-command-keys)
    1818             : when reading the arguments; if it is nil, (this-command-keys) is used.
    1819             : The argument SPECIAL, if non-nil, means that this command is executing
    1820             : a special event, so ignore the prefix argument and don't clear it."
    1821           2 :   (setq debug-on-next-call nil)
    1822           2 :   (let ((prefixarg (unless special
    1823             :                      ;; FIXME: This should probably be done around
    1824             :                      ;; pre-command-hook rather than here!
    1825           0 :                      (prog1 prefix-arg
    1826           0 :                        (setq current-prefix-arg prefix-arg)
    1827           0 :                        (setq prefix-arg nil)
    1828           0 :                        (when current-prefix-arg
    1829           2 :                          (prefix-command-update))))))
    1830           2 :     (if (and (symbolp cmd)
    1831           2 :              (get cmd 'disabled)
    1832           2 :              disabled-command-function)
    1833             :         ;; FIXME: Weird calling convention!
    1834           0 :         (run-hooks 'disabled-command-function)
    1835           2 :       (let ((final cmd))
    1836           2 :         (while
    1837           2 :             (progn
    1838           2 :               (setq final (indirect-function final))
    1839           2 :               (if (autoloadp final)
    1840           2 :                   (setq final (autoload-do-load final cmd)))))
    1841           2 :         (cond
    1842           2 :          ((arrayp final)
    1843             :           ;; If requested, place the macro in the command history.  For
    1844             :           ;; other sorts of commands, call-interactively takes care of this.
    1845           0 :           (when record-flag
    1846           0 :             (push `(execute-kbd-macro ,final ,prefixarg) command-history)
    1847             :             ;; Don't keep command history around forever.
    1848           0 :             (when (and (numberp history-length) (> history-length 0))
    1849           0 :               (let ((cell (nthcdr history-length command-history)))
    1850           0 :                 (if (consp cell) (setcdr cell nil)))))
    1851           0 :           (execute-kbd-macro final prefixarg))
    1852             :          (t
    1853             :           ;; Pass `cmd' rather than `final', for the backtrace's sake.
    1854           2 :           (prog1 (call-interactively cmd record-flag keys)
    1855           2 :             (when (and (symbolp cmd)
    1856           2 :                        (get cmd 'byte-obsolete-info)
    1857           2 :                        (not (get cmd 'command-execute-obsolete-warned)))
    1858           0 :               (put cmd 'command-execute-obsolete-warned t)
    1859           0 :               (message "%s" (macroexp--obsolete-warning
    1860           2 :                              cmd (get cmd 'byte-obsolete-info) "command"))))))))))
    1861             : 
    1862             : (defvar minibuffer-history nil
    1863             :   "Default minibuffer history list.
    1864             : This is used for all minibuffer input
    1865             : except when an alternate history list is specified.
    1866             : 
    1867             : Maximum length of the history list is determined by the value
    1868             : of `history-length', which see.")
    1869             : (defvar minibuffer-history-sexp-flag nil
    1870             :   "Control whether history list elements are expressions or strings.
    1871             : If the value of this variable equals current minibuffer depth,
    1872             : they are expressions; otherwise they are strings.
    1873             : \(That convention is designed to do the right thing for
    1874             : recursive uses of the minibuffer.)")
    1875             : (setq minibuffer-history-variable 'minibuffer-history)
    1876             : (setq minibuffer-history-position nil)  ;; Defvar is in C code.
    1877             : (defvar minibuffer-history-search-history nil)
    1878             : 
    1879             : (defvar minibuffer-text-before-history nil
    1880             :   "Text that was in this minibuffer before any history commands.
    1881             : This is nil if there have not yet been any history commands
    1882             : in this use of the minibuffer.")
    1883             : 
    1884             : (add-hook 'minibuffer-setup-hook 'minibuffer-history-initialize)
    1885             : 
    1886             : (defun minibuffer-history-initialize ()
    1887           0 :   (setq minibuffer-text-before-history nil))
    1888             : 
    1889             : (defun minibuffer-avoid-prompt (_new _old)
    1890             :   "A point-motion hook for the minibuffer, that moves point out of the prompt."
    1891             :   (declare (obsolete cursor-intangible-mode "25.1"))
    1892           0 :   (constrain-to-field nil (point-max)))
    1893             : 
    1894             : (defcustom minibuffer-history-case-insensitive-variables nil
    1895             :   "Minibuffer history variables for which matching should ignore case.
    1896             : If a history variable is a member of this list, then the
    1897             : \\[previous-matching-history-element] and \\[next-matching-history-element]\
    1898             :  commands ignore case when searching it, regardless of `case-fold-search'."
    1899             :   :type '(repeat variable)
    1900             :   :group 'minibuffer)
    1901             : 
    1902             : (defun previous-matching-history-element (regexp n)
    1903             :   "Find the previous history element that matches REGEXP.
    1904             : \(Previous history elements refer to earlier actions.)
    1905             : With prefix argument N, search for Nth previous match.
    1906             : If N is negative, find the next or Nth next match.
    1907             : Normally, history elements are matched case-insensitively if
    1908             : `case-fold-search' is non-nil, but an uppercase letter in REGEXP
    1909             : makes the search case-sensitive.
    1910             : See also `minibuffer-history-case-insensitive-variables'."
    1911             :   (interactive
    1912           0 :    (let* ((enable-recursive-minibuffers t)
    1913           0 :           (regexp (read-from-minibuffer "Previous element matching (regexp): "
    1914             :                                         nil
    1915           0 :                                         minibuffer-local-map
    1916             :                                         nil
    1917             :                                         'minibuffer-history-search-history
    1918           0 :                                         (car minibuffer-history-search-history))))
    1919             :      ;; Use the last regexp specified, by default, if input is empty.
    1920           0 :      (list (if (string= regexp "")
    1921           0 :                (if minibuffer-history-search-history
    1922           0 :                    (car minibuffer-history-search-history)
    1923           0 :                  (user-error "No previous history search regexp"))
    1924           0 :              regexp)
    1925           0 :            (prefix-numeric-value current-prefix-arg))))
    1926           0 :   (unless (zerop n)
    1927           0 :     (if (and (zerop minibuffer-history-position)
    1928           0 :              (null minibuffer-text-before-history))
    1929           0 :         (setq minibuffer-text-before-history
    1930           0 :               (minibuffer-contents-no-properties)))
    1931           0 :     (let ((history (symbol-value minibuffer-history-variable))
    1932             :           (case-fold-search
    1933           0 :            (if (isearch-no-upper-case-p regexp t) ; assume isearch.el is dumped
    1934             :                ;; On some systems, ignore case for file names.
    1935           0 :                (if (memq minibuffer-history-variable
    1936           0 :                          minibuffer-history-case-insensitive-variables)
    1937             :                    t
    1938             :                  ;; Respect the user's setting for case-fold-search:
    1939           0 :                  case-fold-search)
    1940           0 :              nil))
    1941             :           prevpos
    1942             :           match-string
    1943             :           match-offset
    1944           0 :           (pos minibuffer-history-position))
    1945           0 :       (while (/= n 0)
    1946           0 :         (setq prevpos pos)
    1947           0 :         (setq pos (min (max 1 (+ pos (if (< n 0) -1 1))) (length history)))
    1948           0 :         (when (= pos prevpos)
    1949           0 :           (user-error (if (= pos 1)
    1950             :                           "No later matching history item"
    1951           0 :                         "No earlier matching history item")))
    1952           0 :         (setq match-string
    1953           0 :               (if (eq minibuffer-history-sexp-flag (minibuffer-depth))
    1954           0 :                   (let ((print-level nil))
    1955           0 :                     (prin1-to-string (nth (1- pos) history)))
    1956           0 :                 (nth (1- pos) history)))
    1957           0 :         (setq match-offset
    1958           0 :               (if (< n 0)
    1959           0 :                   (and (string-match regexp match-string)
    1960           0 :                        (match-end 0))
    1961           0 :                 (and (string-match (concat ".*\\(" regexp "\\)") match-string)
    1962           0 :                      (match-beginning 1))))
    1963           0 :         (when match-offset
    1964           0 :           (setq n (+ n (if (< n 0) 1 -1)))))
    1965           0 :       (setq minibuffer-history-position pos)
    1966           0 :       (goto-char (point-max))
    1967           0 :       (delete-minibuffer-contents)
    1968           0 :       (insert match-string)
    1969           0 :       (goto-char (+ (minibuffer-prompt-end) match-offset))))
    1970           0 :   (if (memq (car (car command-history)) '(previous-matching-history-element
    1971           0 :                                           next-matching-history-element))
    1972           0 :       (setq command-history (cdr command-history))))
    1973             : 
    1974             : (defun next-matching-history-element (regexp n)
    1975             :   "Find the next history element that matches REGEXP.
    1976             : \(The next history element refers to a more recent action.)
    1977             : With prefix argument N, search for Nth next match.
    1978             : If N is negative, find the previous or Nth previous match.
    1979             : Normally, history elements are matched case-insensitively if
    1980             : `case-fold-search' is non-nil, but an uppercase letter in REGEXP
    1981             : makes the search case-sensitive."
    1982             :   (interactive
    1983           0 :    (let* ((enable-recursive-minibuffers t)
    1984           0 :           (regexp (read-from-minibuffer "Next element matching (regexp): "
    1985             :                                         nil
    1986           0 :                                         minibuffer-local-map
    1987             :                                         nil
    1988             :                                         'minibuffer-history-search-history
    1989           0 :                                         (car minibuffer-history-search-history))))
    1990             :      ;; Use the last regexp specified, by default, if input is empty.
    1991           0 :      (list (if (string= regexp "")
    1992           0 :                (if minibuffer-history-search-history
    1993           0 :                    (car minibuffer-history-search-history)
    1994           0 :                  (user-error "No previous history search regexp"))
    1995           0 :              regexp)
    1996           0 :            (prefix-numeric-value current-prefix-arg))))
    1997           0 :   (previous-matching-history-element regexp (- n)))
    1998             : 
    1999             : (defvar minibuffer-temporary-goal-position nil)
    2000             : 
    2001             : (defvar minibuffer-default-add-function 'minibuffer-default-add-completions
    2002             :   "Function run by `goto-history-element' before consuming default values.
    2003             : This is useful to dynamically add more elements to the list of default values
    2004             : when `goto-history-element' reaches the end of this list.
    2005             : Before calling this function `goto-history-element' sets the variable
    2006             : `minibuffer-default-add-done' to t, so it will call this function only
    2007             : once.  In special cases, when this function needs to be called more
    2008             : than once, it can set `minibuffer-default-add-done' to nil explicitly,
    2009             : overriding the setting of this variable to t in `goto-history-element'.")
    2010             : 
    2011             : (defvar minibuffer-default-add-done nil
    2012             :   "When nil, add more elements to the end of the list of default values.
    2013             : The value nil causes `goto-history-element' to add more elements to
    2014             : the list of defaults when it reaches the end of this list.  It does
    2015             : this by calling a function defined by `minibuffer-default-add-function'.")
    2016             : 
    2017             : (make-variable-buffer-local 'minibuffer-default-add-done)
    2018             : 
    2019             : (defun minibuffer-default-add-completions ()
    2020             :   "Return a list of all completions without the default value.
    2021             : This function is used to add all elements of the completion table to
    2022             : the end of the list of defaults just after the default value."
    2023           0 :   (let ((def minibuffer-default)
    2024           0 :         (all (all-completions ""
    2025           0 :                               minibuffer-completion-table
    2026           0 :                               minibuffer-completion-predicate)))
    2027           0 :     (if (listp def)
    2028           0 :         (append def all)
    2029           0 :       (cons def (delete def all)))))
    2030             : 
    2031             : (defun goto-history-element (nabs)
    2032             :   "Puts element of the minibuffer history in the minibuffer.
    2033             : The argument NABS specifies the absolute history position."
    2034             :   (interactive "p")
    2035           0 :   (when (and (not minibuffer-default-add-done)
    2036           0 :              (functionp minibuffer-default-add-function)
    2037           0 :              (< nabs (- (if (listp minibuffer-default)
    2038           0 :                             (length minibuffer-default)
    2039           0 :                           1))))
    2040           0 :     (setq minibuffer-default-add-done t
    2041           0 :           minibuffer-default (funcall minibuffer-default-add-function)))
    2042           0 :   (let ((minimum (if minibuffer-default
    2043           0 :                      (- (if (listp minibuffer-default)
    2044           0 :                             (length minibuffer-default)
    2045           0 :                           1))
    2046           0 :                    0))
    2047             :         elt minibuffer-returned-to-present)
    2048           0 :     (if (and (zerop minibuffer-history-position)
    2049           0 :              (null minibuffer-text-before-history))
    2050           0 :         (setq minibuffer-text-before-history
    2051           0 :               (minibuffer-contents-no-properties)))
    2052           0 :     (if (< nabs minimum)
    2053           0 :         (user-error (if minibuffer-default
    2054             :                         "End of defaults; no next item"
    2055           0 :                       "End of history; no default available")))
    2056           0 :     (if (> nabs (if (listp (symbol-value minibuffer-history-variable))
    2057           0 :                     (length (symbol-value minibuffer-history-variable))
    2058           0 :                   0))
    2059           0 :         (user-error "Beginning of history; no preceding item"))
    2060           0 :     (unless (memq last-command '(next-history-element
    2061           0 :                                  previous-history-element))
    2062           0 :       (let ((prompt-end (minibuffer-prompt-end)))
    2063           0 :         (set (make-local-variable 'minibuffer-temporary-goal-position)
    2064           0 :              (cond ((<= (point) prompt-end) prompt-end)
    2065           0 :                    ((eobp) nil)
    2066           0 :                    (t (point))))))
    2067           0 :     (goto-char (point-max))
    2068           0 :     (delete-minibuffer-contents)
    2069           0 :     (setq minibuffer-history-position nabs)
    2070           0 :     (cond ((< nabs 0)
    2071           0 :            (setq elt (if (listp minibuffer-default)
    2072           0 :                          (nth (1- (abs nabs)) minibuffer-default)
    2073           0 :                        minibuffer-default)))
    2074           0 :           ((= nabs 0)
    2075           0 :            (setq elt (or minibuffer-text-before-history ""))
    2076           0 :            (setq minibuffer-returned-to-present t)
    2077           0 :            (setq minibuffer-text-before-history nil))
    2078           0 :           (t (setq elt (nth (1- minibuffer-history-position)
    2079           0 :                             (symbol-value minibuffer-history-variable)))))
    2080           0 :     (insert
    2081           0 :      (if (and (eq minibuffer-history-sexp-flag (minibuffer-depth))
    2082           0 :               (not minibuffer-returned-to-present))
    2083           0 :          (let ((print-level nil))
    2084           0 :            (prin1-to-string elt))
    2085           0 :        elt))
    2086           0 :     (goto-char (or minibuffer-temporary-goal-position (point-max)))))
    2087             : 
    2088             : (defun next-history-element (n)
    2089             :   "Puts next element of the minibuffer history in the minibuffer.
    2090             : With argument N, it uses the Nth following element."
    2091             :   (interactive "p")
    2092           0 :   (or (zerop n)
    2093           0 :       (goto-history-element (- minibuffer-history-position n))))
    2094             : 
    2095             : (defun previous-history-element (n)
    2096             :   "Puts previous element of the minibuffer history in the minibuffer.
    2097             : With argument N, it uses the Nth previous element."
    2098             :   (interactive "p")
    2099           0 :   (or (zerop n)
    2100           0 :       (goto-history-element (+ minibuffer-history-position n))))
    2101             : 
    2102             : (defun next-line-or-history-element (&optional arg)
    2103             :   "Move cursor vertically down ARG lines, or to the next history element.
    2104             : When point moves over the bottom line of multi-line minibuffer, puts ARGth
    2105             : next element of the minibuffer history in the minibuffer."
    2106             :   (interactive "^p")
    2107           0 :   (or arg (setq arg 1))
    2108           0 :   (let* ((old-point (point))
    2109             :          ;; Remember the original goal column of possibly multi-line input
    2110             :          ;; excluding the length of the prompt on the first line.
    2111           0 :          (prompt-end (minibuffer-prompt-end))
    2112           0 :          (old-column (unless (and (eolp) (> (point) prompt-end))
    2113           0 :                        (if (= (line-number-at-pos) 1)
    2114           0 :                            (max (- (current-column) (1- prompt-end)) 0)
    2115           0 :                          (current-column)))))
    2116           0 :     (condition-case nil
    2117           0 :         (with-no-warnings
    2118           0 :           (next-line arg))
    2119             :       (end-of-buffer
    2120             :        ;; Restore old position since `line-move-visual' moves point to
    2121             :        ;; the end of the line when it fails to go to the next line.
    2122           0 :        (goto-char old-point)
    2123           0 :        (next-history-element arg)
    2124             :        ;; Reset `temporary-goal-column' because a correct value is not
    2125             :        ;; calculated when `next-line' above fails by bumping against
    2126             :        ;; the bottom of the minibuffer (bug#22544).
    2127           0 :        (setq temporary-goal-column 0)
    2128             :        ;; Restore the original goal column on the last line
    2129             :        ;; of possibly multi-line input.
    2130           0 :        (goto-char (point-max))
    2131           0 :        (when old-column
    2132           0 :          (if (= (line-number-at-pos) 1)
    2133           0 :              (move-to-column (+ old-column (1- (minibuffer-prompt-end))))
    2134           0 :            (move-to-column old-column)))))))
    2135             : 
    2136             : (defun previous-line-or-history-element (&optional arg)
    2137             :   "Move cursor vertically up ARG lines, or to the previous history element.
    2138             : When point moves over the top line of multi-line minibuffer, puts ARGth
    2139             : previous element of the minibuffer history in the minibuffer."
    2140             :   (interactive "^p")
    2141           0 :   (or arg (setq arg 1))
    2142           0 :   (let* ((old-point (point))
    2143             :          ;; Remember the original goal column of possibly multi-line input
    2144             :          ;; excluding the length of the prompt on the first line.
    2145           0 :          (prompt-end (minibuffer-prompt-end))
    2146           0 :          (old-column (unless (and (eolp) (> (point) prompt-end))
    2147           0 :                        (if (= (line-number-at-pos) 1)
    2148           0 :                            (max (- (current-column) (1- prompt-end)) 0)
    2149           0 :                          (current-column)))))
    2150           0 :     (condition-case nil
    2151           0 :         (with-no-warnings
    2152           0 :           (previous-line arg))
    2153             :       (beginning-of-buffer
    2154             :        ;; Restore old position since `line-move-visual' moves point to
    2155             :        ;; the beginning of the line when it fails to go to the previous line.
    2156           0 :        (goto-char old-point)
    2157           0 :        (previous-history-element arg)
    2158             :        ;; Reset `temporary-goal-column' because a correct value is not
    2159             :        ;; calculated when `previous-line' above fails by bumping against
    2160             :        ;; the top of the minibuffer (bug#22544).
    2161           0 :        (setq temporary-goal-column 0)
    2162             :        ;; Restore the original goal column on the first line
    2163             :        ;; of possibly multi-line input.
    2164           0 :        (goto-char (minibuffer-prompt-end))
    2165           0 :        (if old-column
    2166           0 :            (if (= (line-number-at-pos) 1)
    2167           0 :                (move-to-column (+ old-column (1- (minibuffer-prompt-end))))
    2168           0 :              (move-to-column old-column))
    2169             :          ;; Put the cursor at the end of the visual line instead of the
    2170             :          ;; logical line, so the next `previous-line-or-history-element'
    2171             :          ;; would move to the previous history element, not to a possible upper
    2172             :          ;; visual line from the end of logical line in `line-move-visual' mode.
    2173           0 :          (end-of-visual-line)
    2174             :          ;; Since `end-of-visual-line' puts the cursor at the beginning
    2175             :          ;; of the next visual line, move it one char back to the end
    2176             :          ;; of the first visual line (bug#22544).
    2177           0 :          (unless (eolp) (backward-char 1)))))))
    2178             : 
    2179             : (defun next-complete-history-element (n)
    2180             :   "Get next history element which completes the minibuffer before the point.
    2181             : The contents of the minibuffer after the point are deleted, and replaced
    2182             : by the new completion."
    2183             :   (interactive "p")
    2184           0 :   (let ((point-at-start (point)))
    2185           0 :     (next-matching-history-element
    2186           0 :      (concat
    2187           0 :       "^" (regexp-quote (buffer-substring (minibuffer-prompt-end) (point))))
    2188           0 :      n)
    2189             :     ;; next-matching-history-element always puts us at (point-min).
    2190             :     ;; Move to the position we were at before changing the buffer contents.
    2191             :     ;; This is still sensible, because the text before point has not changed.
    2192           0 :     (goto-char point-at-start)))
    2193             : 
    2194             : (defun previous-complete-history-element (n)
    2195             :   "\
    2196             : Get previous history element which completes the minibuffer before the point.
    2197             : The contents of the minibuffer after the point are deleted, and replaced
    2198             : by the new completion."
    2199             :   (interactive "p")
    2200           0 :   (next-complete-history-element (- n)))
    2201             : 
    2202             : ;; For compatibility with the old subr of the same name.
    2203             : (defun minibuffer-prompt-width ()
    2204             :   "Return the display width of the minibuffer prompt.
    2205             : Return 0 if current buffer is not a minibuffer."
    2206             :   ;; Return the width of everything before the field at the end of
    2207             :   ;; the buffer; this should be 0 for normal buffers.
    2208           0 :   (1- (minibuffer-prompt-end)))
    2209             : 
    2210             : ;; isearch minibuffer history
    2211             : (add-hook 'minibuffer-setup-hook 'minibuffer-history-isearch-setup)
    2212             : 
    2213             : (defvar minibuffer-history-isearch-message-overlay)
    2214             : (make-variable-buffer-local 'minibuffer-history-isearch-message-overlay)
    2215             : 
    2216             : (defun minibuffer-history-isearch-setup ()
    2217             :   "Set up a minibuffer for using isearch to search the minibuffer history.
    2218             : Intended to be added to `minibuffer-setup-hook'."
    2219           0 :   (set (make-local-variable 'isearch-search-fun-function)
    2220           0 :        'minibuffer-history-isearch-search)
    2221           0 :   (set (make-local-variable 'isearch-message-function)
    2222           0 :        'minibuffer-history-isearch-message)
    2223           0 :   (set (make-local-variable 'isearch-wrap-function)
    2224           0 :        'minibuffer-history-isearch-wrap)
    2225           0 :   (set (make-local-variable 'isearch-push-state-function)
    2226           0 :        'minibuffer-history-isearch-push-state)
    2227           0 :   (add-hook 'isearch-mode-end-hook 'minibuffer-history-isearch-end nil t))
    2228             : 
    2229             : (defun minibuffer-history-isearch-end ()
    2230             :   "Clean up the minibuffer after terminating isearch in the minibuffer."
    2231           0 :   (if minibuffer-history-isearch-message-overlay
    2232           0 :       (delete-overlay minibuffer-history-isearch-message-overlay)))
    2233             : 
    2234             : (defun minibuffer-history-isearch-search ()
    2235             :   "Return the proper search function, for isearch in minibuffer history."
    2236             :   (lambda (string bound noerror)
    2237           0 :     (let ((search-fun
    2238             :            ;; Use standard functions to search within minibuffer text
    2239           0 :            (isearch-search-fun-default))
    2240             :           found)
    2241             :       ;; Avoid lazy-highlighting matches in the minibuffer prompt when
    2242             :       ;; searching forward.  Lazy-highlight calls this lambda with the
    2243             :       ;; bound arg, so skip the minibuffer prompt.
    2244           0 :       (if (and bound isearch-forward (< (point) (minibuffer-prompt-end)))
    2245           0 :           (goto-char (minibuffer-prompt-end)))
    2246           0 :       (or
    2247             :        ;; 1. First try searching in the initial minibuffer text
    2248           0 :        (funcall search-fun string
    2249           0 :                 (if isearch-forward bound (minibuffer-prompt-end))
    2250           0 :                 noerror)
    2251             :        ;; 2. If the above search fails, start putting next/prev history
    2252             :        ;; elements in the minibuffer successively, and search the string
    2253             :        ;; in them.  Do this only when bound is nil (i.e. not while
    2254             :        ;; lazy-highlighting search strings in the current minibuffer text).
    2255           0 :        (unless bound
    2256           0 :          (condition-case nil
    2257           0 :              (progn
    2258           0 :                (while (not found)
    2259           0 :                  (cond (isearch-forward
    2260           0 :                         (next-history-element 1)
    2261           0 :                         (goto-char (minibuffer-prompt-end)))
    2262             :                        (t
    2263           0 :                         (previous-history-element 1)
    2264           0 :                         (goto-char (point-max))))
    2265           0 :                  (setq isearch-barrier (point) isearch-opoint (point))
    2266             :                  ;; After putting the next/prev history element, search
    2267             :                  ;; the string in them again, until next-history-element
    2268             :                  ;; or previous-history-element raises an error at the
    2269             :                  ;; beginning/end of history.
    2270           0 :                  (setq found (funcall search-fun string
    2271           0 :                                       (unless isearch-forward
    2272             :                                         ;; For backward search, don't search
    2273             :                                         ;; in the minibuffer prompt
    2274           0 :                                         (minibuffer-prompt-end))
    2275           0 :                                       noerror)))
    2276             :                ;; Return point of the new search result
    2277           0 :                (point))
    2278             :            ;; Return nil when next(prev)-history-element fails
    2279           0 :            (error nil)))))))
    2280             : 
    2281             : (defun minibuffer-history-isearch-message (&optional c-q-hack ellipsis)
    2282             :   "Display the minibuffer history search prompt.
    2283             : If there are no search errors, this function displays an overlay with
    2284             : the isearch prompt which replaces the original minibuffer prompt.
    2285             : Otherwise, it displays the standard isearch message returned from
    2286             : the function `isearch-message'."
    2287           0 :   (if (not (and (minibufferp) isearch-success (not isearch-error)))
    2288             :       ;; Use standard function `isearch-message' when not in the minibuffer,
    2289             :       ;; or search fails, or has an error (like incomplete regexp).
    2290             :       ;; This function overwrites minibuffer text with isearch message,
    2291             :       ;; so it's possible to see what is wrong in the search string.
    2292           0 :       (isearch-message c-q-hack ellipsis)
    2293             :     ;; Otherwise, put the overlay with the standard isearch prompt over
    2294             :     ;; the initial minibuffer prompt.
    2295           0 :     (if (overlayp minibuffer-history-isearch-message-overlay)
    2296           0 :         (move-overlay minibuffer-history-isearch-message-overlay
    2297           0 :                       (point-min) (minibuffer-prompt-end))
    2298           0 :       (setq minibuffer-history-isearch-message-overlay
    2299           0 :             (make-overlay (point-min) (minibuffer-prompt-end)))
    2300           0 :       (overlay-put minibuffer-history-isearch-message-overlay 'evaporate t))
    2301           0 :     (overlay-put minibuffer-history-isearch-message-overlay
    2302           0 :                  'display (isearch-message-prefix c-q-hack ellipsis))
    2303             :     ;; And clear any previous isearch message.
    2304           0 :     (message "")))
    2305             : 
    2306             : (defun minibuffer-history-isearch-wrap ()
    2307             :   "Wrap the minibuffer history search when search fails.
    2308             : Move point to the first history element for a forward search,
    2309             : or to the last history element for a backward search."
    2310             :   ;; When `minibuffer-history-isearch-search' fails on reaching the
    2311             :   ;; beginning/end of the history, wrap the search to the first/last
    2312             :   ;; minibuffer history element.
    2313           0 :   (if isearch-forward
    2314           0 :       (goto-history-element (length (symbol-value minibuffer-history-variable)))
    2315           0 :     (goto-history-element 0))
    2316           0 :   (setq isearch-success t)
    2317           0 :   (goto-char (if isearch-forward (minibuffer-prompt-end) (point-max))))
    2318             : 
    2319             : (defun minibuffer-history-isearch-push-state ()
    2320             :   "Save a function restoring the state of minibuffer history search.
    2321             : Save `minibuffer-history-position' to the additional state parameter
    2322             : in the search status stack."
    2323           0 :   (let ((pos minibuffer-history-position))
    2324             :     (lambda (cmd)
    2325           0 :       (minibuffer-history-isearch-pop-state cmd pos))))
    2326             : 
    2327             : (defun minibuffer-history-isearch-pop-state (_cmd hist-pos)
    2328             :   "Restore the minibuffer history search state.
    2329             : Go to the history element by the absolute history position HIST-POS."
    2330           0 :   (goto-history-element hist-pos))
    2331             : 
    2332             : 
    2333             : ;Put this on C-x u, so we can force that rather than C-_ into startup msg
    2334             : (define-obsolete-function-alias 'advertised-undo 'undo "23.2")
    2335             : 
    2336             : (defconst undo-equiv-table (make-hash-table :test 'eq :weakness t)
    2337             :   "Table mapping redo records to the corresponding undo one.
    2338             : A redo record for undo-in-region maps to t.
    2339             : A redo record for ordinary undo maps to the following (earlier) undo.")
    2340             : 
    2341             : (defvar undo-in-region nil
    2342             :   "Non-nil if `pending-undo-list' is not just a tail of `buffer-undo-list'.")
    2343             : 
    2344             : (defvar undo-no-redo nil
    2345             :   "If t, `undo' doesn't go through redo entries.")
    2346             : 
    2347             : (defvar pending-undo-list nil
    2348             :   "Within a run of consecutive undo commands, list remaining to be undone.
    2349             : If t, we undid all the way to the end of it.")
    2350             : 
    2351             : (defun undo (&optional arg)
    2352             :   "Undo some previous changes.
    2353             : Repeat this command to undo more changes.
    2354             : A numeric ARG serves as a repeat count.
    2355             : 
    2356             : In Transient Mark mode when the mark is active, only undo changes within
    2357             : the current region.  Similarly, when not in Transient Mark mode, just \\[universal-argument]
    2358             : as an argument limits undo to changes within the current region."
    2359             :   (interactive "*P")
    2360             :   ;; Make last-command indicate for the next command that this was an undo.
    2361             :   ;; That way, another undo will undo more.
    2362             :   ;; If we get to the end of the undo history and get an error,
    2363             :   ;; another undo command will find the undo history empty
    2364             :   ;; and will get another error.  To begin undoing the undos,
    2365             :   ;; you must type some other command.
    2366           0 :   (let* ((modified (buffer-modified-p))
    2367             :          ;; For an indirect buffer, look in the base buffer for the
    2368             :          ;; auto-save data.
    2369           0 :          (base-buffer (or (buffer-base-buffer) (current-buffer)))
    2370           0 :          (recent-save (with-current-buffer base-buffer
    2371           0 :                         (recent-auto-save-p)))
    2372             :          message)
    2373             :     ;; If we get an error in undo-start,
    2374             :     ;; the next command should not be a "consecutive undo".
    2375             :     ;; So set `this-command' to something other than `undo'.
    2376           0 :     (setq this-command 'undo-start)
    2377             : 
    2378           0 :     (unless (and (eq last-command 'undo)
    2379           0 :                  (or (eq pending-undo-list t)
    2380             :                      ;; If something (a timer or filter?) changed the buffer
    2381             :                      ;; since the previous command, don't continue the undo seq.
    2382           0 :                      (let ((list buffer-undo-list))
    2383           0 :                        (while (eq (car list) nil)
    2384           0 :                          (setq list (cdr list)))
    2385             :                        ;; If the last undo record made was made by undo
    2386             :                        ;; it shows nothing else happened in between.
    2387           0 :                        (gethash list undo-equiv-table))))
    2388           0 :       (setq undo-in-region
    2389           0 :             (or (region-active-p) (and arg (not (numberp arg)))))
    2390           0 :       (if undo-in-region
    2391           0 :           (undo-start (region-beginning) (region-end))
    2392           0 :         (undo-start))
    2393             :       ;; get rid of initial undo boundary
    2394           0 :       (undo-more 1))
    2395             :     ;; If we got this far, the next command should be a consecutive undo.
    2396           0 :     (setq this-command 'undo)
    2397             :     ;; Check to see whether we're hitting a redo record, and if
    2398             :     ;; so, ask the user whether she wants to skip the redo/undo pair.
    2399           0 :     (let ((equiv (gethash pending-undo-list undo-equiv-table)))
    2400           0 :       (or (eq (selected-window) (minibuffer-window))
    2401           0 :           (setq message (format "%s%s!"
    2402           0 :                                 (if (or undo-no-redo (not equiv))
    2403           0 :                                     "Undo" "Redo")
    2404           0 :                                 (if undo-in-region " in region" ""))))
    2405           0 :       (when (and (consp equiv) undo-no-redo)
    2406             :         ;; The equiv entry might point to another redo record if we have done
    2407             :         ;; undo-redo-undo-redo-... so skip to the very last equiv.
    2408           0 :         (while (let ((next (gethash equiv undo-equiv-table)))
    2409           0 :                  (if next (setq equiv next))))
    2410           0 :         (setq pending-undo-list equiv)))
    2411           0 :     (undo-more
    2412           0 :      (if (numberp arg)
    2413           0 :          (prefix-numeric-value arg)
    2414           0 :        1))
    2415             :     ;; Record the fact that the just-generated undo records come from an
    2416             :     ;; undo operation--that is, they are redo records.
    2417             :     ;; In the ordinary case (not within a region), map the redo
    2418             :     ;; record to the following undos.
    2419             :     ;; I don't know how to do that in the undo-in-region case.
    2420           0 :     (let ((list buffer-undo-list))
    2421             :       ;; Strip any leading undo boundaries there might be, like we do
    2422             :       ;; above when checking.
    2423           0 :       (while (eq (car list) nil)
    2424           0 :         (setq list (cdr list)))
    2425           0 :       (puthash list
    2426             :                ;; Prevent identity mapping.  This can happen if
    2427             :                ;; consecutive nils are erroneously in undo list.
    2428           0 :                (if (or undo-in-region (eq list pending-undo-list))
    2429             :                    t
    2430           0 :                  pending-undo-list)
    2431           0 :                undo-equiv-table))
    2432             :     ;; Don't specify a position in the undo record for the undo command.
    2433             :     ;; Instead, undoing this should move point to where the change is.
    2434           0 :     (let ((tail buffer-undo-list)
    2435             :           (prev nil))
    2436           0 :       (while (car tail)
    2437           0 :         (when (integerp (car tail))
    2438           0 :           (let ((pos (car tail)))
    2439           0 :             (if prev
    2440           0 :                 (setcdr prev (cdr tail))
    2441           0 :               (setq buffer-undo-list (cdr tail)))
    2442           0 :             (setq tail (cdr tail))
    2443           0 :             (while (car tail)
    2444           0 :               (if (eq pos (car tail))
    2445           0 :                   (if prev
    2446           0 :                       (setcdr prev (cdr tail))
    2447           0 :                     (setq buffer-undo-list (cdr tail)))
    2448           0 :                 (setq prev tail))
    2449           0 :               (setq tail (cdr tail)))
    2450           0 :             (setq tail nil)))
    2451           0 :         (setq prev tail tail (cdr tail))))
    2452             :     ;; Record what the current undo list says,
    2453             :     ;; so the next command can tell if the buffer was modified in between.
    2454           0 :     (and modified (not (buffer-modified-p))
    2455           0 :          (with-current-buffer base-buffer
    2456           0 :            (delete-auto-save-file-if-necessary recent-save)))
    2457             :     ;; Display a message announcing success.
    2458           0 :     (if message
    2459           0 :         (message "%s" message))))
    2460             : 
    2461             : (defun buffer-disable-undo (&optional buffer)
    2462             :   "Make BUFFER stop keeping undo information.
    2463             : No argument or nil as argument means do this for the current buffer."
    2464             :   (interactive)
    2465           0 :   (with-current-buffer (if buffer (get-buffer buffer) (current-buffer))
    2466           0 :     (setq buffer-undo-list t)))
    2467             : 
    2468             : (defun undo-only (&optional arg)
    2469             :   "Undo some previous changes.
    2470             : Repeat this command to undo more changes.
    2471             : A numeric ARG serves as a repeat count.
    2472             : Contrary to `undo', this will not redo a previous undo."
    2473             :   (interactive "*p")
    2474           0 :   (let ((undo-no-redo t)) (undo arg)))
    2475             : 
    2476             : (defvar undo-in-progress nil
    2477             :   "Non-nil while performing an undo.
    2478             : Some change-hooks test this variable to do something different.")
    2479             : 
    2480             : (defun undo-more (n)
    2481             :   "Undo back N undo-boundaries beyond what was already undone recently.
    2482             : Call `undo-start' to get ready to undo recent changes,
    2483             : then call `undo-more' one or more times to undo them."
    2484           0 :   (or (listp pending-undo-list)
    2485           0 :       (user-error (concat "No further undo information"
    2486           0 :                           (and undo-in-region " for region"))))
    2487           0 :   (let ((undo-in-progress t))
    2488             :     ;; Note: The following, while pulling elements off
    2489             :     ;; `pending-undo-list' will call primitive change functions which
    2490             :     ;; will push more elements onto `buffer-undo-list'.
    2491           0 :     (setq pending-undo-list (primitive-undo n pending-undo-list))
    2492           0 :     (if (null pending-undo-list)
    2493           0 :         (setq pending-undo-list t))))
    2494             : 
    2495             : (defun primitive-undo (n list)
    2496             :   "Undo N records from the front of the list LIST.
    2497             : Return what remains of the list."
    2498             : 
    2499             :   ;; This is a good feature, but would make undo-start
    2500             :   ;; unable to do what is expected.
    2501             :   ;;(when (null (car (list)))
    2502             :   ;;  ;; If the head of the list is a boundary, it is the boundary
    2503             :   ;;  ;; preceding this command.  Get rid of it and don't count it.
    2504             :   ;;  (setq list (cdr list))))
    2505             : 
    2506           0 :   (let ((arg n)
    2507             :         ;; In a writable buffer, enable undoing read-only text that is
    2508             :         ;; so because of text properties.
    2509             :         (inhibit-read-only t)
    2510             :         ;; Don't let `intangible' properties interfere with undo.
    2511             :         (inhibit-point-motion-hooks t)
    2512             :         ;; We use oldlist only to check for EQ.  ++kfs
    2513           0 :         (oldlist buffer-undo-list)
    2514             :         (did-apply nil)
    2515             :         (next nil))
    2516           0 :     (while (> arg 0)
    2517           0 :       (while (setq next (pop list))     ;Exit inner loop at undo boundary.
    2518             :         ;; Handle an integer by setting point to that value.
    2519           0 :         (pcase next
    2520           0 :           ((pred integerp) (goto-char next))
    2521             :           ;; Element (t . TIME) records previous modtime.
    2522             :           ;; Preserve any flag of NONEXISTENT_MODTIME_NSECS or
    2523             :           ;; UNKNOWN_MODTIME_NSECS.
    2524             :           (`(t . ,time)
    2525             :            ;; If this records an obsolete save
    2526             :            ;; (not matching the actual disk file)
    2527             :            ;; then don't mark unmodified.
    2528           0 :            (when (or (equal time (visited-file-modtime))
    2529           0 :                      (and (consp time)
    2530           0 :                           (equal (list (car time) (cdr time))
    2531           0 :                                  (visited-file-modtime))))
    2532           0 :              (when (fboundp 'unlock-buffer)
    2533           0 :                (unlock-buffer))
    2534           0 :              (set-buffer-modified-p nil)))
    2535             :           ;; Element (nil PROP VAL BEG . END) is property change.
    2536             :           (`(nil . ,(or `(,prop ,val ,beg . ,end) pcase--dontcare))
    2537           0 :            (when (or (> (point-min) beg) (< (point-max) end))
    2538           0 :              (error "Changes to be undone are outside visible portion of buffer"))
    2539           0 :            (put-text-property beg end prop val))
    2540             :           ;; Element (BEG . END) means range was inserted.
    2541             :           (`(,(and beg (pred integerp)) . ,(and end (pred integerp)))
    2542             :            ;; (and `(,beg . ,end) `(,(pred integerp) . ,(pred integerp)))
    2543             :            ;; Ideally: `(,(pred integerp beg) . ,(pred integerp end))
    2544           0 :            (when (or (> (point-min) beg) (< (point-max) end))
    2545           0 :              (error "Changes to be undone are outside visible portion of buffer"))
    2546             :            ;; Set point first thing, so that undoing this undo
    2547             :            ;; does not send point back to where it is now.
    2548           0 :            (goto-char beg)
    2549           0 :            (delete-region beg end))
    2550             :           ;; Element (apply FUN . ARGS) means call FUN to undo.
    2551             :           (`(apply . ,fun-args)
    2552           0 :            (let ((currbuff (current-buffer)))
    2553           0 :              (if (integerp (car fun-args))
    2554             :                  ;; Long format: (apply DELTA START END FUN . ARGS).
    2555           0 :                  (pcase-let* ((`(,delta ,start ,end ,fun . ,args) fun-args)
    2556           0 :                               (start-mark (copy-marker start nil))
    2557           0 :                               (end-mark (copy-marker end t)))
    2558           0 :                    (when (or (> (point-min) start) (< (point-max) end))
    2559           0 :                      (error "Changes to be undone are outside visible portion of buffer"))
    2560           0 :                    (apply fun args) ;; Use `save-current-buffer'?
    2561             :                    ;; Check that the function did what the entry
    2562             :                    ;; said it would do.
    2563           0 :                    (unless (and (= start start-mark)
    2564           0 :                                 (= (+ delta end) end-mark))
    2565           0 :                      (error "Changes to be undone by function different than announced"))
    2566           0 :                    (set-marker start-mark nil)
    2567           0 :                    (set-marker end-mark nil))
    2568           0 :                (apply fun-args))
    2569           0 :              (unless (eq currbuff (current-buffer))
    2570           0 :                (error "Undo function switched buffer"))
    2571           0 :              (setq did-apply t)))
    2572             :           ;; Element (STRING . POS) means STRING was deleted.
    2573             :           (`(,(and string (pred stringp)) . ,(and pos (pred integerp)))
    2574           0 :            (when (let ((apos (abs pos)))
    2575           0 :                    (or (< apos (point-min)) (> apos (point-max))))
    2576           0 :              (error "Changes to be undone are outside visible portion of buffer"))
    2577           0 :            (let (valid-marker-adjustments)
    2578             :              ;; Check that marker adjustments which were recorded
    2579             :              ;; with the (STRING . POS) record are still valid, ie
    2580             :              ;; the markers haven't moved.  We check their validity
    2581             :              ;; before reinserting the string so as we don't need to
    2582             :              ;; mind marker insertion-type.
    2583           0 :              (while (and (markerp (car-safe (car list)))
    2584           0 :                          (integerp (cdr-safe (car list))))
    2585           0 :                (let* ((marker-adj (pop list))
    2586           0 :                       (m (car marker-adj)))
    2587           0 :                  (and (eq (marker-buffer m) (current-buffer))
    2588           0 :                       (= pos m)
    2589           0 :                       (push marker-adj valid-marker-adjustments))))
    2590             :              ;; Insert string and adjust point
    2591           0 :              (if (< pos 0)
    2592           0 :                  (progn
    2593           0 :                    (goto-char (- pos))
    2594           0 :                    (insert string))
    2595           0 :                (goto-char pos)
    2596           0 :                (insert string)
    2597           0 :                (goto-char pos))
    2598             :              ;; Adjust the valid marker adjustments
    2599           0 :              (dolist (adj valid-marker-adjustments)
    2600             :                ;; Insert might have invalidated some of the markers
    2601             :                ;; via modification hooks.  Update only the currently
    2602             :                ;; valid ones (bug#25599).
    2603           0 :                (if (marker-buffer (car adj))
    2604           0 :                    (set-marker (car adj)
    2605           0 :                                (- (car adj) (cdr adj)))))))
    2606             :           ;; (MARKER . OFFSET) means a marker MARKER was adjusted by OFFSET.
    2607             :           (`(,(and marker (pred markerp)) . ,(and offset (pred integerp)))
    2608           0 :            (warn "Encountered %S entry in undo list with no matching (TEXT . POS) entry"
    2609           0 :                  next)
    2610             :            ;; Even though these elements are not expected in the undo
    2611             :            ;; list, adjust them to be conservative for the 24.4
    2612             :            ;; release.  (Bug#16818)
    2613           0 :            (when (marker-buffer marker)
    2614           0 :              (set-marker marker
    2615           0 :                          (- marker offset)
    2616           0 :                          (marker-buffer marker))))
    2617           0 :           (_ (error "Unrecognized entry in undo list %S" next))))
    2618           0 :       (setq arg (1- arg)))
    2619             :     ;; Make sure an apply entry produces at least one undo entry,
    2620             :     ;; so the test in `undo' for continuing an undo series
    2621             :     ;; will work right.
    2622           0 :     (if (and did-apply
    2623           0 :              (eq oldlist buffer-undo-list))
    2624           0 :         (setq buffer-undo-list
    2625           0 :               (cons (list 'apply 'cdr nil) buffer-undo-list))))
    2626           0 :   list)
    2627             : 
    2628             : ;; Deep copy of a list
    2629             : (defun undo-copy-list (list)
    2630             :   "Make a copy of undo list LIST."
    2631           0 :   (mapcar 'undo-copy-list-1 list))
    2632             : 
    2633             : (defun undo-copy-list-1 (elt)
    2634           0 :   (if (consp elt)
    2635           0 :       (cons (car elt) (undo-copy-list-1 (cdr elt)))
    2636           0 :     elt))
    2637             : 
    2638             : (defun undo-start (&optional beg end)
    2639             :   "Set `pending-undo-list' to the front of the undo list.
    2640             : The next call to `undo-more' will undo the most recently made change.
    2641             : If BEG and END are specified, then only undo elements
    2642             : that apply to text between BEG and END are used; other undo elements
    2643             : are ignored.  If BEG and END are nil, all undo elements are used."
    2644           0 :   (if (eq buffer-undo-list t)
    2645           0 :       (user-error "No undo information in this buffer"))
    2646           0 :   (setq pending-undo-list
    2647           0 :         (if (and beg end (not (= beg end)))
    2648           0 :             (undo-make-selective-list (min beg end) (max beg end))
    2649           0 :           buffer-undo-list)))
    2650             : 
    2651             : ;; The positions given in elements of the undo list are the positions
    2652             : ;; as of the time that element was recorded to undo history.  In
    2653             : ;; general, subsequent buffer edits render those positions invalid in
    2654             : ;; the current buffer, unless adjusted according to the intervening
    2655             : ;; undo elements.
    2656             : ;;
    2657             : ;; Undo in region is a use case that requires adjustments to undo
    2658             : ;; elements.  It must adjust positions of elements in the region based
    2659             : ;; on newer elements not in the region so as they may be correctly
    2660             : ;; applied in the current buffer.  undo-make-selective-list
    2661             : ;; accomplishes this with its undo-deltas list of adjustments.  An
    2662             : ;; example undo history from oldest to newest:
    2663             : ;;
    2664             : ;; buf pos:
    2665             : ;; 123456789 buffer-undo-list undo-deltas
    2666             : ;; --------- ---------------- -----------
    2667             : ;; aaa       (1 . 4)          (1 . -3)
    2668             : ;; aaba      (3 . 4)          N/A (in region)
    2669             : ;; ccaaba    (1 . 3)          (1 . -2)
    2670             : ;; ccaabaddd (7 . 10)         (7 . -3)
    2671             : ;; ccaabdd   ("ad" . 6)       (6 . 2)
    2672             : ;; ccaabaddd (6 . 8)          (6 . -2)
    2673             : ;;  |   |<-- region: "caab", from 2 to 6
    2674             : ;;
    2675             : ;; When the user starts a run of undos in region,
    2676             : ;; undo-make-selective-list is called to create the full list of in
    2677             : ;; region elements.  Each element is adjusted forward chronologically
    2678             : ;; through undo-deltas to determine if it is in the region.
    2679             : ;;
    2680             : ;; In the above example, the insertion of "b" is (3 . 4) in the
    2681             : ;; buffer-undo-list.  The undo-delta (1 . -2) causes (3 . 4) to become
    2682             : ;; (5 . 6).  The next three undo-deltas cause no adjustment, so (5
    2683             : ;; . 6) is assessed as in the region and placed in the selective list.
    2684             : ;; Notably, the end of region itself adjusts from "2 to 6" to "2 to 5"
    2685             : ;; due to the selected element.  The "b" insertion is the only element
    2686             : ;; fully in the region, so in this example undo-make-selective-list
    2687             : ;; returns (nil (5 . 6)).
    2688             : ;;
    2689             : ;; The adjustment of the (7 . 10) insertion of "ddd" shows an edge
    2690             : ;; case.  It is adjusted through the undo-deltas: ((6 . 2) (6 . -2)).
    2691             : ;; Normally an undo-delta of (6 . 2) would cause positions after 6 to
    2692             : ;; adjust by 2.  However, they shouldn't adjust to less than 6, so (7
    2693             : ;; . 10) adjusts to (6 . 8) due to the first undo delta.
    2694             : ;;
    2695             : ;; More interesting is how to adjust the "ddd" insertion due to the
    2696             : ;; next undo-delta: (6 . -2), corresponding to reinsertion of "ad".
    2697             : ;; If the reinsertion was a manual retyping of "ad", then the total
    2698             : ;; adjustment should be (7 . 10) -> (6 . 8) -> (8 . 10).  However, if
    2699             : ;; the reinsertion was due to undo, one might expect the first "d"
    2700             : ;; character would again be a part of the "ddd" text, meaning its
    2701             : ;; total adjustment would be (7 . 10) -> (6 . 8) -> (7 . 10).
    2702             : ;;
    2703             : ;; undo-make-selective-list assumes in this situation that "ad" was a
    2704             : ;; new edit, even if it was inserted because of an undo.
    2705             : ;; Consequently, if the user undos in region "8 to 10" of the
    2706             : ;; "ccaabaddd" buffer, they could be surprised that it becomes
    2707             : ;; "ccaabad", as though the first "d" became detached from the
    2708             : ;; original "ddd" insertion.  This quirk is a FIXME.
    2709             : 
    2710             : (defun undo-make-selective-list (start end)
    2711             :   "Return a list of undo elements for the region START to END.
    2712             : The elements come from `buffer-undo-list', but we keep only the
    2713             : elements inside this region, and discard those outside this
    2714             : region.  The elements' positions are adjusted so as the returned
    2715             : list can be applied to the current buffer."
    2716           0 :   (let ((ulist buffer-undo-list)
    2717             :         ;; A list of position adjusted undo elements in the region.
    2718           0 :         (selective-list (list nil))
    2719             :         ;; A list of undo-deltas for out of region undo elements.
    2720             :         undo-deltas
    2721             :         undo-elt)
    2722           0 :     (while ulist
    2723           0 :       (when undo-no-redo
    2724           0 :         (while (gethash ulist undo-equiv-table)
    2725           0 :           (setq ulist (gethash ulist undo-equiv-table))))
    2726           0 :       (setq undo-elt (car ulist))
    2727           0 :       (cond
    2728           0 :        ((null undo-elt)
    2729             :         ;; Don't put two nils together in the list
    2730           0 :         (when (car selective-list)
    2731           0 :           (push nil selective-list)))
    2732           0 :        ((and (consp undo-elt) (eq (car undo-elt) t))
    2733             :         ;; This is a "was unmodified" element.  Keep it
    2734             :         ;; if we have kept everything thus far.
    2735           0 :         (when (not undo-deltas)
    2736           0 :           (push undo-elt selective-list)))
    2737             :        ;; Skip over marker adjustments, instead relying
    2738             :        ;; on finding them after (TEXT . POS) elements
    2739           0 :        ((markerp (car-safe undo-elt))
    2740             :         nil)
    2741             :        (t
    2742           0 :         (let ((adjusted-undo-elt (undo-adjust-elt undo-elt
    2743           0 :                                                   undo-deltas)))
    2744           0 :           (if (undo-elt-in-region adjusted-undo-elt start end)
    2745           0 :               (progn
    2746           0 :                 (setq end (+ end (cdr (undo-delta adjusted-undo-elt))))
    2747           0 :                 (push adjusted-undo-elt selective-list)
    2748             :                 ;; Keep (MARKER . ADJUSTMENT) if their (TEXT . POS) was
    2749             :                 ;; kept.  primitive-undo may discard them later.
    2750           0 :                 (when (and (stringp (car-safe adjusted-undo-elt))
    2751           0 :                            (integerp (cdr-safe adjusted-undo-elt)))
    2752           0 :                   (let ((list-i (cdr ulist)))
    2753           0 :                     (while (markerp (car-safe (car list-i)))
    2754           0 :                       (push (pop list-i) selective-list)))))
    2755           0 :             (let ((delta (undo-delta undo-elt)))
    2756           0 :               (when (/= 0 (cdr delta))
    2757           0 :                 (push delta undo-deltas)))))))
    2758           0 :       (pop ulist))
    2759           0 :     (nreverse selective-list)))
    2760             : 
    2761             : (defun undo-elt-in-region (undo-elt start end)
    2762             :   "Determine whether UNDO-ELT falls inside the region START ... END.
    2763             : If it crosses the edge, we return nil.
    2764             : 
    2765             : Generally this function is not useful for determining
    2766             : whether (MARKER . ADJUSTMENT) undo elements are in the region,
    2767             : because markers can be arbitrarily relocated.  Instead, pass the
    2768             : marker adjustment's corresponding (TEXT . POS) element."
    2769           0 :   (cond ((integerp undo-elt)
    2770           0 :          (and (>= undo-elt start)
    2771           0 :               (<= undo-elt end)))
    2772           0 :         ((eq undo-elt nil)
    2773             :          t)
    2774           0 :         ((atom undo-elt)
    2775             :          nil)
    2776           0 :         ((stringp (car undo-elt))
    2777             :          ;; (TEXT . POSITION)
    2778           0 :          (and (>= (abs (cdr undo-elt)) start)
    2779           0 :               (<= (abs (cdr undo-elt)) end)))
    2780           0 :         ((and (consp undo-elt) (markerp (car undo-elt)))
    2781             :          ;; (MARKER . ADJUSTMENT)
    2782           0 :          (<= start (car undo-elt) end))
    2783           0 :         ((null (car undo-elt))
    2784             :          ;; (nil PROPERTY VALUE BEG . END)
    2785           0 :          (let ((tail (nthcdr 3 undo-elt)))
    2786           0 :            (and (>= (car tail) start)
    2787           0 :                 (<= (cdr tail) end))))
    2788           0 :         ((integerp (car undo-elt))
    2789             :          ;; (BEGIN . END)
    2790           0 :          (and (>= (car undo-elt) start)
    2791           0 :               (<= (cdr undo-elt) end)))))
    2792             : 
    2793             : (defun undo-elt-crosses-region (undo-elt start end)
    2794             :   "Test whether UNDO-ELT crosses one edge of that region START ... END.
    2795             : This assumes we have already decided that UNDO-ELT
    2796             : is not *inside* the region START...END."
    2797             :   (declare (obsolete nil "25.1"))
    2798           0 :   (cond ((atom undo-elt) nil)
    2799           0 :         ((null (car undo-elt))
    2800             :          ;; (nil PROPERTY VALUE BEG . END)
    2801           0 :          (let ((tail (nthcdr 3 undo-elt)))
    2802           0 :            (and (< (car tail) end)
    2803           0 :                 (> (cdr tail) start))))
    2804           0 :         ((integerp (car undo-elt))
    2805             :          ;; (BEGIN . END)
    2806           0 :          (and (< (car undo-elt) end)
    2807           0 :               (> (cdr undo-elt) start)))))
    2808             : 
    2809             : (defun undo-adjust-elt (elt deltas)
    2810             :   "Return adjustment of undo element ELT by the undo DELTAS
    2811             : list."
    2812           0 :   (pcase elt
    2813             :     ;; POSITION
    2814             :     ((pred integerp)
    2815           0 :      (undo-adjust-pos elt deltas))
    2816             :     ;; (BEG . END)
    2817             :     (`(,(and beg (pred integerp)) . ,(and end (pred integerp)))
    2818           0 :      (undo-adjust-beg-end beg end deltas))
    2819             :     ;; (TEXT . POSITION)
    2820             :     (`(,(and text (pred stringp)) . ,(and pos (pred integerp)))
    2821           0 :      (cons text (* (if (< pos 0) -1 1)
    2822           0 :                    (undo-adjust-pos (abs pos) deltas))))
    2823             :     ;; (nil PROPERTY VALUE BEG . END)
    2824             :     (`(nil . ,(or `(,prop ,val ,beg . ,end) pcase--dontcare))
    2825           0 :      `(nil ,prop ,val . ,(undo-adjust-beg-end beg end deltas)))
    2826             :     ;; (apply DELTA START END FUN . ARGS)
    2827             :     ;; FIXME
    2828             :     ;; All others return same elt
    2829           0 :     (_ elt)))
    2830             : 
    2831             : ;; (BEG . END) can adjust to the same positions, commonly when an
    2832             : ;; insertion was undone and they are out of region, for example:
    2833             : ;;
    2834             : ;; buf pos:
    2835             : ;; 123456789 buffer-undo-list undo-deltas
    2836             : ;; --------- ---------------- -----------
    2837             : ;; [...]
    2838             : ;; abbaa     (2 . 4)          (2 . -2)
    2839             : ;; aaa       ("bb" . 2)       (2 . 2)
    2840             : ;; [...]
    2841             : ;;
    2842             : ;; "bb" insertion (2 . 4) adjusts to (2 . 2) because of the subsequent
    2843             : ;; undo.  Further adjustments to such an element should be the same as
    2844             : ;; for (TEXT . POSITION) elements.  The options are:
    2845             : ;;
    2846             : ;;   1: POSITION adjusts using <= (use-< nil), resulting in behavior
    2847             : ;;      analogous to marker insertion-type t.
    2848             : ;;
    2849             : ;;   2: POSITION adjusts using <, resulting in behavior analogous to
    2850             : ;;      marker insertion-type nil.
    2851             : ;;
    2852             : ;; There was no strong reason to prefer one or the other, except that
    2853             : ;; the first is more consistent with prior undo in region behavior.
    2854             : (defun undo-adjust-beg-end (beg end deltas)
    2855             :   "Return cons of adjustments to BEG and END by the undo DELTAS
    2856             : list."
    2857           0 :   (let ((adj-beg (undo-adjust-pos beg deltas)))
    2858             :     ;; Note: option 2 above would be like (cons (min ...) adj-end)
    2859           0 :     (cons adj-beg
    2860           0 :           (max adj-beg (undo-adjust-pos end deltas t)))))
    2861             : 
    2862             : (defun undo-adjust-pos (pos deltas &optional use-<)
    2863             :   "Return adjustment of POS by the undo DELTAS list, comparing
    2864             : with < or <= based on USE-<."
    2865           0 :   (dolist (d deltas pos)
    2866           0 :     (when (if use-<
    2867           0 :               (< (car d) pos)
    2868           0 :             (<= (car d) pos))
    2869           0 :       (setq pos
    2870             :             ;; Don't allow pos to become less than the undo-delta
    2871             :             ;; position.  This edge case is described in the overview
    2872             :             ;; comments.
    2873           0 :             (max (car d) (- pos (cdr d)))))))
    2874             : 
    2875             : ;; Return the first affected buffer position and the delta for an undo element
    2876             : ;; delta is defined as the change in subsequent buffer positions if we *did*
    2877             : ;; the undo.
    2878             : (defun undo-delta (undo-elt)
    2879           0 :   (if (consp undo-elt)
    2880           0 :       (cond ((stringp (car undo-elt))
    2881             :              ;; (TEXT . POSITION)
    2882           0 :              (cons (abs (cdr undo-elt)) (length (car undo-elt))))
    2883           0 :             ((integerp (car undo-elt))
    2884             :              ;; (BEGIN . END)
    2885           0 :              (cons (car undo-elt) (- (car undo-elt) (cdr undo-elt))))
    2886             :             (t
    2887           0 :              '(0 . 0)))
    2888           0 :     '(0 . 0)))
    2889             : 
    2890             : ;;; Default undo-boundary addition
    2891             : ;;
    2892             : ;; This section adds a new undo-boundary at either after a command is
    2893             : ;; called or in some cases on a timer called after a change is made in
    2894             : ;; any buffer.
    2895             : (defvar-local undo-auto--last-boundary-cause nil
    2896             :   "Describe the cause of the last undo-boundary.
    2897             : 
    2898             : If `explicit', the last boundary was caused by an explicit call to
    2899             : `undo-boundary', that is one not called by the code in this
    2900             : section.
    2901             : 
    2902             : If it is equal to `timer', then the last boundary was inserted
    2903             : by `undo-auto--boundary-timer'.
    2904             : 
    2905             : If it is equal to `command', then the last boundary was inserted
    2906             : automatically after a command, that is by the code defined in
    2907             : this section.
    2908             : 
    2909             : If it is equal to a list, then the last boundary was inserted by
    2910             : an amalgamating command.  The car of the list is the number of
    2911             : times an amalgamating command has been called, and the cdr are the
    2912             : buffers that were changed during the last command.")
    2913             : 
    2914             : (defvar undo-auto-current-boundary-timer nil
    2915             :   "Current timer which will run `undo-auto--boundary-timer' or nil.
    2916             : 
    2917             : If set to non-nil, this will effectively disable the timer.")
    2918             : 
    2919             : (defvar undo-auto--this-command-amalgamating nil
    2920             :   "Non-nil if `this-command' should be amalgamated.
    2921             : This variable is set to nil by `undo-auto--boundaries' and is set
    2922             : by `undo-auto-amalgamate'." )
    2923             : 
    2924             : (defun undo-auto--needs-boundary-p ()
    2925             :   "Return non-nil if `buffer-undo-list' needs a boundary at the start."
    2926           7 :   (car-safe buffer-undo-list))
    2927             : 
    2928             : (defun undo-auto--last-boundary-amalgamating-number ()
    2929             :   "Return the number of amalgamating last commands or nil.
    2930             : Amalgamating commands are, by default, either
    2931             : `self-insert-command' and `delete-char', but can be any command
    2932             : that calls `undo-auto-amalgamate'."
    2933         411 :   (car-safe undo-auto--last-boundary-cause))
    2934             : 
    2935             : (defun undo-auto--ensure-boundary (cause)
    2936             :   "Add an `undo-boundary' to the current buffer if needed.
    2937             : REASON describes the reason that the boundary is being added; see
    2938             : `undo-auto--last-boundary' for more information."
    2939           7 :   (when (and
    2940           7 :          (undo-auto--needs-boundary-p))
    2941           7 :     (let ((last-amalgamating
    2942           7 :            (undo-auto--last-boundary-amalgamating-number)))
    2943           7 :       (undo-boundary)
    2944           7 :       (setq undo-auto--last-boundary-cause
    2945           7 :             (if (eq 'amalgamate cause)
    2946           0 :                 (cons
    2947           0 :                  (if last-amalgamating (1+ last-amalgamating) 0)
    2948           0 :                  undo-auto--undoably-changed-buffers)
    2949           7 :               cause)))))
    2950             : 
    2951             : (defun undo-auto--boundaries (cause)
    2952             :   "Check recently changed buffers and add a boundary if necessary.
    2953             : REASON describes the reason that the boundary is being added; see
    2954             : `undo-last-boundary' for more information."
    2955             :   ;; (Bug #23785) All commands should ensure that there is an undo
    2956             :   ;; boundary whether they have changed the current buffer or not.
    2957           1 :   (when (eq cause 'command)
    2958           1 :     (add-to-list 'undo-auto--undoably-changed-buffers (current-buffer)))
    2959           1 :   (dolist (b undo-auto--undoably-changed-buffers)
    2960           7 :           (when (buffer-live-p b)
    2961           7 :             (with-current-buffer b
    2962           7 :               (undo-auto--ensure-boundary cause))))
    2963           1 :   (setq undo-auto--undoably-changed-buffers nil))
    2964             : 
    2965             : (defun undo-auto--boundary-timer ()
    2966             :   "Timer which will run `undo--auto-boundary-timer'."
    2967           1 :   (setq undo-auto-current-boundary-timer nil)
    2968           1 :   (undo-auto--boundaries 'timer))
    2969             : 
    2970             : (defun undo-auto--boundary-ensure-timer ()
    2971             :   "Ensure that the `undo-auto-boundary-timer' is set."
    2972          10 :   (unless undo-auto-current-boundary-timer
    2973           2 :     (setq undo-auto-current-boundary-timer
    2974          10 :           (run-at-time 10 nil #'undo-auto--boundary-timer))))
    2975             : 
    2976             : (defvar undo-auto--undoably-changed-buffers nil
    2977             :   "List of buffers that have changed recently.
    2978             : 
    2979             : This list is maintained by `undo-auto--undoable-change' and
    2980             : `undo-auto--boundaries' and can be affected by changes to their
    2981             : default values.")
    2982             : 
    2983             : (defun undo-auto--add-boundary ()
    2984             :   "Add an `undo-boundary' in appropriate buffers."
    2985           0 :   (undo-auto--boundaries
    2986           0 :    (let ((amal undo-auto--this-command-amalgamating))
    2987           0 :        (setq undo-auto--this-command-amalgamating nil)
    2988           0 :        (if amal
    2989             :            'amalgamate
    2990           0 :          'command))))
    2991             : 
    2992             : (defun undo-auto-amalgamate ()
    2993             :   "Amalgamate undo if necessary.
    2994             : This function can be called before an amalgamating command.  It
    2995             : removes the previous `undo-boundary' if a series of such calls
    2996             : have been made.  By default `self-insert-command' and
    2997             : `delete-char' are the only amalgamating commands, although this
    2998             : function could be called by any command wishing to have this
    2999             : behavior."
    3000         404 :   (let ((last-amalgamating-count
    3001         404 :          (undo-auto--last-boundary-amalgamating-number)))
    3002         404 :     (setq undo-auto--this-command-amalgamating t)
    3003         404 :     (when
    3004         404 :         last-amalgamating-count
    3005           0 :       (if
    3006           0 :           (and
    3007           0 :            (< last-amalgamating-count 20)
    3008           0 :            (eq this-command last-command))
    3009             :           ;; Amalgamate all buffers that have changed.
    3010           0 :           (dolist (b (cdr undo-auto--last-boundary-cause))
    3011           0 :             (when (buffer-live-p b)
    3012           0 :               (with-current-buffer
    3013           0 :                   b
    3014           0 :                 (when
    3015             :                     ;; The head of `buffer-undo-list' is nil.
    3016             :                     ;; `car-safe' doesn't work because
    3017             :                     ;; `buffer-undo-list' need not be a list!
    3018           0 :                     (and (listp buffer-undo-list)
    3019           0 :                          (not (car buffer-undo-list)))
    3020           0 :                   (setq buffer-undo-list
    3021           0 :                         (cdr buffer-undo-list))))))
    3022         404 :         (setq undo-auto--last-boundary-cause 0)))))
    3023             : 
    3024             : (defun undo-auto--undoable-change ()
    3025             :   "Called after every undoable buffer change."
    3026          10 :   (add-to-list 'undo-auto--undoably-changed-buffers (current-buffer))
    3027          10 :   (undo-auto--boundary-ensure-timer))
    3028             : ;; End auto-boundary section
    3029             : 
    3030             : (defun undo-amalgamate-change-group (handle)
    3031             :   "Amalgamate changes in change-group since HANDLE.
    3032             : Remove all undo boundaries between the state of HANDLE and now.
    3033             : HANDLE is as returned by `prepare-change-group'."
    3034           0 :   (dolist (elt handle)
    3035           0 :     (with-current-buffer (car elt)
    3036           0 :       (setq elt (cdr elt))
    3037           0 :       (when (consp buffer-undo-list)
    3038           0 :         (let ((old-car (car-safe elt))
    3039           0 :               (old-cdr (cdr-safe elt)))
    3040           0 :           (unwind-protect
    3041           0 :               (progn
    3042             :                 ;; Temporarily truncate the undo log at ELT.
    3043           0 :                 (when (consp elt)
    3044           0 :                   (setcar elt t) (setcdr elt nil))
    3045           0 :                 (when
    3046           0 :                     (or (null elt)        ;The undo-log was empty.
    3047             :                         ;; `elt' is still in the log: normal case.
    3048           0 :                         (eq elt (last buffer-undo-list))
    3049             :                         ;; `elt' is not in the log any more, but that's because
    3050             :                         ;; the log is "all new", so we should remove all
    3051             :                         ;; boundaries from it.
    3052           0 :                         (not (eq (last buffer-undo-list) (last old-cdr))))
    3053           0 :                   (cl-callf (lambda (x) (delq nil x))
    3054           0 :                       (if (car buffer-undo-list)
    3055           0 :                           buffer-undo-list
    3056             :                         ;; Preserve the undo-boundaries at either ends of the
    3057             :                         ;; change-groups.
    3058           0 :                         (cdr buffer-undo-list)))))
    3059             :             ;; Reset the modified cons cell ELT to its original content.
    3060           0 :             (when (consp elt)
    3061           0 :               (setcar elt old-car)
    3062           0 :               (setcdr elt old-cdr))))))))
    3063             : 
    3064             : 
    3065             : (defcustom undo-ask-before-discard nil
    3066             :   "If non-nil ask about discarding undo info for the current command.
    3067             : Normally, Emacs discards the undo info for the current command if
    3068             : it exceeds `undo-outer-limit'.  But if you set this option
    3069             : non-nil, it asks in the echo area whether to discard the info.
    3070             : If you answer no, there is a slight risk that Emacs might crash, so
    3071             : only do it if you really want to undo the command.
    3072             : 
    3073             : This option is mainly intended for debugging.  You have to be
    3074             : careful if you use it for other purposes.  Garbage collection is
    3075             : inhibited while the question is asked, meaning that Emacs might
    3076             : leak memory.  So you should make sure that you do not wait
    3077             : excessively long before answering the question."
    3078             :   :type 'boolean
    3079             :   :group 'undo
    3080             :   :version "22.1")
    3081             : 
    3082             : (defvar undo-extra-outer-limit nil
    3083             :   "If non-nil, an extra level of size that's ok in an undo item.
    3084             : We don't ask the user about truncating the undo list until the
    3085             : current item gets bigger than this amount.
    3086             : 
    3087             : This variable only matters if `undo-ask-before-discard' is non-nil.")
    3088             : (make-variable-buffer-local 'undo-extra-outer-limit)
    3089             : 
    3090             : ;; When the first undo batch in an undo list is longer than
    3091             : ;; undo-outer-limit, this function gets called to warn the user that
    3092             : ;; the undo info for the current command was discarded.  Garbage
    3093             : ;; collection is inhibited around the call, so it had better not do a
    3094             : ;; lot of consing.
    3095             : (setq undo-outer-limit-function 'undo-outer-limit-truncate)
    3096             : (defun undo-outer-limit-truncate (size)
    3097           0 :   (if undo-ask-before-discard
    3098           0 :       (when (or (null undo-extra-outer-limit)
    3099           0 :                 (> size undo-extra-outer-limit))
    3100             :         ;; Don't ask the question again unless it gets even bigger.
    3101             :         ;; This applies, in particular, if the user quits from the question.
    3102             :         ;; Such a quit quits out of GC, but something else will call GC
    3103             :         ;; again momentarily.  It will call this function again,
    3104             :         ;; but we don't want to ask the question again.
    3105           0 :         (setq undo-extra-outer-limit (+ size 50000))
    3106           0 :         (if (let (use-dialog-box track-mouse executing-kbd-macro )
    3107           0 :               (yes-or-no-p (format-message
    3108             :                             "Buffer `%s' undo info is %d bytes long; discard it? "
    3109           0 :                             (buffer-name) size)))
    3110           0 :             (progn (setq buffer-undo-list nil)
    3111           0 :                    (setq undo-extra-outer-limit nil)
    3112           0 :                    t)
    3113           0 :           nil))
    3114           0 :     (display-warning '(undo discard-info)
    3115           0 :                      (concat
    3116           0 :                       (format-message
    3117             :                        "Buffer `%s' undo info was %d bytes long.\n"
    3118           0 :                        (buffer-name) size)
    3119             :                       "The undo info was discarded because it exceeded \
    3120             : `undo-outer-limit'.
    3121             : 
    3122             : This is normal if you executed a command that made a huge change
    3123             : to the buffer.  In that case, to prevent similar problems in the
    3124             : future, set `undo-outer-limit' to a value that is large enough to
    3125             : cover the maximum size of normal changes you expect a single
    3126             : command to make, but not so large that it might exceed the
    3127             : maximum memory allotted to Emacs.
    3128             : 
    3129             : If you did not execute any such command, the situation is
    3130             : probably due to a bug and you should report it.
    3131             : 
    3132             : You can disable the popping up of this buffer by adding the entry
    3133             : \(undo discard-info) to the user option `warning-suppress-types',
    3134           0 : which is defined in the `warnings' library.\n")
    3135           0 :                      :warning)
    3136           0 :     (setq buffer-undo-list nil)
    3137           0 :     t))
    3138             : 
    3139             : (defcustom password-word-equivalents
    3140             :   '("password" "passcode" "passphrase" "pass phrase"
    3141             :     ; These are sorted according to the GNU en_US locale.
    3142             :     "암호"          ; ko
    3143             :     "パスワード" ; ja
    3144             :     "ପ୍ରବେଶ ସଙ୍କେତ"   ; or
    3145             :     "ពាក្យសម្ងាត់"            ; km
    3146             :     "adgangskode"     ; da
    3147             :     "contraseña"     ; es
    3148             :     "contrasenya"     ; ca
    3149             :     "geslo"           ; sl
    3150             :     "hasło"          ; pl
    3151             :     "heslo"           ; cs, sk
    3152             :     "iphasiwedi"      ; zu
    3153             :     "jelszó"         ; hu
    3154             :     "lösenord"               ; sv
    3155             :     "lozinka"         ; hr, sr
    3156             :     "mật khẩu"            ; vi
    3157             :     "mot de passe"    ; fr
    3158             :     "parola"          ; tr
    3159             :     "pasahitza"               ; eu
    3160             :     "passord"         ; nb
    3161             :     "passwort"                ; de
    3162             :     "pasvorto"                ; eo
    3163             :     "salasana"                ; fi
    3164             :     "senha"           ; pt
    3165             :     "slaptažodis"    ; lt
    3166             :     "wachtwoord"      ; nl
    3167             :     "كلمة السر"               ; ar
    3168             :     "ססמה"                ; he
    3169             :     "лозинка"          ; sr
    3170             :     "пароль"            ; kk, ru, uk
    3171             :     "गुप्तशब्द"             ; mr
    3172             :     "शब्दकूट"           ; hi
    3173             :     "પાસવર્ડ"           ; gu
    3174             :     "సంకేతపదము"             ; te
    3175             :     "ਪਾਸਵਰਡ"              ; pa
    3176             :     "ಗುಪ್ತಪದ"           ; kn
    3177             :     "கடவுச்சொல்"          ; ta
    3178             :     "അടയാളവാക്ക്"               ; ml
    3179             :     "গুপ্তশব্দ"             ; as
    3180             :     "পাসওয়ার্ড"             ; bn_IN
    3181             :     "රහස්පදය"           ; si
    3182             :     "密码"          ; zh_CN
    3183             :     "密碼"          ; zh_TW
    3184             :     )
    3185             :   "List of words equivalent to \"password\".
    3186             : This is used by Shell mode and other parts of Emacs to recognize
    3187             : password prompts, including prompts in languages other than
    3188             : English.  Different case choices should not be assumed to be
    3189             : included; callers should bind `case-fold-search' to t."
    3190             :   :type '(repeat string)
    3191             :   :version "24.4"
    3192             :   :group 'processes)
    3193             : 
    3194             : (defvar shell-command-history nil
    3195             :   "History list for some commands that read shell commands.
    3196             : 
    3197             : Maximum length of the history list is determined by the value
    3198             : of `history-length', which see.")
    3199             : 
    3200             : (defvar shell-command-switch (purecopy "-c")
    3201             :   "Switch used to have the shell execute its command line argument.")
    3202             : 
    3203             : (defvar shell-command-default-error-buffer nil
    3204             :   "Buffer name for `shell-command' and `shell-command-on-region' error output.
    3205             : This buffer is used when `shell-command' or `shell-command-on-region'
    3206             : is run interactively.  A value of nil means that output to stderr and
    3207             : stdout will be intermixed in the output stream.")
    3208             : 
    3209             : (declare-function mailcap-file-default-commands "mailcap" (files))
    3210             : (declare-function dired-get-filename "dired" (&optional localp no-error-if-not-filep))
    3211             : 
    3212             : (defun minibuffer-default-add-shell-commands ()
    3213             :   "Return a list of all commands associated with the current file.
    3214             : This function is used to add all related commands retrieved by `mailcap'
    3215             : to the end of the list of defaults just after the default value."
    3216             :   (interactive)
    3217           0 :   (let* ((filename (if (listp minibuffer-default)
    3218           0 :                        (car minibuffer-default)
    3219           0 :                      minibuffer-default))
    3220           0 :          (commands (and filename (require 'mailcap nil t)
    3221           0 :                         (mailcap-file-default-commands (list filename)))))
    3222           0 :     (setq commands (mapcar (lambda (command)
    3223           0 :                              (concat command " " filename))
    3224           0 :                            commands))
    3225           0 :     (if (listp minibuffer-default)
    3226           0 :         (append minibuffer-default commands)
    3227           0 :       (cons minibuffer-default commands))))
    3228             : 
    3229             : (declare-function shell-completion-vars "shell" ())
    3230             : 
    3231             : (defvar minibuffer-local-shell-command-map
    3232             :   (let ((map (make-sparse-keymap)))
    3233             :     (set-keymap-parent map minibuffer-local-map)
    3234             :     (define-key map "\t" 'completion-at-point)
    3235             :     map)
    3236             :   "Keymap used for completing shell commands in minibuffer.")
    3237             : 
    3238             : (defun read-shell-command (prompt &optional initial-contents hist &rest args)
    3239             :   "Read a shell command from the minibuffer.
    3240             : The arguments are the same as the ones of `read-from-minibuffer',
    3241             : except READ and KEYMAP are missing and HIST defaults
    3242             : to `shell-command-history'."
    3243           0 :   (require 'shell)
    3244           0 :   (minibuffer-with-setup-hook
    3245             :       (lambda ()
    3246           0 :         (shell-completion-vars)
    3247           0 :         (set (make-local-variable 'minibuffer-default-add-function)
    3248           0 :              'minibuffer-default-add-shell-commands))
    3249           0 :     (apply 'read-from-minibuffer prompt initial-contents
    3250           0 :            minibuffer-local-shell-command-map
    3251             :            nil
    3252           0 :            (or hist 'shell-command-history)
    3253           0 :            args)))
    3254             : 
    3255             : (defcustom async-shell-command-buffer 'confirm-new-buffer
    3256             :   "What to do when the output buffer is used by another shell command.
    3257             : This option specifies how to resolve the conflict where a new command
    3258             : wants to direct its output to the buffer `*Async Shell Command*',
    3259             : but this buffer is already taken by another running shell command.
    3260             : 
    3261             : The value `confirm-kill-process' is used to ask for confirmation before
    3262             : killing the already running process and running a new process
    3263             : in the same buffer, `confirm-new-buffer' for confirmation before running
    3264             : the command in a new buffer with a name other than the default buffer name,
    3265             : `new-buffer' for doing the same without confirmation,
    3266             : `confirm-rename-buffer' for confirmation before renaming the existing
    3267             : output buffer and running a new command in the default buffer,
    3268             : `rename-buffer' for doing the same without confirmation."
    3269             :   :type '(choice (const :tag "Confirm killing of running command"
    3270             :                         confirm-kill-process)
    3271             :                  (const :tag "Confirm creation of a new buffer"
    3272             :                         confirm-new-buffer)
    3273             :                  (const :tag "Create a new buffer"
    3274             :                         new-buffer)
    3275             :                  (const :tag "Confirm renaming of existing buffer"
    3276             :                         confirm-rename-buffer)
    3277             :                  (const :tag "Rename the existing buffer"
    3278             :                         rename-buffer))
    3279             :   :group 'shell
    3280             :   :version "24.3")
    3281             : 
    3282             : (defcustom async-shell-command-display-buffer t
    3283             :   "Whether to display the command buffer immediately.
    3284             : If t, display the buffer immediately; if nil, wait until there
    3285             : is output."
    3286             :   :type '(choice (const :tag "Display buffer immediately"
    3287             :                         t)
    3288             :                  (const :tag "Display buffer on output"
    3289             :                         nil))
    3290             :   :group 'shell
    3291             :   :version "26.1")
    3292             : 
    3293             : (defun shell-command--save-pos-or-erase ()
    3294             :   "Store a buffer position or erase the buffer.
    3295             : See `shell-command-dont-erase-buffer'."
    3296           0 :   (let ((sym shell-command-dont-erase-buffer)
    3297             :         pos)
    3298           0 :     (setq buffer-read-only nil)
    3299             :     ;; Setting buffer-read-only to nil doesn't suffice
    3300             :     ;; if some text has a non-nil read-only property,
    3301             :     ;; which comint sometimes adds for prompts.
    3302           0 :     (setq pos
    3303           0 :           (cond ((eq sym 'save-point) (point))
    3304           0 :                 ((eq sym 'beg-last-out) (point-max))
    3305           0 :                 ((not sym)
    3306           0 :                  (let ((inhibit-read-only t))
    3307           0 :                    (erase-buffer) nil))))
    3308           0 :     (when pos
    3309           0 :       (goto-char (point-max))
    3310           0 :       (push (cons (current-buffer) pos)
    3311           0 :             shell-command-saved-pos))))
    3312             : 
    3313             : (defun shell-command--set-point-after-cmd (&optional buffer)
    3314             :   "Set point in BUFFER after command complete.
    3315             : BUFFER is the output buffer of the command; if nil, then defaults
    3316             : to the current BUFFER.
    3317             : Set point to the `cdr' of the element in `shell-command-saved-pos'
    3318             : whose `car' is BUFFER."
    3319           0 :   (when shell-command-dont-erase-buffer
    3320           0 :     (let* ((sym  shell-command-dont-erase-buffer)
    3321           0 :            (buf  (or buffer (current-buffer)))
    3322           0 :            (pos  (alist-get buf shell-command-saved-pos)))
    3323           0 :       (setq shell-command-saved-pos
    3324           0 :             (assq-delete-all buf shell-command-saved-pos))
    3325           0 :       (when (buffer-live-p buf)
    3326           0 :         (let ((win   (car (get-buffer-window-list buf)))
    3327           0 :               (pmax  (with-current-buffer buf (point-max))))
    3328           0 :           (unless (and pos (memq sym '(save-point beg-last-out)))
    3329           0 :             (setq pos pmax))
    3330             :           ;; Set point in the window displaying buf, if any; otherwise
    3331             :           ;; display buf temporary in selected frame and set the point.
    3332           0 :           (if win
    3333           0 :               (set-window-point win pos)
    3334           0 :             (save-window-excursion
    3335           0 :               (let ((win (display-buffer
    3336           0 :                           buf
    3337           0 :                           '(nil (inhibit-switch-frame . t)))))
    3338           0 :                 (set-window-point win pos)))))))))
    3339             : 
    3340             : (defun async-shell-command (command &optional output-buffer error-buffer)
    3341             :   "Execute string COMMAND asynchronously in background.
    3342             : 
    3343             : Like `shell-command', but adds `&' at the end of COMMAND
    3344             : to execute it asynchronously.
    3345             : 
    3346             : The output appears in the buffer `*Async Shell Command*'.
    3347             : That buffer is in shell mode.
    3348             : 
    3349             : You can configure `async-shell-command-buffer' to specify what to do in
    3350             : case when `*Async Shell Command*' buffer is already taken by another
    3351             : running shell command.  To run COMMAND without displaying the output
    3352             : in a window you can configure `display-buffer-alist' to use the action
    3353             : `display-buffer-no-window' for the buffer `*Async Shell Command*'.
    3354             : 
    3355             : In Elisp, you will often be better served by calling `start-process'
    3356             : directly, since it offers more control and does not impose the use of a
    3357             : shell (with its need to quote arguments)."
    3358             :   (interactive
    3359           0 :    (list
    3360           0 :     (read-shell-command "Async shell command: " nil nil
    3361           0 :                         (let ((filename
    3362           0 :                                (cond
    3363           0 :                                 (buffer-file-name)
    3364           0 :                                 ((eq major-mode 'dired-mode)
    3365           0 :                                  (dired-get-filename nil t)))))
    3366           0 :                           (and filename (file-relative-name filename))))
    3367           0 :     current-prefix-arg
    3368           0 :     shell-command-default-error-buffer))
    3369          10 :   (unless (string-match "&[ \t]*\\'" command)
    3370          10 :     (setq command (concat command " &")))
    3371          10 :   (shell-command command output-buffer error-buffer))
    3372             : 
    3373             : (defun shell-command (command &optional output-buffer error-buffer)
    3374             :   "Execute string COMMAND in inferior shell; display output, if any.
    3375             : With prefix argument, insert the COMMAND's output at point.
    3376             : 
    3377             : Interactively, prompt for COMMAND in the minibuffer.
    3378             : 
    3379             : If COMMAND ends in `&', execute it asynchronously.
    3380             : The output appears in the buffer `*Async Shell Command*'.
    3381             : That buffer is in shell mode.  You can also use
    3382             : `async-shell-command' that automatically adds `&'.
    3383             : 
    3384             : Otherwise, COMMAND is executed synchronously.  The output appears in
    3385             : the buffer `*Shell Command Output*'.  If the output is short enough to
    3386             : display in the echo area (which is determined by the variables
    3387             : `resize-mini-windows' and `max-mini-window-height'), it is shown
    3388             : there, but it is nonetheless available in buffer `*Shell Command
    3389             : Output*' even though that buffer is not automatically displayed.
    3390             : 
    3391             : To specify a coding system for converting non-ASCII characters
    3392             : in the shell command output, use \\[universal-coding-system-argument] \
    3393             : before this command.
    3394             : 
    3395             : Noninteractive callers can specify coding systems by binding
    3396             : `coding-system-for-read' and `coding-system-for-write'.
    3397             : 
    3398             : The optional second argument OUTPUT-BUFFER, if non-nil,
    3399             : says to put the output in some other buffer.
    3400             : If OUTPUT-BUFFER is a buffer or buffer name, erase that buffer
    3401             : and insert the output there; a non-nil value of
    3402             : `shell-command-dont-erase-buffer' prevent to erase the buffer.
    3403             : If OUTPUT-BUFFER is not a buffer and not nil, insert the output
    3404             : in current buffer after point leaving mark after it.
    3405             : This cannot be done asynchronously.
    3406             : 
    3407             : If the command terminates without error, but generates output,
    3408             : and you did not specify \"insert it in the current buffer\",
    3409             : the output can be displayed in the echo area or in its buffer.
    3410             : If the output is short enough to display in the echo area
    3411             : \(determined by the variable `max-mini-window-height' if
    3412             : `resize-mini-windows' is non-nil), it is shown there.
    3413             : Otherwise,the buffer containing the output is displayed.
    3414             : 
    3415             : If there is output and an error, and you did not specify \"insert it
    3416             : in the current buffer\", a message about the error goes at the end
    3417             : of the output.
    3418             : 
    3419             : If the optional third argument ERROR-BUFFER is non-nil, it is a buffer
    3420             : or buffer name to which to direct the command's standard error output.
    3421             : If it is nil, error output is mingled with regular output.
    3422             : In an interactive call, the variable `shell-command-default-error-buffer'
    3423             : specifies the value of ERROR-BUFFER.
    3424             : 
    3425             : In Elisp, you will often be better served by calling `call-process' or
    3426             : `start-process' directly, since it offers more control and does not impose
    3427             : the use of a shell (with its need to quote arguments)."
    3428             : 
    3429             :   (interactive
    3430           0 :    (list
    3431           0 :     (read-shell-command "Shell command: " nil nil
    3432           0 :                         (let ((filename
    3433           0 :                                (cond
    3434           0 :                                 (buffer-file-name)
    3435           0 :                                 ((eq major-mode 'dired-mode)
    3436           0 :                                  (dired-get-filename nil t)))))
    3437           0 :                           (and filename (file-relative-name filename))))
    3438           0 :     current-prefix-arg
    3439           0 :     shell-command-default-error-buffer))
    3440             :   ;; Look for a handler in case default-directory is a remote file name.
    3441          14 :   (let ((handler
    3442          14 :          (find-file-name-handler (directory-file-name default-directory)
    3443          14 :                                  'shell-command)))
    3444          14 :     (if handler
    3445          14 :         (funcall handler 'shell-command command output-buffer error-buffer)
    3446           0 :       (if (and output-buffer
    3447           0 :                (not (or (bufferp output-buffer)  (stringp output-buffer))))
    3448             :           ;; Output goes in current buffer.
    3449           0 :           (let ((error-file
    3450           0 :                  (if error-buffer
    3451           0 :                      (make-temp-file
    3452           0 :                       (expand-file-name "scor"
    3453           0 :                                         (or small-temporary-file-directory
    3454           0 :                                             temporary-file-directory)))
    3455           0 :                    nil)))
    3456           0 :             (barf-if-buffer-read-only)
    3457           0 :             (push-mark nil t)
    3458             :             ;; We do not use -f for csh; we will not support broken use of
    3459             :             ;; .cshrcs.  Even the BSD csh manual says to use
    3460             :             ;; "if ($?prompt) exit" before things which are not useful
    3461             :             ;; non-interactively.  Besides, if someone wants their other
    3462             :             ;; aliases for shell commands then they can still have them.
    3463           0 :             (call-process shell-file-name nil
    3464           0 :                           (if error-file
    3465           0 :                               (list t error-file)
    3466           0 :                             t)
    3467           0 :                           nil shell-command-switch command)
    3468           0 :             (when (and error-file (file-exists-p error-file))
    3469           0 :               (if (< 0 (nth 7 (file-attributes error-file)))
    3470           0 :                   (with-current-buffer (get-buffer-create error-buffer)
    3471           0 :                     (let ((pos-from-end (- (point-max) (point))))
    3472           0 :                       (or (bobp)
    3473           0 :                           (insert "\f\n"))
    3474             :                       ;; Do no formatting while reading error file,
    3475             :                       ;; because that can run a shell command, and we
    3476             :                       ;; don't want that to cause an infinite recursion.
    3477           0 :                       (format-insert-file error-file nil)
    3478             :                       ;; Put point after the inserted errors.
    3479           0 :                       (goto-char (- (point-max) pos-from-end)))
    3480           0 :                     (display-buffer (current-buffer))))
    3481           0 :               (delete-file error-file))
    3482             :             ;; This is like exchange-point-and-mark, but doesn't
    3483             :             ;; activate the mark.  It is cleaner to avoid activation,
    3484             :             ;; even though the command loop would deactivate the mark
    3485             :             ;; because we inserted text.
    3486           0 :             (goto-char (prog1 (mark t)
    3487           0 :                          (set-marker (mark-marker) (point)
    3488           0 :                                      (current-buffer)))))
    3489             :         ;; Output goes in a separate buffer.
    3490             :         ;; Preserve the match data in case called from a program.
    3491             :         ;; FIXME: It'd be ridiculous for an Elisp function to call
    3492             :         ;; shell-command and assume that it won't mess the match-data!
    3493           0 :         (save-match-data
    3494           0 :           (if (string-match "[ \t]*&[ \t]*\\'" command)
    3495             :               ;; Command ending with ampersand means asynchronous.
    3496           0 :               (let ((buffer (get-buffer-create
    3497           0 :                              (or output-buffer "*Async Shell Command*")))
    3498           0 :                     (directory default-directory)
    3499             :                     proc)
    3500             :                 ;; Remove the ampersand.
    3501           0 :                 (setq command (substring command 0 (match-beginning 0)))
    3502             :                 ;; Ask the user what to do with already running process.
    3503           0 :                 (setq proc (get-buffer-process buffer))
    3504           0 :                 (when proc
    3505           0 :                   (cond
    3506           0 :                    ((eq async-shell-command-buffer 'confirm-kill-process)
    3507             :                     ;; If will kill a process, query first.
    3508           0 :                     (if (yes-or-no-p "A command is running in the default buffer.  Kill it? ")
    3509           0 :                         (kill-process proc)
    3510           0 :                       (error "Shell command in progress")))
    3511           0 :                    ((eq async-shell-command-buffer 'confirm-new-buffer)
    3512             :                     ;; If will create a new buffer, query first.
    3513           0 :                     (if (yes-or-no-p "A command is running in the default buffer.  Use a new buffer? ")
    3514           0 :                         (setq buffer (generate-new-buffer
    3515           0 :                                       (or (and (bufferp output-buffer) (buffer-name output-buffer))
    3516           0 :                                           output-buffer "*Async Shell Command*")))
    3517           0 :                       (error "Shell command in progress")))
    3518           0 :                    ((eq async-shell-command-buffer 'new-buffer)
    3519             :                     ;; It will create a new buffer.
    3520           0 :                     (setq buffer (generate-new-buffer
    3521           0 :                                   (or (and (bufferp output-buffer) (buffer-name output-buffer))
    3522           0 :                                       output-buffer "*Async Shell Command*"))))
    3523           0 :                    ((eq async-shell-command-buffer 'confirm-rename-buffer)
    3524             :                     ;; If will rename the buffer, query first.
    3525           0 :                     (if (yes-or-no-p "A command is running in the default buffer.  Rename it? ")
    3526           0 :                         (progn
    3527           0 :                           (with-current-buffer buffer
    3528           0 :                             (rename-uniquely))
    3529           0 :                           (setq buffer (get-buffer-create
    3530           0 :                                         (or output-buffer "*Async Shell Command*"))))
    3531           0 :                       (error "Shell command in progress")))
    3532           0 :                    ((eq async-shell-command-buffer 'rename-buffer)
    3533             :                     ;; It will rename the buffer.
    3534           0 :                     (with-current-buffer buffer
    3535           0 :                       (rename-uniquely))
    3536           0 :                     (setq buffer (get-buffer-create
    3537           0 :                                   (or output-buffer "*Async Shell Command*"))))))
    3538           0 :                 (with-current-buffer buffer
    3539           0 :                   (shell-command--save-pos-or-erase)
    3540           0 :                   (setq default-directory directory)
    3541           0 :                   (setq proc (start-process "Shell" buffer shell-file-name
    3542           0 :                                             shell-command-switch command))
    3543           0 :                   (setq mode-line-process '(":%s"))
    3544           0 :                   (require 'shell) (shell-mode)
    3545           0 :                   (set-process-sentinel proc 'shell-command-sentinel)
    3546             :                   ;; Use the comint filter for proper handling of carriage motion
    3547             :                   ;; (see `comint-inhibit-carriage-motion'),.
    3548           0 :                   (set-process-filter proc 'comint-output-filter)
    3549           0 :                   (if async-shell-command-display-buffer
    3550           0 :                       (display-buffer buffer '(nil (allow-no-window . t)))
    3551           0 :                     (add-function :before (process-filter proc)
    3552           0 :                                   `(lambda (process string)
    3553             :                                      (when (and (= 0 (buffer-size (process-buffer process)))
    3554             :                                                 (string= (buffer-name (process-buffer process))
    3555           0 :                                                     ,(or output-buffer "*Async Shell Command*")))
    3556           0 :                                        (display-buffer (process-buffer process))))
    3557           0 :                                   ))
    3558           0 :                   ))
    3559             :             ;; Otherwise, command is executed synchronously.
    3560           0 :             (shell-command-on-region (point) (point) command
    3561          14 :                                      output-buffer nil error-buffer)))))))
    3562             : 
    3563             : (defun display-message-or-buffer (message &optional buffer-name action frame)
    3564             :   "Display MESSAGE in the echo area if possible, otherwise in a pop-up buffer.
    3565             : MESSAGE may be either a string or a buffer.
    3566             : 
    3567             : A pop-up buffer is displayed using `display-buffer' if MESSAGE is too long
    3568             : for maximum height of the echo area, as defined by `max-mini-window-height'
    3569             : if `resize-mini-windows' is non-nil.
    3570             : 
    3571             : Returns either the string shown in the echo area, or when a pop-up
    3572             : buffer is used, the window used to display it.
    3573             : 
    3574             : If MESSAGE is a string, then the optional argument BUFFER-NAME is the
    3575             : name of the buffer used to display it in the case where a pop-up buffer
    3576             : is used, defaulting to `*Message*'.  In the case where MESSAGE is a
    3577             : string and it is displayed in the echo area, it is not specified whether
    3578             : the contents are inserted into the buffer anyway.
    3579             : 
    3580             : Optional arguments ACTION and FRAME are as for `display-buffer',
    3581             : and are only used if a pop-up buffer is displayed."
    3582           2 :   (cond ((and (stringp message) (not (string-match "\n" message)))
    3583             :          ;; Trivial case where we can use the echo area
    3584           0 :          (message "%s" message))
    3585           2 :         ((and (stringp message)
    3586           2 :               (= (string-match "\n" message) (1- (length message))))
    3587             :          ;; Trivial case where we can just remove single trailing newline
    3588           0 :          (message "%s" (substring message 0 (1- (length message)))))
    3589             :         (t
    3590             :          ;; General case
    3591           2 :          (with-current-buffer
    3592           2 :              (if (bufferp message)
    3593           2 :                  message
    3594           2 :                (get-buffer-create (or buffer-name "*Message*")))
    3595             : 
    3596           2 :            (unless (bufferp message)
    3597           0 :              (erase-buffer)
    3598           2 :              (insert message))
    3599             : 
    3600           2 :            (let ((lines
    3601           2 :                   (if (= (buffer-size) 0)
    3602             :                       0
    3603           2 :                     (count-screen-lines nil nil nil (minibuffer-window)))))
    3604           2 :              (cond ((= lines 0))
    3605           2 :                    ((and (or (<= lines 1)
    3606           2 :                              (<= lines
    3607           2 :                                  (if resize-mini-windows
    3608           2 :                                      (cond ((floatp max-mini-window-height)
    3609           2 :                                             (* (frame-height)
    3610           2 :                                                max-mini-window-height))
    3611           0 :                                            ((integerp max-mini-window-height)
    3612           0 :                                             max-mini-window-height)
    3613             :                                            (t
    3614           2 :                                             1))
    3615           2 :                                    1)))
    3616             :                          ;; Don't use the echo area if the output buffer is
    3617             :                          ;; already displayed in the selected frame.
    3618           2 :                          (not (get-buffer-window (current-buffer))))
    3619             :                     ;; Echo area
    3620           2 :                     (goto-char (point-max))
    3621           2 :                     (when (bolp)
    3622           2 :                       (backward-char 1))
    3623           2 :                     (message "%s" (buffer-substring (point-min) (point))))
    3624             :                    (t
    3625             :                     ;; Buffer
    3626           0 :                     (goto-char (point-min))
    3627           2 :                     (display-buffer (current-buffer) action frame))))))))
    3628             : 
    3629             : 
    3630             : ;; We have a sentinel to prevent insertion of a termination message
    3631             : ;; in the buffer itself, and to set the point in the buffer when
    3632             : ;; `shell-command-dont-erase-buffer' is non-nil.
    3633             : (defun shell-command-sentinel (process signal)
    3634           0 :   (when (memq (process-status process) '(exit signal))
    3635           0 :     (shell-command--set-point-after-cmd (process-buffer process))
    3636           0 :     (message "%s: %s."
    3637           0 :              (car (cdr (cdr (process-command process))))
    3638           0 :              (substring signal 0 -1))))
    3639             : 
    3640             : (defun shell-command-on-region (start end command
    3641             :                                       &optional output-buffer replace
    3642             :                                       error-buffer display-error-buffer
    3643             :                                       region-noncontiguous-p)
    3644             :   "Execute string COMMAND in inferior shell with region as input.
    3645             : Normally display output (if any) in temp buffer `*Shell Command Output*';
    3646             : Prefix arg means replace the region with it.  Return the exit code of
    3647             : COMMAND.
    3648             : 
    3649             : To specify a coding system for converting non-ASCII characters
    3650             : in the input and output to the shell command, use \\[universal-coding-system-argument]
    3651             : before this command.  By default, the input (from the current buffer)
    3652             : is encoded using coding-system specified by `process-coding-system-alist',
    3653             : falling back to `default-process-coding-system' if no match for COMMAND
    3654             : is found in `process-coding-system-alist'.
    3655             : 
    3656             : Noninteractive callers can specify coding systems by binding
    3657             : `coding-system-for-read' and `coding-system-for-write'.
    3658             : 
    3659             : If the command generates output, the output may be displayed
    3660             : in the echo area or in a buffer.
    3661             : If the output is short enough to display in the echo area
    3662             : \(determined by the variable `max-mini-window-height' if
    3663             : `resize-mini-windows' is non-nil), it is shown there.
    3664             : Otherwise it is displayed in the buffer `*Shell Command Output*'.
    3665             : The output is available in that buffer in both cases.
    3666             : 
    3667             : If there is output and an error, a message about the error
    3668             : appears at the end of the output.
    3669             : 
    3670             : Optional fourth arg OUTPUT-BUFFER specifies where to put the
    3671             : command's output.  If the value is a buffer or buffer name,
    3672             : erase that buffer and insert the output there; a non-nil value of
    3673             : `shell-command-dont-erase-buffer' prevent to erase the buffer.
    3674             : If the value is nil, use the buffer `*Shell Command Output*'.
    3675             : Any other non-nil value means to insert the output in the
    3676             : current buffer after START.
    3677             : 
    3678             : Optional fifth arg REPLACE, if non-nil, means to insert the
    3679             : output in place of text from START to END, putting point and mark
    3680             : around it.
    3681             : 
    3682             : Optional sixth arg ERROR-BUFFER, if non-nil, specifies a buffer
    3683             : or buffer name to which to direct the command's standard error
    3684             : output.  If nil, error output is mingled with regular output.
    3685             : When called interactively, `shell-command-default-error-buffer'
    3686             : is used for ERROR-BUFFER.
    3687             : 
    3688             : Optional seventh arg DISPLAY-ERROR-BUFFER, if non-nil, means to
    3689             : display the error buffer if there were any errors.  When called
    3690             : interactively, this is t."
    3691           0 :   (interactive (let (string)
    3692           0 :                  (unless (mark)
    3693           0 :                    (user-error "The mark is not set now, so there is no region"))
    3694             :                  ;; Do this before calling region-beginning
    3695             :                  ;; and region-end, in case subprocess output
    3696             :                  ;; relocates them while we are in the minibuffer.
    3697           0 :                  (setq string (read-shell-command "Shell command on region: "))
    3698             :                  ;; call-interactively recognizes region-beginning and
    3699             :                  ;; region-end specially, leaving them in the history.
    3700           0 :                  (list (region-beginning) (region-end)
    3701           0 :                        string
    3702           0 :                        current-prefix-arg
    3703           0 :                        current-prefix-arg
    3704           0 :                        shell-command-default-error-buffer
    3705             :                        t
    3706           0 :                        (region-noncontiguous-p))))
    3707           0 :   (let ((error-file
    3708           0 :          (if error-buffer
    3709           0 :              (make-temp-file
    3710           0 :               (expand-file-name "scor"
    3711           0 :                                 (or small-temporary-file-directory
    3712           0 :                                     temporary-file-directory)))
    3713           0 :            nil))
    3714             :         exit-status)
    3715             :     ;; Unless a single contiguous chunk is selected, operate on multiple chunks.
    3716           0 :     (if region-noncontiguous-p
    3717           0 :         (let ((input (concat (funcall region-extract-function 'delete) "\n"))
    3718             :               output)
    3719           0 :           (with-temp-buffer
    3720           0 :             (insert input)
    3721           0 :             (call-process-region (point-min) (point-max)
    3722           0 :                                  shell-file-name t t
    3723           0 :                                  nil shell-command-switch
    3724           0 :                                  command)
    3725           0 :             (setq output (split-string (buffer-string) "\n")))
    3726           0 :           (goto-char start)
    3727           0 :           (funcall region-insert-function output))
    3728           0 :       (if (or replace
    3729           0 :               (and output-buffer
    3730           0 :                    (not (or (bufferp output-buffer) (stringp output-buffer)))))
    3731             :           ;; Replace specified region with output from command.
    3732           0 :           (let ((swap (and replace (< start end))))
    3733             :             ;; Don't muck with mark unless REPLACE says we should.
    3734           0 :             (goto-char start)
    3735           0 :             (and replace (push-mark (point) 'nomsg))
    3736           0 :             (setq exit-status
    3737           0 :                   (call-shell-region start end command replace
    3738           0 :                                        (if error-file
    3739           0 :                                            (list t error-file)
    3740           0 :                                          t)))
    3741             :             ;; It is rude to delete a buffer which the command is not using.
    3742             :             ;; (let ((shell-buffer (get-buffer "*Shell Command Output*")))
    3743             :             ;;   (and shell-buffer (not (eq shell-buffer (current-buffer)))
    3744             :             ;;   (kill-buffer shell-buffer)))
    3745             :             ;; Don't muck with mark unless REPLACE says we should.
    3746           0 :             (and replace swap (exchange-point-and-mark)))
    3747             :         ;; No prefix argument: put the output in a temp buffer,
    3748             :         ;; replacing its entire contents.
    3749           0 :         (let ((buffer (get-buffer-create
    3750           0 :                        (or output-buffer "*Shell Command Output*"))))
    3751           0 :           (unwind-protect
    3752           0 :               (if (and (eq buffer (current-buffer))
    3753           0 :                        (or (not shell-command-dont-erase-buffer)
    3754           0 :                            (and (not (eq buffer (get-buffer "*Shell Command Output*")))
    3755           0 :                                 (not (region-active-p)))))
    3756             :                   ;; If the input is the same buffer as the output,
    3757             :                   ;; delete everything but the specified region,
    3758             :                   ;; then replace that region with the output.
    3759           0 :                   (progn (setq buffer-read-only nil)
    3760           0 :                          (delete-region (max start end) (point-max))
    3761           0 :                          (delete-region (point-min) (min start end))
    3762           0 :                          (setq exit-status
    3763           0 :                                (call-process-region (point-min) (point-max)
    3764           0 :                                                     shell-file-name t
    3765           0 :                                                     (if error-file
    3766           0 :                                                         (list t error-file)
    3767           0 :                                                       t)
    3768           0 :                                                     nil shell-command-switch
    3769           0 :                                                     command)))
    3770             :                 ;; Clear the output buffer, then run the command with
    3771             :                 ;; output there.
    3772           0 :                 (let ((directory default-directory))
    3773           0 :                   (with-current-buffer buffer
    3774           0 :                     (if (not output-buffer)
    3775           0 :                         (setq default-directory directory))
    3776           0 :                     (shell-command--save-pos-or-erase)))
    3777           0 :                 (setq exit-status
    3778           0 :                       (call-shell-region start end command nil
    3779           0 :                                            (if error-file
    3780           0 :                                                (list buffer error-file)
    3781           0 :                                              buffer))))
    3782             :             ;; Report the output.
    3783           0 :             (with-current-buffer buffer
    3784           0 :               (setq mode-line-process
    3785           0 :                     (cond ((null exit-status)
    3786             :                            " - Error")
    3787           0 :                           ((stringp exit-status)
    3788           0 :                            (format " - Signal [%s]" exit-status))
    3789           0 :                           ((not (equal 0 exit-status))
    3790           0 :                            (format " - Exit [%d]" exit-status)))))
    3791           0 :             (if (with-current-buffer buffer (> (point-max) (point-min)))
    3792             :                 ;; There's some output, display it
    3793           0 :                 (progn
    3794           0 :                   (display-message-or-buffer buffer)
    3795           0 :                   (shell-command--set-point-after-cmd buffer))
    3796             :             ;; No output; error?
    3797           0 :               (let ((output
    3798           0 :                      (if (and error-file
    3799           0 :                               (< 0 (nth 7 (file-attributes error-file))))
    3800           0 :                          (format "some error output%s"
    3801           0 :                                  (if shell-command-default-error-buffer
    3802           0 :                                      (format " to the \"%s\" buffer"
    3803           0 :                                              shell-command-default-error-buffer)
    3804           0 :                                    ""))
    3805           0 :                        "no output")))
    3806           0 :                 (cond ((null exit-status)
    3807           0 :                        (message "(Shell command failed with error)"))
    3808           0 :                       ((equal 0 exit-status)
    3809           0 :                        (message "(Shell command succeeded with %s)"
    3810           0 :                                 output))
    3811           0 :                       ((stringp exit-status)
    3812           0 :                        (message "(Shell command killed by signal %s)"
    3813           0 :                                 exit-status))
    3814             :                       (t
    3815           0 :                        (message "(Shell command failed with code %d and %s)"
    3816           0 :                                 exit-status output))))
    3817             :               ;; Don't kill: there might be useful info in the undo-log.
    3818             :               ;; (kill-buffer buffer)
    3819           0 :               )))))
    3820             : 
    3821           0 :     (when (and error-file (file-exists-p error-file))
    3822           0 :       (if (< 0 (nth 7 (file-attributes error-file)))
    3823           0 :           (with-current-buffer (get-buffer-create error-buffer)
    3824           0 :             (let ((pos-from-end (- (point-max) (point))))
    3825           0 :               (or (bobp)
    3826           0 :                   (insert "\f\n"))
    3827             :               ;; Do no formatting while reading error file,
    3828             :               ;; because that can run a shell command, and we
    3829             :               ;; don't want that to cause an infinite recursion.
    3830           0 :               (format-insert-file error-file nil)
    3831             :               ;; Put point after the inserted errors.
    3832           0 :               (goto-char (- (point-max) pos-from-end)))
    3833           0 :             (and display-error-buffer
    3834           0 :                  (display-buffer (current-buffer)))))
    3835           0 :       (delete-file error-file))
    3836           0 :     exit-status))
    3837             : 
    3838             : (defun shell-command-to-string (command)
    3839             :   "Execute shell command COMMAND and return its output as a string."
    3840          11 :   (with-output-to-string
    3841          11 :     (with-current-buffer
    3842          11 :       standard-output
    3843          11 :       (process-file shell-file-name nil t nil shell-command-switch command))))
    3844             : 
    3845             : (defun process-file (program &optional infile buffer display &rest args)
    3846             :   "Process files synchronously in a separate process.
    3847             : Similar to `call-process', but may invoke a file handler based on
    3848             : `default-directory'.  The current working directory of the
    3849             : subprocess is `default-directory'.
    3850             : 
    3851             : File names in INFILE and BUFFER are handled normally, but file
    3852             : names in ARGS should be relative to `default-directory', as they
    3853             : are passed to the process verbatim.  (This is a difference to
    3854             : `call-process' which does not support file handlers for INFILE
    3855             : and BUFFER.)
    3856             : 
    3857             : Some file handlers might not support all variants, for example
    3858             : they might behave as if DISPLAY was nil, regardless of the actual
    3859             : value passed."
    3860         732 :   (let ((fh (find-file-name-handler default-directory 'process-file))
    3861             :         lc stderr-file)
    3862         732 :     (unwind-protect
    3863         732 :         (if fh (apply fh 'process-file program infile buffer display args)
    3864         630 :           (when infile (setq lc (file-local-copy infile)))
    3865         630 :           (setq stderr-file (when (and (consp buffer) (stringp (cadr buffer)))
    3866         630 :                               (make-temp-file "emacs")))
    3867         630 :           (prog1
    3868         630 :               (apply 'call-process program
    3869         630 :                      (or lc infile)
    3870         630 :                      (if stderr-file (list (car buffer) stderr-file) buffer)
    3871         630 :                      display args)
    3872         732 :             (when stderr-file (copy-file stderr-file (cadr buffer) t))))
    3873         732 :       (when stderr-file (delete-file stderr-file))
    3874         732 :       (when lc (delete-file lc)))))
    3875             : 
    3876             : (defvar process-file-side-effects t
    3877             :   "Whether a call of `process-file' changes remote files.
    3878             : 
    3879             : By default, this variable is always set to t, meaning that a
    3880             : call of `process-file' could potentially change any file on a
    3881             : remote host.  When set to nil, a file handler could optimize
    3882             : its behavior with respect to remote file attribute caching.
    3883             : 
    3884             : You should only ever change this variable with a let-binding;
    3885             : never with `setq'.")
    3886             : 
    3887             : (defun start-file-process (name buffer program &rest program-args)
    3888             :   "Start a program in a subprocess.  Return the process object for it.
    3889             : 
    3890             : Similar to `start-process', but may invoke a file handler based on
    3891             : `default-directory'.  See Info node `(elisp)Magic File Names'.
    3892             : 
    3893             : This handler ought to run PROGRAM, perhaps on the local host,
    3894             : perhaps on a remote host that corresponds to `default-directory'.
    3895             : In the latter case, the local part of `default-directory' becomes
    3896             : the working directory of the process.
    3897             : 
    3898             : PROGRAM and PROGRAM-ARGS might be file names.  They are not
    3899             : objects of file handler invocation.  File handlers might not
    3900             : support pty association, if PROGRAM is nil."
    3901          27 :   (let ((fh (find-file-name-handler default-directory 'start-file-process)))
    3902          27 :     (if fh (apply fh 'start-file-process name buffer program program-args)
    3903          27 :       (apply 'start-process name buffer program program-args))))
    3904             : 
    3905             : ;;;; Process menu
    3906             : 
    3907             : (defvar tabulated-list-format)
    3908             : (defvar tabulated-list-entries)
    3909             : (defvar tabulated-list-sort-key)
    3910             : (declare-function tabulated-list-init-header  "tabulated-list" ())
    3911             : (declare-function tabulated-list-print "tabulated-list"
    3912             :                   (&optional remember-pos update))
    3913             : 
    3914             : (defvar process-menu-query-only nil)
    3915             : 
    3916             : (defvar process-menu-mode-map
    3917             :   (let ((map (make-sparse-keymap)))
    3918             :     (define-key map [?d] 'process-menu-delete-process)
    3919             :     map))
    3920             : 
    3921             : (define-derived-mode process-menu-mode tabulated-list-mode "Process Menu"
    3922             :   "Major mode for listing the processes called by Emacs."
    3923           0 :   (setq tabulated-list-format [("Process" 15 t)
    3924             :                                ("PID"      7 t)
    3925             :                                ("Status"   7 t)
    3926             :                                ("Buffer"  15 t)
    3927             :                                ("TTY"     12 t)
    3928           0 :                                ("Command"  0 t)])
    3929           0 :   (make-local-variable 'process-menu-query-only)
    3930           0 :   (setq tabulated-list-sort-key (cons "Process" nil))
    3931           0 :   (add-hook 'tabulated-list-revert-hook 'list-processes--refresh nil t))
    3932             : 
    3933             : (defun process-menu-delete-process ()
    3934             :   "Kill process at point in a `list-processes' buffer."
    3935             :   (interactive)
    3936           0 :   (let ((pos (point)))
    3937           0 :     (delete-process (tabulated-list-get-id))
    3938           0 :     (revert-buffer)
    3939           0 :     (goto-char (min pos (point-max)))
    3940           0 :     (if (eobp)
    3941           0 :         (forward-line -1)
    3942           0 :       (beginning-of-line))))
    3943             : 
    3944             : (defun list-processes--refresh ()
    3945             :   "Recompute the list of processes for the Process List buffer.
    3946             : Also, delete any process that is exited or signaled."
    3947           0 :   (setq tabulated-list-entries nil)
    3948           0 :   (dolist (p (process-list))
    3949           0 :     (cond ((memq (process-status p) '(exit signal closed))
    3950           0 :            (delete-process p))
    3951           0 :           ((or (not process-menu-query-only)
    3952           0 :                (process-query-on-exit-flag p))
    3953           0 :            (let* ((buf (process-buffer p))
    3954           0 :                   (type (process-type p))
    3955           0 :                   (pid  (if (process-id p) (format "%d" (process-id p)) "--"))
    3956           0 :                   (name (process-name p))
    3957           0 :                   (status (symbol-name (process-status p)))
    3958           0 :                   (buf-label (if (buffer-live-p buf)
    3959           0 :                                  `(,(buffer-name buf)
    3960             :                                    face link
    3961           0 :                                    help-echo ,(format-message
    3962             :                                                "Visit buffer `%s'"
    3963           0 :                                                (buffer-name buf))
    3964             :                                    follow-link t
    3965           0 :                                    process-buffer ,buf
    3966           0 :                                    action process-menu-visit-buffer)
    3967           0 :                                "--"))
    3968           0 :                   (tty (or (process-tty-name p) "--"))
    3969             :                   (cmd
    3970           0 :                    (if (memq type '(network serial))
    3971           0 :                        (let ((contact (process-contact p t)))
    3972           0 :                          (if (eq type 'network)
    3973           0 :                              (format "(%s %s)"
    3974           0 :                                      (if (plist-get contact :type)
    3975             :                                          "datagram"
    3976           0 :                                        "network")
    3977           0 :                                      (if (plist-get contact :server)
    3978           0 :                                          (format "server on %s"
    3979           0 :                                                  (or
    3980           0 :                                                   (plist-get contact :host)
    3981           0 :                                                   (plist-get contact :local)))
    3982           0 :                                        (format "connection to %s"
    3983           0 :                                                (plist-get contact :host))))
    3984           0 :                            (format "(serial port %s%s)"
    3985           0 :                                    (or (plist-get contact :port) "?")
    3986           0 :                                    (let ((speed (plist-get contact :speed)))
    3987           0 :                                      (if speed
    3988           0 :                                          (format " at %s b/s" speed)
    3989           0 :                                        "")))))
    3990           0 :                      (mapconcat 'identity (process-command p) " "))))
    3991           0 :              (push (list p (vector name pid status buf-label tty cmd))
    3992           0 :                    tabulated-list-entries)))))
    3993           0 :   (tabulated-list-init-header))
    3994             : 
    3995             : (defun process-menu-visit-buffer (button)
    3996           0 :   (display-buffer (button-get button 'process-buffer)))
    3997             : 
    3998             : (defun list-processes (&optional query-only buffer)
    3999             :   "Display a list of all processes that are Emacs sub-processes.
    4000             : If optional argument QUERY-ONLY is non-nil, only processes with
    4001             : the query-on-exit flag set are listed.
    4002             : Any process listed as exited or signaled is actually eliminated
    4003             : after the listing is made.
    4004             : Optional argument BUFFER specifies a buffer to use, instead of
    4005             : \"*Process List*\".
    4006             : The return value is always nil.
    4007             : 
    4008             : This function lists only processes that were launched by Emacs.  To
    4009             : see other processes running on the system, use `list-system-processes'."
    4010             :   (interactive)
    4011           0 :   (or (fboundp 'process-list)
    4012           0 :       (error "Asynchronous subprocesses are not supported on this system"))
    4013           0 :   (unless (bufferp buffer)
    4014           0 :     (setq buffer (get-buffer-create "*Process List*")))
    4015           0 :   (with-current-buffer buffer
    4016           0 :     (process-menu-mode)
    4017           0 :     (setq process-menu-query-only query-only)
    4018           0 :     (list-processes--refresh)
    4019           0 :     (tabulated-list-print))
    4020           0 :   (display-buffer buffer)
    4021             :   nil)
    4022             : 
    4023             : ;;;; Prefix commands
    4024             : 
    4025             : (setq prefix-command--needs-update nil)
    4026             : (setq prefix-command--last-echo nil)
    4027             : 
    4028             : (defun internal-echo-keystrokes-prefix ()
    4029             :   ;; BEWARE: Called directly from C code.
    4030             :   ;; If the return value is non-nil, it means we are in the middle of
    4031             :   ;; a command with prefix, such as a command invoked with prefix-arg.
    4032           0 :   (if (not prefix-command--needs-update)
    4033           0 :       prefix-command--last-echo
    4034           0 :     (setq prefix-command--last-echo
    4035           0 :           (let ((strs nil))
    4036           0 :             (run-hook-wrapped 'prefix-command-echo-keystrokes-functions
    4037           0 :                               (lambda (fun) (push (funcall fun) strs)))
    4038           0 :             (setq strs (delq nil strs))
    4039           0 :             (when strs (mapconcat #'identity strs " "))))))
    4040             : 
    4041             : (defvar prefix-command-echo-keystrokes-functions nil
    4042             :   "Abnormal hook which constructs the description of the current prefix state.
    4043             : Each function is called with no argument, should return a string or nil.")
    4044             : 
    4045             : (defun prefix-command-update ()
    4046             :   "Update state of prefix commands.
    4047             : Call it whenever you change the \"prefix command state\"."
    4048           0 :   (setq prefix-command--needs-update t))
    4049             : 
    4050             : (defvar prefix-command-preserve-state-hook nil
    4051             :   "Normal hook run when a command needs to preserve the prefix.")
    4052             : 
    4053             : (defun prefix-command-preserve-state ()
    4054             :   "Pass the current prefix command state to the next command.
    4055             : Should be called by all prefix commands.
    4056             : Runs `prefix-command-preserve-state-hook'."
    4057           0 :   (run-hooks 'prefix-command-preserve-state-hook)
    4058             :   ;; If the current command is a prefix command, we don't want the next (real)
    4059             :   ;; command to have `last-command' set to, say, `universal-argument'.
    4060           0 :   (setq this-command last-command)
    4061           0 :   (setq real-this-command real-last-command)
    4062           0 :   (prefix-command-update))
    4063             : 
    4064             : (defun reset-this-command-lengths ()
    4065             :   (declare (obsolete prefix-command-preserve-state "25.1"))
    4066             :   nil)
    4067             : 
    4068             : ;;;;; The main prefix command.
    4069             : 
    4070             : ;; FIXME: Declaration of `prefix-arg' should be moved here!?
    4071             : 
    4072             : (add-hook 'prefix-command-echo-keystrokes-functions
    4073             :           #'universal-argument--description)
    4074             : (defun universal-argument--description ()
    4075           0 :   (when prefix-arg
    4076           0 :     (concat "C-u"
    4077           0 :             (pcase prefix-arg
    4078             :               (`(-) " -")
    4079             :               (`(,(and (pred integerp) n))
    4080           0 :                (let ((str ""))
    4081           0 :                  (while (and (> n 4) (= (mod n 4) 0))
    4082           0 :                    (setq str (concat str " C-u"))
    4083           0 :                    (setq n (/ n 4)))
    4084           0 :                  (if (= n 4) str (format " %s" prefix-arg))))
    4085           0 :               (_ (format " %s" prefix-arg))))))
    4086             : 
    4087             : (add-hook 'prefix-command-preserve-state-hook
    4088             :           #'universal-argument--preserve)
    4089             : (defun universal-argument--preserve ()
    4090           0 :   (setq prefix-arg current-prefix-arg))
    4091             : 
    4092             : (defvar universal-argument-map
    4093             :   (let ((map (make-sparse-keymap))
    4094             :         (universal-argument-minus
    4095             :          ;; For backward compatibility, minus with no modifiers is an ordinary
    4096             :          ;; command if digits have already been entered.
    4097             :          `(menu-item "" negative-argument
    4098             :                      :filter ,(lambda (cmd)
    4099             :                                 (if (integerp prefix-arg) nil cmd)))))
    4100             :     (define-key map [switch-frame]
    4101             :       (lambda (e) (interactive "e")
    4102             :         (handle-switch-frame e) (universal-argument--mode)))
    4103             :     (define-key map [?\C-u] 'universal-argument-more)
    4104             :     (define-key map [?-] universal-argument-minus)
    4105             :     (define-key map [?0] 'digit-argument)
    4106             :     (define-key map [?1] 'digit-argument)
    4107             :     (define-key map [?2] 'digit-argument)
    4108             :     (define-key map [?3] 'digit-argument)
    4109             :     (define-key map [?4] 'digit-argument)
    4110             :     (define-key map [?5] 'digit-argument)
    4111             :     (define-key map [?6] 'digit-argument)
    4112             :     (define-key map [?7] 'digit-argument)
    4113             :     (define-key map [?8] 'digit-argument)
    4114             :     (define-key map [?9] 'digit-argument)
    4115             :     (define-key map [kp-0] 'digit-argument)
    4116             :     (define-key map [kp-1] 'digit-argument)
    4117             :     (define-key map [kp-2] 'digit-argument)
    4118             :     (define-key map [kp-3] 'digit-argument)
    4119             :     (define-key map [kp-4] 'digit-argument)
    4120             :     (define-key map [kp-5] 'digit-argument)
    4121             :     (define-key map [kp-6] 'digit-argument)
    4122             :     (define-key map [kp-7] 'digit-argument)
    4123             :     (define-key map [kp-8] 'digit-argument)
    4124             :     (define-key map [kp-9] 'digit-argument)
    4125             :     (define-key map [kp-subtract] universal-argument-minus)
    4126             :     map)
    4127             :   "Keymap used while processing \\[universal-argument].")
    4128             : 
    4129             : (defun universal-argument--mode ()
    4130           0 :   (prefix-command-update)
    4131           0 :   (set-transient-map universal-argument-map nil))
    4132             : 
    4133             : (defun universal-argument ()
    4134             :   "Begin a numeric argument for the following command.
    4135             : Digits or minus sign following \\[universal-argument] make up the numeric argument.
    4136             : \\[universal-argument] following the digits or minus sign ends the argument.
    4137             : \\[universal-argument] without digits or minus sign provides 4 as argument.
    4138             : Repeating \\[universal-argument] without digits or minus sign
    4139             :  multiplies the argument by 4 each time.
    4140             : For some commands, just \\[universal-argument] by itself serves as a flag
    4141             : which is different in effect from any particular numeric argument.
    4142             : These commands include \\[set-mark-command] and \\[start-kbd-macro]."
    4143             :   (interactive)
    4144           0 :   (prefix-command-preserve-state)
    4145           0 :   (setq prefix-arg (list 4))
    4146           0 :   (universal-argument--mode))
    4147             : 
    4148             : (defun universal-argument-more (arg)
    4149             :   ;; A subsequent C-u means to multiply the factor by 4 if we've typed
    4150             :   ;; nothing but C-u's; otherwise it means to terminate the prefix arg.
    4151             :   (interactive "P")
    4152           0 :   (prefix-command-preserve-state)
    4153           0 :   (setq prefix-arg (if (consp arg)
    4154           0 :                        (list (* 4 (car arg)))
    4155           0 :                      (if (eq arg '-)
    4156           0 :                          (list -4)
    4157           0 :                        arg)))
    4158           0 :   (when (consp prefix-arg) (universal-argument--mode)))
    4159             : 
    4160             : (defun negative-argument (arg)
    4161             :   "Begin a negative numeric argument for the next command.
    4162             : \\[universal-argument] following digits or minus sign ends the argument."
    4163             :   (interactive "P")
    4164           0 :   (prefix-command-preserve-state)
    4165           0 :   (setq prefix-arg (cond ((integerp arg) (- arg))
    4166           0 :                          ((eq arg '-) nil)
    4167           0 :                          (t '-)))
    4168           0 :   (universal-argument--mode))
    4169             : 
    4170             : (defun digit-argument (arg)
    4171             :   "Part of the numeric argument for the next command.
    4172             : \\[universal-argument] following digits or minus sign ends the argument."
    4173             :   (interactive "P")
    4174           0 :   (prefix-command-preserve-state)
    4175           0 :   (let* ((char (if (integerp last-command-event)
    4176           0 :                    last-command-event
    4177           0 :                  (get last-command-event 'ascii-character)))
    4178           0 :          (digit (- (logand char ?\177) ?0)))
    4179           0 :     (setq prefix-arg (cond ((integerp arg)
    4180           0 :                             (+ (* arg 10)
    4181           0 :                                (if (< arg 0) (- digit) digit)))
    4182           0 :                            ((eq arg '-)
    4183             :                             ;; Treat -0 as just -, so that -01 will work.
    4184           0 :                             (if (zerop digit) '- (- digit)))
    4185             :                            (t
    4186           0 :                             digit))))
    4187           0 :   (universal-argument--mode))
    4188             : 
    4189             : 
    4190             : (defvar filter-buffer-substring-functions nil
    4191             :   "This variable is a wrapper hook around `buffer-substring--filter'.
    4192             : \(See `with-wrapper-hook' for details about wrapper hooks.)")
    4193             : (make-obsolete-variable 'filter-buffer-substring-functions
    4194             :                         'filter-buffer-substring-function "24.4")
    4195             : 
    4196             : (defvar filter-buffer-substring-function #'buffer-substring--filter
    4197             :   "Function to perform the filtering in `filter-buffer-substring'.
    4198             : The function is called with the same 3 arguments (BEG END DELETE)
    4199             : that `filter-buffer-substring' received.  It should return the
    4200             : buffer substring between BEG and END, after filtering.  If DELETE is
    4201             : non-nil, it should delete the text between BEG and END from the buffer.")
    4202             : 
    4203             : (defvar buffer-substring-filters nil
    4204             :   "List of filter functions for `buffer-substring--filter'.
    4205             : Each function must accept a single argument, a string, and return a string.
    4206             : The buffer substring is passed to the first function in the list,
    4207             : and the return value of each function is passed to the next.
    4208             : As a special convention, point is set to the start of the buffer text
    4209             : being operated on (i.e., the first argument of `buffer-substring--filter')
    4210             : before these functions are called.")
    4211             : (make-obsolete-variable 'buffer-substring-filters
    4212             :                         'filter-buffer-substring-function "24.1")
    4213             : 
    4214             : (defun filter-buffer-substring (beg end &optional delete)
    4215             :   "Return the buffer substring between BEG and END, after filtering.
    4216             : If DELETE is non-nil, delete the text between BEG and END from the buffer.
    4217             : 
    4218             : This calls the function that `filter-buffer-substring-function' specifies
    4219             : \(passing the same three arguments that it received) to do the work,
    4220             : and returns whatever it does.  The default function does no filtering,
    4221             : unless a hook has been set.
    4222             : 
    4223             : Use `filter-buffer-substring' instead of `buffer-substring',
    4224             : `buffer-substring-no-properties', or `delete-and-extract-region' when
    4225             : you want to allow filtering to take place.  For example, major or minor
    4226             : modes can use `filter-buffer-substring-function' to extract characters
    4227             : that are special to a buffer, and should not be copied into other buffers."
    4228           0 :   (funcall filter-buffer-substring-function beg end delete))
    4229             : 
    4230             : (defun buffer-substring--filter (beg end &optional delete)
    4231             :   "Default function to use for `filter-buffer-substring-function'.
    4232             : Its arguments and return value are as specified for `filter-buffer-substring'.
    4233             : Also respects the obsolete wrapper hook `filter-buffer-substring-functions'
    4234             : \(see `with-wrapper-hook' for details about wrapper hooks),
    4235             : and the abnormal hook `buffer-substring-filters'.
    4236             : No filtering is done unless a hook says to."
    4237           0 :   (subr--with-wrapper-hook-no-warnings
    4238             :     filter-buffer-substring-functions (beg end delete)
    4239             :     (cond
    4240             :      ((or delete buffer-substring-filters)
    4241             :       (save-excursion
    4242             :         (goto-char beg)
    4243             :         (let ((string (if delete (delete-and-extract-region beg end)
    4244             :                         (buffer-substring beg end))))
    4245             :           (dolist (filter buffer-substring-filters)
    4246             :             (setq string (funcall filter string)))
    4247             :           string)))
    4248             :      (t
    4249           0 :       (buffer-substring beg end)))))
    4250             : 
    4251             : 
    4252             : ;;;; Window system cut and paste hooks.
    4253             : 
    4254             : (defvar interprogram-cut-function #'gui-select-text
    4255             :   "Function to call to make a killed region available to other programs.
    4256             : Most window systems provide a facility for cutting and pasting
    4257             : text between different programs, such as the clipboard on X and
    4258             : MS-Windows, or the pasteboard on Nextstep/Mac OS.
    4259             : 
    4260             : This variable holds a function that Emacs calls whenever text is
    4261             : put in the kill ring, to make the new kill available to other
    4262             : programs.  The function takes one argument, TEXT, which is a
    4263             : string containing the text which should be made available.")
    4264             : 
    4265             : (defvar interprogram-paste-function #'gui-selection-value
    4266             :   "Function to call to get text cut from other programs.
    4267             : Most window systems provide a facility for cutting and pasting
    4268             : text between different programs, such as the clipboard on X and
    4269             : MS-Windows, or the pasteboard on Nextstep/Mac OS.
    4270             : 
    4271             : This variable holds a function that Emacs calls to obtain text
    4272             : that other programs have provided for pasting.  The function is
    4273             : called with no arguments.  If no other program has provided text
    4274             : to paste, the function should return nil (in which case the
    4275             : caller, usually `current-kill', should use the top of the Emacs
    4276             : kill ring).  If another program has provided text to paste, the
    4277             : function should return that text as a string (in which case the
    4278             : caller should put this string in the kill ring as the latest
    4279             : kill).
    4280             : 
    4281             : The function may also return a list of strings if the window
    4282             : system supports multiple selections.  The first string will be
    4283             : used as the pasted text, but the other will be placed in the kill
    4284             : ring for easy access via `yank-pop'.
    4285             : 
    4286             : Note that the function should return a string only if a program
    4287             : other than Emacs has provided a string for pasting; if Emacs
    4288             : provided the most recent string, the function should return nil.
    4289             : If it is difficult to tell whether Emacs or some other program
    4290             : provided the current string, it is probably good enough to return
    4291             : nil if the string is equal (according to `string=') to the last
    4292             : text Emacs provided.")
    4293             : 
    4294             : 
    4295             : 
    4296             : ;;;; The kill ring data structure.
    4297             : 
    4298             : (defvar kill-ring nil
    4299             :   "List of killed text sequences.
    4300             : Since the kill ring is supposed to interact nicely with cut-and-paste
    4301             : facilities offered by window systems, use of this variable should
    4302             : interact nicely with `interprogram-cut-function' and
    4303             : `interprogram-paste-function'.  The functions `kill-new',
    4304             : `kill-append', and `current-kill' are supposed to implement this
    4305             : interaction; you may want to use them instead of manipulating the kill
    4306             : ring directly.")
    4307             : 
    4308             : (defcustom kill-ring-max 60
    4309             :   "Maximum length of kill ring before oldest elements are thrown away."
    4310             :   :type 'integer
    4311             :   :group 'killing)
    4312             : 
    4313             : (defvar kill-ring-yank-pointer nil
    4314             :   "The tail of the kill ring whose car is the last thing yanked.")
    4315             : 
    4316             : (defcustom save-interprogram-paste-before-kill nil
    4317             :   "Save clipboard strings into kill ring before replacing them.
    4318             : When one selects something in another program to paste it into Emacs,
    4319             : but kills something in Emacs before actually pasting it,
    4320             : this selection is gone unless this variable is non-nil,
    4321             : in which case the other program's selection is saved in the `kill-ring'
    4322             : before the Emacs kill and one can still paste it using \\[yank] \\[yank-pop]."
    4323             :   :type 'boolean
    4324             :   :group 'killing
    4325             :   :version "23.2")
    4326             : 
    4327             : (defcustom kill-do-not-save-duplicates nil
    4328             :   "Do not add a new string to `kill-ring' if it duplicates the last one.
    4329             : The comparison is done using `equal-including-properties'."
    4330             :   :type 'boolean
    4331             :   :group 'killing
    4332             :   :version "23.2")
    4333             : 
    4334             : (defun kill-new (string &optional replace)
    4335             :   "Make STRING the latest kill in the kill ring.
    4336             : Set `kill-ring-yank-pointer' to point to it.
    4337             : If `interprogram-cut-function' is non-nil, apply it to STRING.
    4338             : Optional second argument REPLACE non-nil means that STRING will replace
    4339             : the front of the kill ring, rather than being added to the list.
    4340             : 
    4341             : When `save-interprogram-paste-before-kill' and `interprogram-paste-function'
    4342             : are non-nil, saves the interprogram paste string(s) into `kill-ring' before
    4343             : STRING.
    4344             : 
    4345             : When the yank handler has a non-nil PARAM element, the original STRING
    4346             : argument is not used by `insert-for-yank'.  However, since Lisp code
    4347             : may access and use elements from the kill ring directly, the STRING
    4348             : argument should still be a \"useful\" string for such uses."
    4349           0 :   (unless (and kill-do-not-save-duplicates
    4350             :                ;; Due to text properties such as 'yank-handler that
    4351             :                ;; can alter the contents to yank, comparison using
    4352             :                ;; `equal' is unsafe.
    4353           0 :                (equal-including-properties string (car kill-ring)))
    4354           0 :     (if (fboundp 'menu-bar-update-yank-menu)
    4355           0 :         (menu-bar-update-yank-menu string (and replace (car kill-ring)))))
    4356           0 :   (when save-interprogram-paste-before-kill
    4357           0 :     (let ((interprogram-paste (and interprogram-paste-function
    4358           0 :                                    (funcall interprogram-paste-function))))
    4359           0 :       (when interprogram-paste
    4360           0 :         (dolist (s (if (listp interprogram-paste)
    4361           0 :                        (nreverse interprogram-paste)
    4362           0 :                      (list interprogram-paste)))
    4363           0 :           (unless (and kill-do-not-save-duplicates
    4364           0 :                        (equal-including-properties s (car kill-ring)))
    4365           0 :             (push s kill-ring))))))
    4366           0 :   (unless (and kill-do-not-save-duplicates
    4367           0 :                (equal-including-properties string (car kill-ring)))
    4368           0 :     (if (and replace kill-ring)
    4369           0 :         (setcar kill-ring string)
    4370           0 :       (push string kill-ring)
    4371           0 :       (if (> (length kill-ring) kill-ring-max)
    4372           0 :           (setcdr (nthcdr (1- kill-ring-max) kill-ring) nil))))
    4373           0 :   (setq kill-ring-yank-pointer kill-ring)
    4374           0 :   (if interprogram-cut-function
    4375           0 :       (funcall interprogram-cut-function string)))
    4376             : 
    4377             : ;; It has been argued that this should work similar to `self-insert-command'
    4378             : ;; which merges insertions in undo-list in groups of 20 (hard-coded in cmds.c).
    4379             : (defcustom kill-append-merge-undo nil
    4380             :   "Whether appending to kill ring also makes \\[undo] restore both pieces of text simultaneously."
    4381             :   :type 'boolean
    4382             :   :group 'killing
    4383             :   :version "25.1")
    4384             : 
    4385             : (defun kill-append (string before-p)
    4386             :   "Append STRING to the end of the latest kill in the kill ring.
    4387             : If BEFORE-P is non-nil, prepend STRING to the kill.
    4388             : Also removes the last undo boundary in the current buffer,
    4389             :  depending on `kill-append-merge-undo'.
    4390             : If `interprogram-cut-function' is set, pass the resulting kill to it."
    4391           0 :   (let* ((cur (car kill-ring)))
    4392           0 :     (kill-new (if before-p (concat string cur) (concat cur string))
    4393           0 :               (or (= (length cur) 0)
    4394           0 :                   (equal nil (get-text-property 0 'yank-handler cur))))
    4395           0 :     (when (and kill-append-merge-undo (not buffer-read-only))
    4396           0 :       (let ((prev buffer-undo-list)
    4397           0 :             (next (cdr buffer-undo-list)))
    4398             :         ;; find the next undo boundary
    4399           0 :         (while (car next)
    4400           0 :           (pop next)
    4401           0 :           (pop prev))
    4402             :         ;; remove this undo boundary
    4403           0 :         (when prev
    4404           0 :           (setcdr prev (cdr next)))))))
    4405             : 
    4406             : (defcustom yank-pop-change-selection nil
    4407             :   "Whether rotating the kill ring changes the window system selection.
    4408             : If non-nil, whenever the kill ring is rotated (usually via the
    4409             : `yank-pop' command), Emacs also calls `interprogram-cut-function'
    4410             : to copy the new kill to the window system selection."
    4411             :   :type 'boolean
    4412             :   :group 'killing
    4413             :   :version "23.1")
    4414             : 
    4415             : (defun current-kill (n &optional do-not-move)
    4416             :   "Rotate the yanking point by N places, and then return that kill.
    4417             : If N is zero and `interprogram-paste-function' is set to a
    4418             : function that returns a string or a list of strings, and if that
    4419             : function doesn't return nil, then that string (or list) is added
    4420             : to the front of the kill ring and the string (or first string in
    4421             : the list) is returned as the latest kill.
    4422             : 
    4423             : If N is not zero, and if `yank-pop-change-selection' is
    4424             : non-nil, use `interprogram-cut-function' to transfer the
    4425             : kill at the new yank point into the window system selection.
    4426             : 
    4427             : If optional arg DO-NOT-MOVE is non-nil, then don't actually
    4428             : move the yanking point; just return the Nth kill forward."
    4429             : 
    4430           0 :   (let ((interprogram-paste (and (= n 0)
    4431           0 :                                  interprogram-paste-function
    4432           0 :                                  (funcall interprogram-paste-function))))
    4433           0 :     (if interprogram-paste
    4434           0 :         (progn
    4435             :           ;; Disable the interprogram cut function when we add the new
    4436             :           ;; text to the kill ring, so Emacs doesn't try to own the
    4437             :           ;; selection, with identical text.
    4438           0 :           (let ((interprogram-cut-function nil))
    4439           0 :             (if (listp interprogram-paste)
    4440           0 :               (mapc 'kill-new (nreverse interprogram-paste))
    4441           0 :               (kill-new interprogram-paste)))
    4442           0 :           (car kill-ring))
    4443           0 :       (or kill-ring (error "Kill ring is empty"))
    4444           0 :       (let ((ARGth-kill-element
    4445           0 :              (nthcdr (mod (- n (length kill-ring-yank-pointer))
    4446           0 :                           (length kill-ring))
    4447           0 :                      kill-ring)))
    4448           0 :         (unless do-not-move
    4449           0 :           (setq kill-ring-yank-pointer ARGth-kill-element)
    4450           0 :           (when (and yank-pop-change-selection
    4451           0 :                      (> n 0)
    4452           0 :                      interprogram-cut-function)
    4453           0 :             (funcall interprogram-cut-function (car ARGth-kill-element))))
    4454           0 :         (car ARGth-kill-element)))))
    4455             : 
    4456             : 
    4457             : 
    4458             : ;;;; Commands for manipulating the kill ring.
    4459             : 
    4460             : (defcustom kill-read-only-ok nil
    4461             :   "Non-nil means don't signal an error for killing read-only text."
    4462             :   :type 'boolean
    4463             :   :group 'killing)
    4464             : 
    4465             : (defun kill-region (beg end &optional region)
    4466             :   "Kill (\"cut\") text between point and mark.
    4467             : This deletes the text from the buffer and saves it in the kill ring.
    4468             : The command \\[yank] can retrieve it from there.
    4469             : \(If you want to save the region without killing it, use \\[kill-ring-save].)
    4470             : 
    4471             : If you want to append the killed region to the last killed text,
    4472             : use \\[append-next-kill] before \\[kill-region].
    4473             : 
    4474             : Any command that calls this function is a \"kill command\".
    4475             : If the previous command was also a kill command,
    4476             : the text killed this time appends to the text killed last time
    4477             : to make one entry in the kill ring.
    4478             : 
    4479             : The killed text is filtered by `filter-buffer-substring' before it is
    4480             : saved in the kill ring, so the actual saved text might be different
    4481             : from what was killed.
    4482             : 
    4483             : If the buffer is read-only, Emacs will beep and refrain from deleting
    4484             : the text, but put the text in the kill ring anyway.  This means that
    4485             : you can use the killing commands to copy text from a read-only buffer.
    4486             : 
    4487             : Lisp programs should use this function for killing text.
    4488             :  (To delete text, use `delete-region'.)
    4489             : Supply two arguments, character positions BEG and END indicating the
    4490             :  stretch of text to be killed.  If the optional argument REGION is
    4491             :  non-nil, the function ignores BEG and END, and kills the current
    4492             :  region instead."
    4493             :   ;; Pass mark first, then point, because the order matters when
    4494             :   ;; calling `kill-append'.
    4495           0 :   (interactive (list (mark) (point) 'region))
    4496           0 :   (unless (and beg end)
    4497           0 :     (user-error "The mark is not set now, so there is no region"))
    4498           0 :   (condition-case nil
    4499           0 :       (let ((string (if region
    4500           0 :                         (funcall region-extract-function 'delete)
    4501           0 :                       (filter-buffer-substring beg end 'delete))))
    4502           0 :         (when string                    ;STRING is nil if BEG = END
    4503             :           ;; Add that string to the kill ring, one way or another.
    4504           0 :           (if (eq last-command 'kill-region)
    4505           0 :               (kill-append string (< end beg))
    4506           0 :             (kill-new string)))
    4507           0 :         (when (or string (eq last-command 'kill-region))
    4508           0 :           (setq this-command 'kill-region))
    4509           0 :         (setq deactivate-mark t)
    4510           0 :         nil)
    4511             :     ((buffer-read-only text-read-only)
    4512             :      ;; The code above failed because the buffer, or some of the characters
    4513             :      ;; in the region, are read-only.
    4514             :      ;; We should beep, in case the user just isn't aware of this.
    4515             :      ;; However, there's no harm in putting
    4516             :      ;; the region's text in the kill ring, anyway.
    4517           0 :      (copy-region-as-kill beg end region)
    4518             :      ;; Set this-command now, so it will be set even if we get an error.
    4519           0 :      (setq this-command 'kill-region)
    4520             :      ;; This should barf, if appropriate, and give us the correct error.
    4521           0 :      (if kill-read-only-ok
    4522           0 :          (progn (message "Read only text copied to kill ring") nil)
    4523             :        ;; Signal an error if the buffer is read-only.
    4524           0 :        (barf-if-buffer-read-only)
    4525             :        ;; If the buffer isn't read-only, the text is.
    4526           0 :        (signal 'text-read-only (list (current-buffer)))))))
    4527             : 
    4528             : ;; copy-region-as-kill no longer sets this-command, because it's confusing
    4529             : ;; to get two copies of the text when the user accidentally types M-w and
    4530             : ;; then corrects it with the intended C-w.
    4531             : (defun copy-region-as-kill (beg end &optional region)
    4532             :   "Save the region as if killed, but don't kill it.
    4533             : In Transient Mark mode, deactivate the mark.
    4534             : If `interprogram-cut-function' is non-nil, also save the text for a window
    4535             : system cut and paste.
    4536             : 
    4537             : The copied text is filtered by `filter-buffer-substring' before it is
    4538             : saved in the kill ring, so the actual saved text might be different
    4539             : from what was in the buffer.
    4540             : 
    4541             : When called from Lisp, save in the kill ring the stretch of text
    4542             : between BEG and END, unless the optional argument REGION is
    4543             : non-nil, in which case ignore BEG and END, and save the current
    4544             : region instead.
    4545             : 
    4546             : This command's old key binding has been given to `kill-ring-save'."
    4547             :   ;; Pass mark first, then point, because the order matters when
    4548             :   ;; calling `kill-append'.
    4549           0 :   (interactive (list (mark) (point)
    4550           0 :                      (prefix-numeric-value current-prefix-arg)))
    4551           0 :   (let ((str (if region
    4552           0 :                  (funcall region-extract-function nil)
    4553           0 :                (filter-buffer-substring beg end))))
    4554           0 :   (if (eq last-command 'kill-region)
    4555           0 :         (kill-append str (< end beg))
    4556           0 :       (kill-new str)))
    4557           0 :   (setq deactivate-mark t)
    4558             :   nil)
    4559             : 
    4560             : (defun kill-ring-save (beg end &optional region)
    4561             :   "Save the region as if killed, but don't kill it.
    4562             : In Transient Mark mode, deactivate the mark.
    4563             : If `interprogram-cut-function' is non-nil, also save the text for a window
    4564             : system cut and paste.
    4565             : 
    4566             : If you want to append the killed line to the last killed text,
    4567             : use \\[append-next-kill] before \\[kill-ring-save].
    4568             : 
    4569             : The copied text is filtered by `filter-buffer-substring' before it is
    4570             : saved in the kill ring, so the actual saved text might be different
    4571             : from what was in the buffer.
    4572             : 
    4573             : When called from Lisp, save in the kill ring the stretch of text
    4574             : between BEG and END, unless the optional argument REGION is
    4575             : non-nil, in which case ignore BEG and END, and save the current
    4576             : region instead.
    4577             : 
    4578             : This command is similar to `copy-region-as-kill', except that it gives
    4579             : visual feedback indicating the extent of the region being copied."
    4580             :   ;; Pass mark first, then point, because the order matters when
    4581             :   ;; calling `kill-append'.
    4582           0 :   (interactive (list (mark) (point)
    4583           0 :                      (prefix-numeric-value current-prefix-arg)))
    4584           0 :   (copy-region-as-kill beg end region)
    4585             :   ;; This use of called-interactively-p is correct because the code it
    4586             :   ;; controls just gives the user visual feedback.
    4587           0 :   (if (called-interactively-p 'interactive)
    4588           0 :       (indicate-copied-region)))
    4589             : 
    4590             : (defun indicate-copied-region (&optional message-len)
    4591             :   "Indicate that the region text has been copied interactively.
    4592             : If the mark is visible in the selected window, blink the cursor
    4593             : between point and mark if there is currently no active region
    4594             : highlighting.
    4595             : 
    4596             : If the mark lies outside the selected window, display an
    4597             : informative message containing a sample of the copied text.  The
    4598             : optional argument MESSAGE-LEN, if non-nil, specifies the length
    4599             : of this sample text; it defaults to 40."
    4600           0 :   (let ((mark (mark t))
    4601           0 :         (point (point))
    4602             :         ;; Inhibit quitting so we can make a quit here
    4603             :         ;; look like a C-g typed as a command.
    4604             :         (inhibit-quit t))
    4605           0 :     (if (pos-visible-in-window-p mark (selected-window))
    4606             :         ;; Swap point-and-mark quickly so as to show the region that
    4607             :         ;; was selected.  Don't do it if the region is highlighted.
    4608           0 :         (unless (and (region-active-p)
    4609           0 :                      (face-background 'region))
    4610             :           ;; Swap point and mark.
    4611           0 :           (set-marker (mark-marker) (point) (current-buffer))
    4612           0 :           (goto-char mark)
    4613           0 :           (sit-for blink-matching-delay)
    4614             :           ;; Swap back.
    4615           0 :           (set-marker (mark-marker) mark (current-buffer))
    4616           0 :           (goto-char point)
    4617             :           ;; If user quit, deactivate the mark
    4618             :           ;; as C-g would as a command.
    4619           0 :           (and quit-flag (region-active-p)
    4620           0 :                (deactivate-mark)))
    4621           0 :       (let ((len (min (abs (- mark point))
    4622           0 :                       (or message-len 40))))
    4623           0 :         (if (< point mark)
    4624             :             ;; Don't say "killed"; that is misleading.
    4625           0 :             (message "Saved text until \"%s\""
    4626           0 :                      (buffer-substring-no-properties (- mark len) mark))
    4627           0 :           (message "Saved text from \"%s\""
    4628           0 :                    (buffer-substring-no-properties mark (+ mark len))))))))
    4629             : 
    4630             : (defun append-next-kill (&optional interactive)
    4631             :   "Cause following command, if it kills, to add to previous kill.
    4632             : If the next command kills forward from point, the kill is
    4633             : appended to the previous killed text.  If the command kills
    4634             : backward, the kill is prepended.  Kill commands that act on the
    4635             : region, such as `kill-region', are regarded as killing forward if
    4636             : point is after mark, and killing backward if point is before
    4637             : mark.
    4638             : 
    4639             : If the next command is not a kill command, `append-next-kill' has
    4640             : no effect.
    4641             : 
    4642             : The argument is used for internal purposes; do not supply one."
    4643             :   (interactive "p")
    4644             :   ;; We don't use (interactive-p), since that breaks kbd macros.
    4645           0 :   (if interactive
    4646           0 :       (progn
    4647           0 :         (setq this-command 'kill-region)
    4648           0 :         (message "If the next command is a kill, it will append"))
    4649           0 :     (setq last-command 'kill-region)))
    4650             : 
    4651             : (defvar bidi-directional-controls-chars "\x202a-\x202e\x2066-\x2069"
    4652             :   "Character set that matches bidirectional formatting control characters.")
    4653             : 
    4654             : (defvar bidi-directional-non-controls-chars "^\x202a-\x202e\x2066-\x2069"
    4655             :   "Character set that matches any character except bidirectional controls.")
    4656             : 
    4657             : (defun squeeze-bidi-context-1 (from to category replacement)
    4658             :   "A subroutine of `squeeze-bidi-context'.
    4659             : FROM and TO should be markers, CATEGORY and REPLACEMENT should be strings."
    4660           0 :   (let ((pt (copy-marker from))
    4661           0 :         (limit (copy-marker to))
    4662             :         (old-pt 0)
    4663             :         lim1)
    4664           0 :     (setq lim1 limit)
    4665           0 :     (goto-char pt)
    4666           0 :     (while (< pt limit)
    4667           0 :       (if (> pt old-pt)
    4668           0 :           (move-marker lim1
    4669           0 :                        (save-excursion
    4670             :                          ;; L and R categories include embedding and
    4671             :                          ;; override controls, but we don't want to
    4672             :                          ;; replace them, because that might change
    4673             :                          ;; the visual order.  Likewise with PDF and
    4674             :                          ;; isolate controls.
    4675           0 :                          (+ pt (skip-chars-forward
    4676           0 :                                 bidi-directional-non-controls-chars
    4677           0 :                                 limit)))))
    4678             :       ;; Replace any run of non-RTL characters by a single LRM.
    4679           0 :       (if (null (re-search-forward category lim1 t))
    4680             :           ;; No more characters of CATEGORY, we are done.
    4681           0 :           (setq pt limit)
    4682           0 :         (replace-match replacement nil t)
    4683           0 :         (move-marker pt (point)))
    4684           0 :       (setq old-pt pt)
    4685             :       ;; Skip directional controls, if any.
    4686           0 :       (move-marker
    4687           0 :        pt (+ pt (skip-chars-forward bidi-directional-controls-chars limit))))))
    4688             : 
    4689             : (defun squeeze-bidi-context (from to)
    4690             :   "Replace characters between FROM and TO while keeping bidi context.
    4691             : 
    4692             : This function replaces the region of text with as few characters
    4693             : as possible, while preserving the effect that region will have on
    4694             : bidirectional display before and after the region."
    4695           0 :   (let ((start (set-marker (make-marker)
    4696           0 :                            (if (> from 0) from (+ (point-max) from))))
    4697           0 :         (end (set-marker (make-marker) to))
    4698             :         ;; This is for when they copy text with read-only text
    4699             :         ;; properties.
    4700             :         (inhibit-read-only t))
    4701           0 :     (if (null (marker-position end))
    4702           0 :         (setq end (point-max-marker)))
    4703             :     ;; Replace each run of non-RTL characters with a single LRM.
    4704           0 :     (squeeze-bidi-context-1 start end "\\CR+" "\x200e")
    4705             :     ;; Replace each run of non-LTR characters with a single RLM.  Note
    4706             :     ;; that the \cR category includes both the Arabic Letter (AL) and
    4707             :     ;; R characters; here we ignore the distinction between them,
    4708             :     ;; because that distinction only affects Arabic Number (AN)
    4709             :     ;; characters, which are weak and don't affect the reordering.
    4710           0 :     (squeeze-bidi-context-1 start end "\\CL+" "\x200f")))
    4711             : 
    4712             : (defun line-substring-with-bidi-context (start end &optional no-properties)
    4713             :   "Return buffer text between START and END with its bidi context.
    4714             : 
    4715             : START and END are assumed to belong to the same physical line
    4716             : of buffer text.  This function prepends and appends to the text
    4717             : between START and END bidi control characters that preserve the
    4718             : visual order of that text when it is inserted at some other place."
    4719           0 :   (if (or (< start (point-min))
    4720           0 :           (> end (point-max)))
    4721           0 :       (signal 'args-out-of-range (list (current-buffer) start end)))
    4722           0 :   (let ((buf (current-buffer))
    4723             :         substr para-dir from to)
    4724           0 :     (save-excursion
    4725           0 :       (goto-char start)
    4726           0 :       (setq para-dir (current-bidi-paragraph-direction))
    4727           0 :       (setq from (line-beginning-position)
    4728           0 :             to (line-end-position))
    4729           0 :       (goto-char from)
    4730             :       ;; If we don't have any mixed directional characters in the
    4731             :       ;; entire line, we can just copy the substring without adding
    4732             :       ;; any context.
    4733           0 :       (if (or (looking-at-p "\\CR*$")
    4734           0 :               (looking-at-p "\\CL*$"))
    4735           0 :           (setq substr (if no-properties
    4736           0 :                            (buffer-substring-no-properties start end)
    4737           0 :                          (buffer-substring start end)))
    4738           0 :         (setq substr
    4739           0 :               (with-temp-buffer
    4740           0 :                 (if no-properties
    4741           0 :                     (insert-buffer-substring-no-properties buf from to)
    4742           0 :                   (insert-buffer-substring buf from to))
    4743           0 :                 (squeeze-bidi-context 1 (1+ (- start from)))
    4744           0 :                 (squeeze-bidi-context (- end to) nil)
    4745           0 :                 (buffer-substring 1 (point-max)))))
    4746             : 
    4747             :       ;; Wrap the string in LRI/RLI..PDI pair to achieve 2 effects:
    4748             :       ;; (1) force the string to have the same base embedding
    4749             :       ;; direction as the paragraph direction at the source, no matter
    4750             :       ;; what is the paragraph direction at destination; and (2) avoid
    4751             :       ;; affecting the visual order of the surrounding text at
    4752             :       ;; destination if there are characters of different
    4753             :       ;; directionality there.
    4754           0 :       (concat (if (eq para-dir 'left-to-right) "\x2066" "\x2067")
    4755           0 :               substr "\x2069"))))
    4756             : 
    4757             : (defun buffer-substring-with-bidi-context (start end &optional no-properties)
    4758             :   "Return portion of current buffer between START and END with bidi context.
    4759             : 
    4760             : This function works similar to `buffer-substring', but it prepends and
    4761             : appends to the text bidi directional control characters necessary to
    4762             : preserve the visual appearance of the text if it is inserted at another
    4763             : place.  This is useful when the buffer substring includes bidirectional
    4764             : text and control characters that cause non-trivial reordering on display.
    4765             : If copied verbatim, such text can have a very different visual appearance,
    4766             : and can also change the visual appearance of the surrounding text at the
    4767             : destination of the copy.
    4768             : 
    4769             : Optional argument NO-PROPERTIES, if non-nil, means copy the text without
    4770             : the text properties."
    4771           0 :   (let (line-end substr)
    4772           0 :     (if (or (< start (point-min))
    4773           0 :             (> end (point-max)))
    4774           0 :         (signal 'args-out-of-range (list (current-buffer) start end)))
    4775           0 :     (save-excursion
    4776           0 :       (goto-char start)
    4777           0 :       (setq line-end (min end (line-end-position)))
    4778           0 :       (while (< start end)
    4779           0 :         (setq substr
    4780           0 :               (concat substr
    4781           0 :                       (if substr "\n" "")
    4782           0 :                       (line-substring-with-bidi-context start line-end
    4783           0 :                                                         no-properties)))
    4784           0 :         (forward-line 1)
    4785           0 :         (setq start (point))
    4786           0 :         (setq line-end (min end (line-end-position))))
    4787           0 :       substr)))
    4788             : 
    4789             : ;; Yanking.
    4790             : 
    4791             : (defcustom yank-handled-properties
    4792             :   '((font-lock-face . yank-handle-font-lock-face-property)
    4793             :     (category . yank-handle-category-property))
    4794             :   "List of special text property handling conditions for yanking.
    4795             : Each element should have the form (PROP . FUN), where PROP is a
    4796             : property symbol and FUN is a function.  When the `yank' command
    4797             : inserts text into the buffer, it scans the inserted text for
    4798             : stretches of text that have `eq' values of the text property
    4799             : PROP; for each such stretch of text, FUN is called with three
    4800             : arguments: the property's value in that text, and the start and
    4801             : end positions of the text.
    4802             : 
    4803             : This is done prior to removing the properties specified by
    4804             : `yank-excluded-properties'."
    4805             :   :group 'killing
    4806             :   :type '(repeat (cons (symbol :tag "property symbol")
    4807             :                        function))
    4808             :   :version "24.3")
    4809             : 
    4810             : ;; This is actually used in subr.el but defcustom does not work there.
    4811             : (defcustom yank-excluded-properties
    4812             :   '(category field follow-link fontified font-lock-face help-echo
    4813             :     intangible invisible keymap local-map mouse-face read-only
    4814             :     yank-handler)
    4815             :   "Text properties to discard when yanking.
    4816             : The value should be a list of text properties to discard or t,
    4817             : which means to discard all text properties.
    4818             : 
    4819             : See also `yank-handled-properties'."
    4820             :   :type '(choice (const :tag "All" t) (repeat symbol))
    4821             :   :group 'killing
    4822             :   :version "24.3")
    4823             : 
    4824             : (defvar yank-window-start nil)
    4825             : (defvar yank-undo-function nil
    4826             :   "If non-nil, function used by `yank-pop' to delete last stretch of yanked text.
    4827             : Function is called with two parameters, START and END corresponding to
    4828             : the value of the mark and point; it is guaranteed that START <= END.
    4829             : Normally set from the UNDO element of a yank-handler; see `insert-for-yank'.")
    4830             : 
    4831             : (defun yank-pop (&optional arg)
    4832             :   "Replace just-yanked stretch of killed text with a different stretch.
    4833             : This command is allowed only immediately after a `yank' or a `yank-pop'.
    4834             : At such a time, the region contains a stretch of reinserted
    4835             : previously-killed text.  `yank-pop' deletes that text and inserts in its
    4836             : place a different stretch of killed text.
    4837             : 
    4838             : With no argument, the previous kill is inserted.
    4839             : With argument N, insert the Nth previous kill.
    4840             : If N is negative, this is a more recent kill.
    4841             : 
    4842             : The sequence of kills wraps around, so that after the oldest one
    4843             : comes the newest one.
    4844             : 
    4845             : This command honors the `yank-handled-properties' and
    4846             : `yank-excluded-properties' variables, and the `yank-handler' text
    4847             : property, in the way that `yank' does."
    4848             :   (interactive "*p")
    4849           0 :   (if (not (eq last-command 'yank))
    4850           0 :       (user-error "Previous command was not a yank"))
    4851           0 :   (setq this-command 'yank)
    4852           0 :   (unless arg (setq arg 1))
    4853           0 :   (let ((inhibit-read-only t)
    4854           0 :         (before (< (point) (mark t))))
    4855           0 :     (if before
    4856           0 :         (funcall (or yank-undo-function 'delete-region) (point) (mark t))
    4857           0 :       (funcall (or yank-undo-function 'delete-region) (mark t) (point)))
    4858           0 :     (setq yank-undo-function nil)
    4859           0 :     (set-marker (mark-marker) (point) (current-buffer))
    4860           0 :     (insert-for-yank (current-kill arg))
    4861             :     ;; Set the window start back where it was in the yank command,
    4862             :     ;; if possible.
    4863           0 :     (set-window-start (selected-window) yank-window-start t)
    4864           0 :     (if before
    4865             :         ;; This is like exchange-point-and-mark, but doesn't activate the mark.
    4866             :         ;; It is cleaner to avoid activation, even though the command
    4867             :         ;; loop would deactivate the mark because we inserted text.
    4868           0 :         (goto-char (prog1 (mark t)
    4869           0 :                      (set-marker (mark-marker) (point) (current-buffer))))))
    4870             :   nil)
    4871             : 
    4872             : (defun yank (&optional arg)
    4873             :   "Reinsert (\"paste\") the last stretch of killed text.
    4874             : More precisely, reinsert the most recent kill, which is the
    4875             : stretch of killed text most recently killed OR yanked.  Put point
    4876             : at the end, and set mark at the beginning without activating it.
    4877             : With just \\[universal-argument] as argument, put point at beginning, and mark at end.
    4878             : With argument N, reinsert the Nth most recent kill.
    4879             : 
    4880             : This command honors the `yank-handled-properties' and
    4881             : `yank-excluded-properties' variables, and the `yank-handler' text
    4882             : property, as described below.
    4883             : 
    4884             : Properties listed in `yank-handled-properties' are processed,
    4885             : then those listed in `yank-excluded-properties' are discarded.
    4886             : 
    4887             : If STRING has a non-nil `yank-handler' property anywhere, the
    4888             : normal insert behavior is altered, and instead, for each contiguous
    4889             : segment of STRING that has a given value of the `yank-handler'
    4890             : property, that value is used as follows:
    4891             : 
    4892             : The value of a `yank-handler' property must be a list of one to four
    4893             : elements, of the form (FUNCTION PARAM NOEXCLUDE UNDO).
    4894             : FUNCTION, if non-nil, should be a function of one argument (the
    4895             :  object to insert); FUNCTION is called instead of `insert'.
    4896             : PARAM, if present and non-nil, is passed to FUNCTION (to be handled
    4897             :  in whatever way is appropriate; e.g. if FUNCTION is `yank-rectangle',
    4898             :  PARAM may be a list of strings to insert as a rectangle).  If PARAM
    4899             :  is nil, then the current segment of STRING is used.
    4900             : If NOEXCLUDE is present and non-nil, the normal removal of
    4901             :  `yank-excluded-properties' is not performed; instead FUNCTION is
    4902             :  responsible for the removal.  This may be necessary if FUNCTION
    4903             :  adjusts point before or after inserting the object.
    4904             : UNDO, if present and non-nil, should be a function to be called
    4905             :  by `yank-pop' to undo the insertion of the current PARAM.  It is
    4906             :  given two arguments, the start and end of the region.  FUNCTION
    4907             :  may set `yank-undo-function' to override UNDO.
    4908             : 
    4909             : See also the command `yank-pop' (\\[yank-pop])."
    4910             :   (interactive "*P")
    4911           0 :   (setq yank-window-start (window-start))
    4912             :   ;; If we don't get all the way thru, make last-command indicate that
    4913             :   ;; for the following command.
    4914           0 :   (setq this-command t)
    4915           0 :   (push-mark)
    4916           0 :   (insert-for-yank (current-kill (cond
    4917           0 :                                   ((listp arg) 0)
    4918           0 :                                   ((eq arg '-) -2)
    4919           0 :                                   (t (1- arg)))))
    4920           0 :   (if (consp arg)
    4921             :       ;; This is like exchange-point-and-mark, but doesn't activate the mark.
    4922             :       ;; It is cleaner to avoid activation, even though the command
    4923             :       ;; loop would deactivate the mark because we inserted text.
    4924           0 :       (goto-char (prog1 (mark t)
    4925           0 :                    (set-marker (mark-marker) (point) (current-buffer)))))
    4926             :   ;; If we do get all the way thru, make this-command indicate that.
    4927           0 :   (if (eq this-command t)
    4928           0 :       (setq this-command 'yank))
    4929             :   nil)
    4930             : 
    4931             : (defun rotate-yank-pointer (arg)
    4932             :   "Rotate the yanking point in the kill ring.
    4933             : With ARG, rotate that many kills forward (or backward, if negative)."
    4934             :   (interactive "p")
    4935           0 :   (current-kill arg))
    4936             : 
    4937             : ;; Some kill commands.
    4938             : 
    4939             : ;; Internal subroutine of delete-char
    4940             : (defun kill-forward-chars (arg)
    4941           0 :   (if (listp arg) (setq arg (car arg)))
    4942           0 :   (if (eq arg '-) (setq arg -1))
    4943           0 :   (kill-region (point) (+ (point) arg)))
    4944             : 
    4945             : ;; Internal subroutine of backward-delete-char
    4946             : (defun kill-backward-chars (arg)
    4947           0 :   (if (listp arg) (setq arg (car arg)))
    4948           0 :   (if (eq arg '-) (setq arg -1))
    4949           0 :   (kill-region (point) (- (point) arg)))
    4950             : 
    4951             : (defcustom backward-delete-char-untabify-method 'untabify
    4952             :   "The method for untabifying when deleting backward.
    4953             : Can be `untabify' -- turn a tab to many spaces, then delete one space;
    4954             :        `hungry' -- delete all whitespace, both tabs and spaces;
    4955             :        `all' -- delete all whitespace, including tabs, spaces and newlines;
    4956             :        nil -- just delete one character."
    4957             :   :type '(choice (const untabify) (const hungry) (const all) (const nil))
    4958             :   :version "20.3"
    4959             :   :group 'killing)
    4960             : 
    4961             : (defun backward-delete-char-untabify (arg &optional killp)
    4962             :   "Delete characters backward, changing tabs into spaces.
    4963             : The exact behavior depends on `backward-delete-char-untabify-method'.
    4964             : Delete ARG chars, and kill (save in kill ring) if KILLP is non-nil.
    4965             : Interactively, ARG is the prefix arg (default 1)
    4966             : and KILLP is t if a prefix arg was specified."
    4967             :   (interactive "*p\nP")
    4968           0 :   (when (eq backward-delete-char-untabify-method 'untabify)
    4969           0 :     (let ((count arg))
    4970           0 :       (save-excursion
    4971           0 :         (while (and (> count 0) (not (bobp)))
    4972           0 :           (if (= (preceding-char) ?\t)
    4973           0 :               (let ((col (current-column)))
    4974           0 :                 (forward-char -1)
    4975           0 :                 (setq col (- col (current-column)))
    4976           0 :                 (insert-char ?\s col)
    4977           0 :                 (delete-char 1)))
    4978           0 :           (forward-char -1)
    4979           0 :           (setq count (1- count))))))
    4980           0 :   (let* ((skip (cond ((eq backward-delete-char-untabify-method 'hungry) " \t")
    4981           0 :                      ((eq backward-delete-char-untabify-method 'all)
    4982           0 :                       " \t\n\r")))
    4983           0 :          (n (if skip
    4984           0 :                 (let* ((oldpt (point))
    4985           0 :                        (wh (- oldpt (save-excursion
    4986           0 :                                       (skip-chars-backward skip)
    4987           0 :                                       (constrain-to-field nil oldpt)))))
    4988           0 :                   (+ arg (if (zerop wh) 0 (1- wh))))
    4989           0 :               arg)))
    4990             :     ;; Avoid warning about delete-backward-char
    4991           0 :     (with-no-warnings (delete-backward-char n killp))))
    4992             : 
    4993             : (defun zap-to-char (arg char)
    4994             :   "Kill up to and including ARGth occurrence of CHAR.
    4995             : Case is ignored if `case-fold-search' is non-nil in the current buffer.
    4996             : Goes backward if ARG is negative; error if CHAR not found."
    4997           0 :   (interactive (list (prefix-numeric-value current-prefix-arg)
    4998           0 :                      (read-char "Zap to char: " t)))
    4999             :   ;; Avoid "obsolete" warnings for translation-table-for-input.
    5000           0 :   (with-no-warnings
    5001           0 :     (if (char-table-p translation-table-for-input)
    5002           0 :         (setq char (or (aref translation-table-for-input char) char))))
    5003           0 :   (kill-region (point) (progn
    5004           0 :                          (search-forward (char-to-string char) nil nil arg)
    5005           0 :                          (point))))
    5006             : 
    5007             : ;; kill-line and its subroutines.
    5008             : 
    5009             : (defcustom kill-whole-line nil
    5010             :   "If non-nil, `kill-line' with no arg at start of line kills the whole line."
    5011             :   :type 'boolean
    5012             :   :group 'killing)
    5013             : 
    5014             : (defun kill-line (&optional arg)
    5015             :   "Kill the rest of the current line; if no nonblanks there, kill thru newline.
    5016             : With prefix argument ARG, kill that many lines from point.
    5017             : Negative arguments kill lines backward.
    5018             : With zero argument, kills the text before point on the current line.
    5019             : 
    5020             : When calling from a program, nil means \"no arg\",
    5021             : a number counts as a prefix arg.
    5022             : 
    5023             : To kill a whole line, when point is not at the beginning, type \
    5024             : \\[move-beginning-of-line] \\[kill-line] \\[kill-line].
    5025             : 
    5026             : If `show-trailing-whitespace' is non-nil, this command will just
    5027             : kill the rest of the current line, even if there are no nonblanks
    5028             : there.
    5029             : 
    5030             : If option `kill-whole-line' is non-nil, then this command kills the whole line
    5031             : including its terminating newline, when used at the beginning of a line
    5032             : with no argument.  As a consequence, you can always kill a whole line
    5033             : by typing \\[move-beginning-of-line] \\[kill-line].
    5034             : 
    5035             : If you want to append the killed line to the last killed text,
    5036             : use \\[append-next-kill] before \\[kill-line].
    5037             : 
    5038             : If the buffer is read-only, Emacs will beep and refrain from deleting
    5039             : the line, but put the line in the kill ring anyway.  This means that
    5040             : you can use this command to copy text from a read-only buffer.
    5041             : \(If the variable `kill-read-only-ok' is non-nil, then this won't
    5042             : even beep.)"
    5043             :   (interactive "P")
    5044           0 :   (kill-region (point)
    5045             :                ;; It is better to move point to the other end of the kill
    5046             :                ;; before killing.  That way, in a read-only buffer, point
    5047             :                ;; moves across the text that is copied to the kill ring.
    5048             :                ;; The choice has no effect on undo now that undo records
    5049             :                ;; the value of point from before the command was run.
    5050           0 :                (progn
    5051           0 :                  (if arg
    5052           0 :                      (forward-visible-line (prefix-numeric-value arg))
    5053           0 :                    (if (eobp)
    5054           0 :                        (signal 'end-of-buffer nil))
    5055           0 :                    (let ((end
    5056           0 :                           (save-excursion
    5057           0 :                             (end-of-visible-line) (point))))
    5058           0 :                      (if (or (save-excursion
    5059             :                                ;; If trailing whitespace is visible,
    5060             :                                ;; don't treat it as nothing.
    5061           0 :                                (unless show-trailing-whitespace
    5062           0 :                                  (skip-chars-forward " \t" end))
    5063           0 :                                (= (point) end))
    5064           0 :                              (and kill-whole-line (bolp)))
    5065           0 :                          (forward-visible-line 1)
    5066           0 :                        (goto-char end))))
    5067           0 :                  (point))))
    5068             : 
    5069             : (defun kill-whole-line (&optional arg)
    5070             :   "Kill current line.
    5071             : With prefix ARG, kill that many lines starting from the current line.
    5072             : If ARG is negative, kill backward.  Also kill the preceding newline.
    5073             : \(This is meant to make \\[repeat] work well with negative arguments.)
    5074             : If ARG is zero, kill current line but exclude the trailing newline."
    5075             :   (interactive "p")
    5076           0 :   (or arg (setq arg 1))
    5077           0 :   (if (and (> arg 0) (eobp) (save-excursion (forward-visible-line 0) (eobp)))
    5078           0 :       (signal 'end-of-buffer nil))
    5079           0 :   (if (and (< arg 0) (bobp) (save-excursion (end-of-visible-line) (bobp)))
    5080           0 :       (signal 'beginning-of-buffer nil))
    5081           0 :   (unless (eq last-command 'kill-region)
    5082           0 :     (kill-new "")
    5083           0 :     (setq last-command 'kill-region))
    5084           0 :   (cond ((zerop arg)
    5085             :          ;; We need to kill in two steps, because the previous command
    5086             :          ;; could have been a kill command, in which case the text
    5087             :          ;; before point needs to be prepended to the current kill
    5088             :          ;; ring entry and the text after point appended.  Also, we
    5089             :          ;; need to use save-excursion to avoid copying the same text
    5090             :          ;; twice to the kill ring in read-only buffers.
    5091           0 :          (save-excursion
    5092           0 :            (kill-region (point) (progn (forward-visible-line 0) (point))))
    5093           0 :          (kill-region (point) (progn (end-of-visible-line) (point))))
    5094           0 :         ((< arg 0)
    5095           0 :          (save-excursion
    5096           0 :            (kill-region (point) (progn (end-of-visible-line) (point))))
    5097           0 :          (kill-region (point)
    5098           0 :                       (progn (forward-visible-line (1+ arg))
    5099           0 :                              (unless (bobp) (backward-char))
    5100           0 :                              (point))))
    5101             :         (t
    5102           0 :          (save-excursion
    5103           0 :            (kill-region (point) (progn (forward-visible-line 0) (point))))
    5104           0 :          (kill-region (point)
    5105           0 :                       (progn (forward-visible-line arg) (point))))))
    5106             : 
    5107             : (defun forward-visible-line (arg)
    5108             :   "Move forward by ARG lines, ignoring currently invisible newlines only.
    5109             : If ARG is negative, move backward -ARG lines.
    5110             : If ARG is zero, move to the beginning of the current line."
    5111           0 :   (condition-case nil
    5112           0 :       (if (> arg 0)
    5113           0 :           (progn
    5114           0 :             (while (> arg 0)
    5115           0 :               (or (zerop (forward-line 1))
    5116           0 :                   (signal 'end-of-buffer nil))
    5117             :               ;; If the newline we just skipped is invisible,
    5118             :               ;; don't count it.
    5119           0 :               (let ((prop
    5120           0 :                      (get-char-property (1- (point)) 'invisible)))
    5121           0 :                 (if (if (eq buffer-invisibility-spec t)
    5122           0 :                         prop
    5123           0 :                       (or (memq prop buffer-invisibility-spec)
    5124           0 :                           (assq prop buffer-invisibility-spec)))
    5125           0 :                     (setq arg (1+ arg))))
    5126           0 :               (setq arg (1- arg)))
    5127             :             ;; If invisible text follows, and it is a number of complete lines,
    5128             :             ;; skip it.
    5129           0 :             (let ((opoint (point)))
    5130           0 :               (while (and (not (eobp))
    5131           0 :                           (let ((prop
    5132           0 :                                  (get-char-property (point) 'invisible)))
    5133           0 :                             (if (eq buffer-invisibility-spec t)
    5134           0 :                                 prop
    5135           0 :                               (or (memq prop buffer-invisibility-spec)
    5136           0 :                                   (assq prop buffer-invisibility-spec)))))
    5137           0 :                 (goto-char
    5138           0 :                  (if (get-text-property (point) 'invisible)
    5139           0 :                      (or (next-single-property-change (point) 'invisible)
    5140           0 :                          (point-max))
    5141           0 :                    (next-overlay-change (point)))))
    5142           0 :               (unless (bolp)
    5143           0 :                 (goto-char opoint))))
    5144           0 :         (let ((first t))
    5145           0 :           (while (or first (<= arg 0))
    5146           0 :             (if first
    5147           0 :                 (beginning-of-line)
    5148           0 :               (or (zerop (forward-line -1))
    5149           0 :                   (signal 'beginning-of-buffer nil)))
    5150             :             ;; If the newline we just moved to is invisible,
    5151             :             ;; don't count it.
    5152           0 :             (unless (bobp)
    5153           0 :               (let ((prop
    5154           0 :                      (get-char-property (1- (point)) 'invisible)))
    5155           0 :                 (unless (if (eq buffer-invisibility-spec t)
    5156           0 :                             prop
    5157           0 :                           (or (memq prop buffer-invisibility-spec)
    5158           0 :                               (assq prop buffer-invisibility-spec)))
    5159           0 :                   (setq arg (1+ arg)))))
    5160           0 :             (setq first nil))
    5161             :           ;; If invisible text follows, and it is a number of complete lines,
    5162             :           ;; skip it.
    5163           0 :           (let ((opoint (point)))
    5164           0 :             (while (and (not (bobp))
    5165           0 :                         (let ((prop
    5166           0 :                                (get-char-property (1- (point)) 'invisible)))
    5167           0 :                           (if (eq buffer-invisibility-spec t)
    5168           0 :                               prop
    5169           0 :                             (or (memq prop buffer-invisibility-spec)
    5170           0 :                                 (assq prop buffer-invisibility-spec)))))
    5171           0 :               (goto-char
    5172           0 :                (if (get-text-property (1- (point)) 'invisible)
    5173           0 :                    (or (previous-single-property-change (point) 'invisible)
    5174           0 :                        (point-min))
    5175           0 :                  (previous-overlay-change (point)))))
    5176           0 :             (unless (bolp)
    5177           0 :               (goto-char opoint)))))
    5178             :     ((beginning-of-buffer end-of-buffer)
    5179           0 :      nil)))
    5180             : 
    5181             : (defun end-of-visible-line ()
    5182             :   "Move to end of current visible line."
    5183           0 :   (end-of-line)
    5184             :   ;; If the following character is currently invisible,
    5185             :   ;; skip all characters with that same `invisible' property value,
    5186             :   ;; then find the next newline.
    5187           0 :   (while (and (not (eobp))
    5188           0 :               (save-excursion
    5189           0 :                 (skip-chars-forward "^\n")
    5190           0 :                 (let ((prop
    5191           0 :                        (get-char-property (point) 'invisible)))
    5192           0 :                   (if (eq buffer-invisibility-spec t)
    5193           0 :                       prop
    5194           0 :                     (or (memq prop buffer-invisibility-spec)
    5195           0 :                         (assq prop buffer-invisibility-spec))))))
    5196           0 :     (skip-chars-forward "^\n")
    5197           0 :     (if (get-text-property (point) 'invisible)
    5198           0 :         (goto-char (or (next-single-property-change (point) 'invisible)
    5199           0 :                        (point-max)))
    5200           0 :       (goto-char (next-overlay-change (point))))
    5201           0 :     (end-of-line)))
    5202             : 
    5203             : (defun kill-current-buffer ()
    5204             :   "Kill the current buffer.
    5205             : When called in the minibuffer, get out of the minibuffer
    5206             : using `abort-recursive-edit'.
    5207             : 
    5208             : This is like `kill-this-buffer', but it doesn't have to be invoked
    5209             : via the menu bar, and pays no attention to the menu-bar's frame."
    5210             :   (interactive)
    5211           0 :   (let ((frame (selected-frame)))
    5212           0 :     (if (and (frame-live-p frame)
    5213           0 :              (not (window-minibuffer-p (frame-selected-window frame))))
    5214           0 :         (kill-buffer (current-buffer))
    5215           0 :       (abort-recursive-edit))))
    5216             : 
    5217             : 
    5218             : (defun insert-buffer (buffer)
    5219             :   "Insert after point the contents of BUFFER.
    5220             : Puts mark after the inserted text.
    5221             : BUFFER may be a buffer or a buffer name."
    5222             :   (declare (interactive-only insert-buffer-substring))
    5223             :   (interactive
    5224           0 :    (list
    5225           0 :     (progn
    5226           0 :       (barf-if-buffer-read-only)
    5227           0 :       (read-buffer "Insert buffer: "
    5228           0 :                    (if (eq (selected-window) (next-window))
    5229           0 :                        (other-buffer (current-buffer))
    5230           0 :                      (window-buffer (next-window)))
    5231           0 :                    t))))
    5232           0 :   (push-mark
    5233           0 :    (save-excursion
    5234           0 :      (insert-buffer-substring (get-buffer buffer))
    5235           0 :      (point)))
    5236             :   nil)
    5237             : 
    5238             : (defun append-to-buffer (buffer start end)
    5239             :   "Append to specified buffer the text of the region.
    5240             : It is inserted into that buffer before its point.
    5241             : 
    5242             : When calling from a program, give three arguments:
    5243             : BUFFER (or buffer name), START and END.
    5244             : START and END specify the portion of the current buffer to be copied."
    5245             :   (interactive
    5246           0 :    (list (read-buffer "Append to buffer: " (other-buffer (current-buffer) t))
    5247           0 :          (region-beginning) (region-end)))
    5248           0 :   (let* ((oldbuf (current-buffer))
    5249           0 :          (append-to (get-buffer-create buffer))
    5250           0 :          (windows (get-buffer-window-list append-to t t))
    5251             :          point)
    5252           0 :     (save-excursion
    5253           0 :       (with-current-buffer append-to
    5254           0 :         (setq point (point))
    5255           0 :         (barf-if-buffer-read-only)
    5256           0 :         (insert-buffer-substring oldbuf start end)
    5257           0 :         (dolist (window windows)
    5258           0 :           (when (= (window-point window) point)
    5259           0 :             (set-window-point window (point))))))))
    5260             : 
    5261             : (defun prepend-to-buffer (buffer start end)
    5262             :   "Prepend to specified buffer the text of the region.
    5263             : It is inserted into that buffer after its point.
    5264             : 
    5265             : When calling from a program, give three arguments:
    5266             : BUFFER (or buffer name), START and END.
    5267             : START and END specify the portion of the current buffer to be copied."
    5268             :   (interactive "BPrepend to buffer: \nr")
    5269           0 :   (let ((oldbuf (current-buffer)))
    5270           0 :     (with-current-buffer (get-buffer-create buffer)
    5271           0 :       (barf-if-buffer-read-only)
    5272           0 :       (save-excursion
    5273           0 :         (insert-buffer-substring oldbuf start end)))))
    5274             : 
    5275             : (defun copy-to-buffer (buffer start end)
    5276             :   "Copy to specified buffer the text of the region.
    5277             : It is inserted into that buffer, replacing existing text there.
    5278             : 
    5279             : When calling from a program, give three arguments:
    5280             : BUFFER (or buffer name), START and END.
    5281             : START and END specify the portion of the current buffer to be copied."
    5282             :   (interactive "BCopy to buffer: \nr")
    5283           0 :   (let ((oldbuf (current-buffer)))
    5284           0 :     (with-current-buffer (get-buffer-create buffer)
    5285           0 :       (barf-if-buffer-read-only)
    5286           0 :       (erase-buffer)
    5287           0 :       (save-excursion
    5288           0 :         (insert-buffer-substring oldbuf start end)))))
    5289             : 
    5290             : (define-error 'mark-inactive (purecopy "The mark is not active now"))
    5291             : 
    5292             : (defvar activate-mark-hook nil
    5293             :   "Hook run when the mark becomes active.
    5294             : It is also run at the end of a command, if the mark is active and
    5295             : it is possible that the region may have changed.")
    5296             : 
    5297             : (defvar deactivate-mark-hook nil
    5298             :   "Hook run when the mark becomes inactive.")
    5299             : 
    5300             : (defun mark (&optional force)
    5301             :   "Return this buffer's mark value as integer, or nil if never set.
    5302             : 
    5303             : In Transient Mark mode, this function signals an error if
    5304             : the mark is not active.  However, if `mark-even-if-inactive' is non-nil,
    5305             : or the argument FORCE is non-nil, it disregards whether the mark
    5306             : is active, and returns an integer or nil in the usual way.
    5307             : 
    5308             : If you are using this in an editing command, you are most likely making
    5309             : a mistake; see the documentation of `set-mark'."
    5310           8 :   (if (or force (not transient-mark-mode) mark-active mark-even-if-inactive)
    5311           8 :       (marker-position (mark-marker))
    5312           8 :     (signal 'mark-inactive nil)))
    5313             : 
    5314             : ;; Behind display-selections-p.
    5315             : 
    5316             : (defun deactivate-mark (&optional force)
    5317             :   "Deactivate the mark.
    5318             : If Transient Mark mode is disabled, this function normally does
    5319             : nothing; but if FORCE is non-nil, it deactivates the mark anyway.
    5320             : 
    5321             : Deactivating the mark sets `mark-active' to nil, updates the
    5322             : primary selection according to `select-active-regions', and runs
    5323             : `deactivate-mark-hook'.
    5324             : 
    5325             : If Transient Mark mode was temporarily enabled, reset the value
    5326             : of the variable `transient-mark-mode'; if this causes Transient
    5327             : Mark mode to be disabled, don't change `mark-active' to nil or
    5328             : run `deactivate-mark-hook'."
    5329           0 :   (when (or (region-active-p) force)
    5330           0 :     (when (and (if (eq select-active-regions 'only)
    5331           0 :                    (eq (car-safe transient-mark-mode) 'only)
    5332           0 :                  select-active-regions)
    5333           0 :                (region-active-p)
    5334           0 :                (display-selections-p))
    5335             :       ;; The var `saved-region-selection', if non-nil, is the text in
    5336             :       ;; the region prior to the last command modifying the buffer.
    5337             :       ;; Set the selection to that, or to the current region.
    5338           0 :       (cond (saved-region-selection
    5339           0 :              (if (gui-backend-selection-owner-p 'PRIMARY)
    5340           0 :                  (gui-set-selection 'PRIMARY saved-region-selection))
    5341           0 :              (setq saved-region-selection nil))
    5342             :             ;; If another program has acquired the selection, region
    5343             :             ;; deactivation should not clobber it (Bug#11772).
    5344           0 :             ((and (/= (region-beginning) (region-end))
    5345           0 :                   (or (gui-backend-selection-owner-p 'PRIMARY)
    5346           0 :                       (null (gui-backend-selection-exists-p 'PRIMARY))))
    5347           0 :              (gui-set-selection 'PRIMARY
    5348           0 :                                 (funcall region-extract-function nil)))))
    5349           0 :     (when mark-active (force-mode-line-update)) ;Refresh toolbar (bug#16382).
    5350           0 :     (cond
    5351           0 :      ((eq (car-safe transient-mark-mode) 'only)
    5352           0 :       (setq transient-mark-mode (cdr transient-mark-mode))
    5353           0 :       (if (eq transient-mark-mode (default-value 'transient-mark-mode))
    5354           0 :           (kill-local-variable 'transient-mark-mode)))
    5355           0 :      ((eq transient-mark-mode 'lambda)
    5356           0 :       (kill-local-variable 'transient-mark-mode)))
    5357           0 :     (setq mark-active nil)
    5358           0 :     (run-hooks 'deactivate-mark-hook)
    5359           0 :     (redisplay--update-region-highlight (selected-window))))
    5360             : 
    5361             : (defun activate-mark (&optional no-tmm)
    5362             :   "Activate the mark.
    5363             : If NO-TMM is non-nil, leave `transient-mark-mode' alone."
    5364           2 :   (when (mark t)
    5365           2 :     (unless (region-active-p)
    5366           2 :       (force-mode-line-update) ;Refresh toolbar (bug#16382).
    5367           2 :       (setq mark-active t)
    5368           2 :       (unless (or transient-mark-mode no-tmm)
    5369           2 :         (setq-local transient-mark-mode 'lambda))
    5370           2 :       (run-hooks 'activate-mark-hook))))
    5371             : 
    5372             : (defun set-mark (pos)
    5373             :   "Set this buffer's mark to POS.  Don't use this function!
    5374             : That is to say, don't use this function unless you want
    5375             : the user to see that the mark has moved, and you want the previous
    5376             : mark position to be lost.
    5377             : 
    5378             : Normally, when a new mark is set, the old one should go on the stack.
    5379             : This is why most applications should use `push-mark', not `set-mark'.
    5380             : 
    5381             : Novice Emacs Lisp programmers often try to use the mark for the wrong
    5382             : purposes.  The mark saves a location for the user's convenience.
    5383             : Most editing commands should not alter the mark.
    5384             : To remember a location for internal use in the Lisp program,
    5385             : store it in a Lisp variable.  Example:
    5386             : 
    5387             :    (let ((beg (point))) (forward-line 1) (delete-region beg (point)))."
    5388           2 :   (if pos
    5389           2 :       (progn
    5390           2 :         (set-marker (mark-marker) pos (current-buffer))
    5391           2 :         (activate-mark 'no-tmm))
    5392             :     ;; Normally we never clear mark-active except in Transient Mark mode.
    5393             :     ;; But when we actually clear out the mark value too, we must
    5394             :     ;; clear mark-active in any mode.
    5395           0 :     (deactivate-mark t)
    5396             :     ;; `deactivate-mark' sometimes leaves mark-active non-nil, but
    5397             :     ;; it should never be nil if the mark is nil.
    5398           0 :     (setq mark-active nil)
    5399           2 :     (set-marker (mark-marker) nil)))
    5400             : 
    5401             : (defun save-mark-and-excursion--save ()
    5402           0 :   (cons
    5403           0 :    (let ((mark (mark-marker)))
    5404           0 :      (and (marker-position mark) (copy-marker mark)))
    5405           0 :    mark-active))
    5406             : 
    5407             : (defun save-mark-and-excursion--restore (saved-mark-info)
    5408           0 :   (let ((saved-mark (car saved-mark-info))
    5409           0 :         (omark (marker-position (mark-marker)))
    5410             :         (nmark nil)
    5411           0 :         (saved-mark-active (cdr saved-mark-info)))
    5412             :     ;; Mark marker
    5413           0 :     (if (null saved-mark)
    5414           0 :         (set-marker (mark-marker) nil)
    5415           0 :       (setf nmark (marker-position saved-mark))
    5416           0 :       (set-marker (mark-marker) nmark)
    5417           0 :       (set-marker saved-mark nil))
    5418             :     ;; Mark active
    5419           0 :     (let ((cur-mark-active mark-active))
    5420           0 :       (setq mark-active saved-mark-active)
    5421             :       ;; If mark is active now, and either was not active or was at a
    5422             :       ;; different place, run the activate hook.
    5423           0 :       (if saved-mark-active
    5424           0 :           (when (or (not cur-mark-active)
    5425           0 :                     (not (eq omark nmark)))
    5426           0 :             (run-hooks 'activate-mark-hook))
    5427             :         ;; If mark has ceased to be active, run deactivate hook.
    5428           0 :         (when cur-mark-active
    5429           0 :           (run-hooks 'deactivate-mark-hook))))))
    5430             : 
    5431             : (defmacro save-mark-and-excursion (&rest body)
    5432             :   "Like `save-excursion', but also save and restore the mark state.
    5433             : This macro does what `save-excursion' did before Emacs 25.1."
    5434             :   (declare (indent 0) (debug t))
    5435           1 :   (let ((saved-marker-sym (make-symbol "saved-marker")))
    5436           1 :     `(let ((,saved-marker-sym (save-mark-and-excursion--save)))
    5437             :        (unwind-protect
    5438           1 :             (save-excursion ,@body)
    5439           1 :          (save-mark-and-excursion--restore ,saved-marker-sym)))))
    5440             : 
    5441             : (defcustom use-empty-active-region nil
    5442             :   "Whether \"region-aware\" commands should act on empty regions.
    5443             : If nil, region-aware commands treat the empty region as inactive.
    5444             : If non-nil, region-aware commands treat the region as active as
    5445             : long as the mark is active, even if the region is empty.
    5446             : 
    5447             : Region-aware commands are those that act on the region if it is
    5448             : active and Transient Mark mode is enabled, and on the text near
    5449             : point otherwise."
    5450             :   :type 'boolean
    5451             :   :version "23.1"
    5452             :   :group 'editing-basics)
    5453             : 
    5454             : (defun use-region-p ()
    5455             :   "Return t if the region is active and it is appropriate to act on it.
    5456             : This is used by commands that act specially on the region under
    5457             : Transient Mark mode.
    5458             : 
    5459             : The return value is t if Transient Mark mode is enabled and the
    5460             : mark is active; furthermore, if `use-empty-active-region' is nil,
    5461             : the region must not be empty.  Otherwise, the return value is nil.
    5462             : 
    5463             : For some commands, it may be appropriate to ignore the value of
    5464             : `use-empty-active-region'; in that case, use `region-active-p'."
    5465           0 :   (and (region-active-p)
    5466           0 :        (or use-empty-active-region (> (region-end) (region-beginning)))))
    5467             : 
    5468             : (defun region-active-p ()
    5469             :   "Return non-nil if Transient Mark mode is enabled and the mark is active.
    5470             : 
    5471             : Some commands act specially on the region when Transient Mark
    5472             : mode is enabled.  Usually, such commands should use
    5473             : `use-region-p' instead of this function, because `use-region-p'
    5474             : also checks the value of `use-empty-active-region'."
    5475           2 :   (and transient-mark-mode mark-active
    5476             :        ;; FIXME: Somehow we sometimes end up with mark-active non-nil but
    5477             :        ;; without the mark being set (e.g. bug#17324).  We really should fix
    5478             :        ;; that problem, but in the mean time, let's make sure we don't say the
    5479             :        ;; region is active when there's no mark.
    5480           2 :        (progn (cl-assert (mark)) t)))
    5481             : 
    5482             : (defun region-bounds ()
    5483             :   "Return the boundaries of the region as a list of (START . END) positions."
    5484           0 :   (funcall region-extract-function 'bounds))
    5485             : 
    5486             : (defun region-noncontiguous-p ()
    5487             :   "Return non-nil if the region contains several pieces.
    5488             : An example is a rectangular region handled as a list of
    5489             : separate contiguous regions for each line."
    5490           0 :   (> (length (region-bounds)) 1))
    5491             : 
    5492             : (defvar redisplay-unhighlight-region-function
    5493             :   (lambda (rol) (when (overlayp rol) (delete-overlay rol))))
    5494             : 
    5495             : (defvar redisplay-highlight-region-function
    5496             :   (lambda (start end window rol)
    5497             :     (if (not (overlayp rol))
    5498             :         (let ((nrol (make-overlay start end)))
    5499             :           (funcall redisplay-unhighlight-region-function rol)
    5500             :           (overlay-put nrol 'window window)
    5501             :           (overlay-put nrol 'face 'region)
    5502             :           ;; Normal priority so that a large region doesn't hide all the
    5503             :           ;; overlays within it, but high secondary priority so that if it
    5504             :           ;; ends/starts in the middle of a small overlay, that small overlay
    5505             :           ;; won't hide the region's boundaries.
    5506             :           (overlay-put nrol 'priority '(nil . 100))
    5507             :           nrol)
    5508             :       (unless (and (eq (overlay-buffer rol) (current-buffer))
    5509             :                    (eq (overlay-start rol) start)
    5510             :                    (eq (overlay-end rol) end))
    5511             :         (move-overlay rol start end (current-buffer)))
    5512             :       rol)))
    5513             : 
    5514             : (defun redisplay--update-region-highlight (window)
    5515           0 :   (let ((rol (window-parameter window 'internal-region-overlay)))
    5516           0 :     (if (not (and (region-active-p)
    5517           0 :                   (or highlight-nonselected-windows
    5518           0 :                       (eq window (selected-window))
    5519           0 :                       (and (window-minibuffer-p)
    5520           0 :                            (eq window (minibuffer-selected-window))))))
    5521           0 :         (funcall redisplay-unhighlight-region-function rol)
    5522           0 :       (let* ((pt (window-point window))
    5523           0 :              (mark (mark))
    5524           0 :              (start (min pt mark))
    5525           0 :              (end   (max pt mark))
    5526             :              (new
    5527           0 :               (funcall redisplay-highlight-region-function
    5528           0 :                        start end window rol)))
    5529           0 :         (unless (equal new rol)
    5530           0 :           (set-window-parameter window 'internal-region-overlay
    5531           0 :                                 new))))))
    5532             : 
    5533             : (defvar pre-redisplay-functions (list #'redisplay--update-region-highlight)
    5534             :   "Hook run just before redisplay.
    5535             : It is called in each window that is to be redisplayed.  It takes one argument,
    5536             : which is the window that will be redisplayed.  When run, the `current-buffer'
    5537             : is set to the buffer displayed in that window.")
    5538             : 
    5539             : (defun redisplay--pre-redisplay-functions (windows)
    5540           0 :   (with-demoted-errors "redisplay--pre-redisplay-functions: %S"
    5541           0 :     (if (null windows)
    5542           0 :         (with-current-buffer (window-buffer (selected-window))
    5543           0 :           (run-hook-with-args 'pre-redisplay-functions (selected-window)))
    5544           0 :       (dolist (win (if (listp windows) windows (window-list-1 nil nil t)))
    5545           0 :         (with-current-buffer (window-buffer win)
    5546           0 :           (run-hook-with-args 'pre-redisplay-functions win))))))
    5547             : 
    5548             : (add-function :before pre-redisplay-function
    5549             :               #'redisplay--pre-redisplay-functions)
    5550             : 
    5551             : 
    5552             : (defvar-local mark-ring nil
    5553             :   "The list of former marks of the current buffer, most recent first.")
    5554             : (put 'mark-ring 'permanent-local t)
    5555             : 
    5556             : (defcustom mark-ring-max 16
    5557             :   "Maximum size of mark ring.  Start discarding off end if gets this big."
    5558             :   :type 'integer
    5559             :   :group 'editing-basics)
    5560             : 
    5561             : (defvar global-mark-ring nil
    5562             :   "The list of saved global marks, most recent first.")
    5563             : 
    5564             : (defcustom global-mark-ring-max 16
    5565             :   "Maximum size of global mark ring.  \
    5566             : Start discarding off end if gets this big."
    5567             :   :type 'integer
    5568             :   :group 'editing-basics)
    5569             : 
    5570             : (defun pop-to-mark-command ()
    5571             :   "Jump to mark, and pop a new position for mark off the ring.
    5572             : \(Does not affect global mark ring)."
    5573             :   (interactive)
    5574           0 :   (if (null (mark t))
    5575           0 :       (user-error "No mark set in this buffer")
    5576           0 :     (if (= (point) (mark t))
    5577           0 :         (message "Mark popped"))
    5578           0 :     (goto-char (mark t))
    5579           0 :     (pop-mark)))
    5580             : 
    5581             : (defun push-mark-command (arg &optional nomsg)
    5582             :   "Set mark at where point is.
    5583             : If no prefix ARG and mark is already set there, just activate it.
    5584             : Display `Mark set' unless the optional second arg NOMSG is non-nil."
    5585             :   (interactive "P")
    5586           0 :   (let ((mark (mark t)))
    5587           0 :     (if (or arg (null mark) (/= mark (point)))
    5588           0 :         (push-mark nil nomsg t)
    5589           0 :       (activate-mark 'no-tmm)
    5590           0 :       (unless nomsg
    5591           0 :         (message "Mark activated")))))
    5592             : 
    5593             : (defcustom set-mark-command-repeat-pop nil
    5594             :   "Non-nil means repeating \\[set-mark-command] after popping mark pops it again.
    5595             : That means that C-u \\[set-mark-command] \\[set-mark-command]
    5596             : will pop the mark twice, and
    5597             : C-u \\[set-mark-command] \\[set-mark-command] \\[set-mark-command]
    5598             : will pop the mark three times.
    5599             : 
    5600             : A value of nil means \\[set-mark-command]'s behavior does not change
    5601             : after C-u \\[set-mark-command]."
    5602             :   :type 'boolean
    5603             :   :group 'editing-basics)
    5604             : 
    5605             : (defun set-mark-command (arg)
    5606             :   "Set the mark where point is, and activate it; or jump to the mark.
    5607             : Setting the mark also alters the region, which is the text
    5608             : between point and mark; this is the closest equivalent in
    5609             : Emacs to what some editors call the \"selection\".
    5610             : 
    5611             : With no prefix argument, set the mark at point, and push the
    5612             : old mark position on local mark ring.  Also push the new mark on
    5613             : global mark ring, if the previous mark was set in another buffer.
    5614             : 
    5615             : When Transient Mark Mode is off, immediately repeating this
    5616             : command activates `transient-mark-mode' temporarily.
    5617             : 
    5618             : With prefix argument (e.g., \\[universal-argument] \\[set-mark-command]), \
    5619             : jump to the mark, and set the mark from
    5620             : position popped off the local mark ring (this does not affect the global
    5621             : mark ring).  Use \\[pop-global-mark] to jump to a mark popped off the global
    5622             : mark ring (see `pop-global-mark').
    5623             : 
    5624             : If `set-mark-command-repeat-pop' is non-nil, repeating
    5625             : the \\[set-mark-command] command with no prefix argument pops the next position
    5626             : off the local (or global) mark ring and jumps there.
    5627             : 
    5628             : With \\[universal-argument] \\[universal-argument] as prefix
    5629             : argument, unconditionally set mark where point is, even if
    5630             : `set-mark-command-repeat-pop' is non-nil.
    5631             : 
    5632             : Novice Emacs Lisp programmers often try to use the mark for the wrong
    5633             : purposes.  See the documentation of `set-mark' for more information."
    5634             :   (interactive "P")
    5635           0 :   (cond ((eq transient-mark-mode 'lambda)
    5636           0 :          (kill-local-variable 'transient-mark-mode))
    5637           0 :         ((eq (car-safe transient-mark-mode) 'only)
    5638           0 :          (deactivate-mark)))
    5639           0 :   (cond
    5640           0 :    ((and (consp arg) (> (prefix-numeric-value arg) 4))
    5641           0 :     (push-mark-command nil))
    5642           0 :    ((not (eq this-command 'set-mark-command))
    5643           0 :     (if arg
    5644           0 :         (pop-to-mark-command)
    5645           0 :       (push-mark-command t)))
    5646           0 :    ((and set-mark-command-repeat-pop
    5647           0 :          (eq last-command 'pop-global-mark)
    5648           0 :          (not arg))
    5649           0 :     (setq this-command 'pop-global-mark)
    5650           0 :     (pop-global-mark))
    5651           0 :    ((or (and set-mark-command-repeat-pop
    5652           0 :              (eq last-command 'pop-to-mark-command))
    5653           0 :         arg)
    5654           0 :     (setq this-command 'pop-to-mark-command)
    5655           0 :     (pop-to-mark-command))
    5656           0 :    ((eq last-command 'set-mark-command)
    5657           0 :     (if (region-active-p)
    5658           0 :         (progn
    5659           0 :           (deactivate-mark)
    5660           0 :           (message "Mark deactivated"))
    5661           0 :       (activate-mark)
    5662           0 :       (message "Mark activated")))
    5663             :    (t
    5664           0 :     (push-mark-command nil))))
    5665             : 
    5666             : (defun push-mark (&optional location nomsg activate)
    5667             :   "Set mark at LOCATION (point, by default) and push old mark on mark ring.
    5668             : If the last global mark pushed was not in the current buffer,
    5669             : also push LOCATION on the global mark ring.
    5670             : Display `Mark set' unless the optional second arg NOMSG is non-nil.
    5671             : 
    5672             : Novice Emacs Lisp programmers often try to use the mark for the wrong
    5673             : purposes.  See the documentation of `set-mark' for more information.
    5674             : 
    5675             : In Transient Mark mode, activate mark if optional third arg ACTIVATE non-nil."
    5676           2 :   (unless (null (mark t))
    5677           0 :     (setq mark-ring (cons (copy-marker (mark-marker)) mark-ring))
    5678           0 :     (when (> (length mark-ring) mark-ring-max)
    5679           0 :       (move-marker (car (nthcdr mark-ring-max mark-ring)) nil)
    5680           2 :       (setcdr (nthcdr (1- mark-ring-max) mark-ring) nil)))
    5681           2 :   (set-marker (mark-marker) (or location (point)) (current-buffer))
    5682             :   ;; Now push the mark on the global mark ring.
    5683           2 :   (if (and global-mark-ring
    5684           2 :            (eq (marker-buffer (car global-mark-ring)) (current-buffer)))
    5685             :       ;; The last global mark pushed was in this same buffer.
    5686             :       ;; Don't push another one.
    5687             :       nil
    5688           2 :     (setq global-mark-ring (cons (copy-marker (mark-marker)) global-mark-ring))
    5689           2 :     (when (> (length global-mark-ring) global-mark-ring-max)
    5690           0 :       (move-marker (car (nthcdr global-mark-ring-max global-mark-ring)) nil)
    5691           2 :       (setcdr (nthcdr (1- global-mark-ring-max) global-mark-ring) nil)))
    5692           2 :   (or nomsg executing-kbd-macro (> (minibuffer-depth) 0)
    5693           2 :       (message "Mark set"))
    5694           2 :   (if (or activate (not transient-mark-mode))
    5695           2 :       (set-mark (mark t)))
    5696             :   nil)
    5697             : 
    5698             : (defun pop-mark ()
    5699             :   "Pop off mark ring into the buffer's actual mark.
    5700             : Does not set point.  Does nothing if mark ring is empty."
    5701           0 :   (when mark-ring
    5702           0 :     (setq mark-ring (nconc mark-ring (list (copy-marker (mark-marker)))))
    5703           0 :     (set-marker (mark-marker) (+ 0 (car mark-ring)) (current-buffer))
    5704           0 :     (move-marker (car mark-ring) nil)
    5705           0 :     (if (null (mark t)) (ding))
    5706           0 :     (setq mark-ring (cdr mark-ring)))
    5707           0 :   (deactivate-mark))
    5708             : 
    5709             : (define-obsolete-function-alias
    5710             :   'exchange-dot-and-mark 'exchange-point-and-mark "23.3")
    5711             : (defun exchange-point-and-mark (&optional arg)
    5712             :   "Put the mark where point is now, and point where the mark is now.
    5713             : This command works even when the mark is not active,
    5714             : and it reactivates the mark.
    5715             : 
    5716             : If Transient Mark mode is on, a prefix ARG deactivates the mark
    5717             : if it is active, and otherwise avoids reactivating it.  If
    5718             : Transient Mark mode is off, a prefix ARG enables Transient Mark
    5719             : mode temporarily."
    5720             :   (interactive "P")
    5721           0 :   (let ((omark (mark t))
    5722           0 :         (temp-highlight (eq (car-safe transient-mark-mode) 'only)))
    5723           0 :     (if (null omark)
    5724           0 :         (user-error "No mark set in this buffer"))
    5725           0 :     (set-mark (point))
    5726           0 :     (goto-char omark)
    5727           0 :     (cond (temp-highlight
    5728           0 :            (setq-local transient-mark-mode (cons 'only transient-mark-mode)))
    5729           0 :           ((or (and arg (region-active-p)) ; (xor arg (not (region-active-p)))
    5730           0 :                (not (or arg (region-active-p))))
    5731           0 :            (deactivate-mark))
    5732           0 :           (t (activate-mark)))
    5733           0 :     nil))
    5734             : 
    5735             : (defcustom shift-select-mode t
    5736             :   "When non-nil, shifted motion keys activate the mark momentarily.
    5737             : 
    5738             : While the mark is activated in this way, any shift-translated point
    5739             : motion key extends the region, and if Transient Mark mode was off, it
    5740             : is temporarily turned on.  Furthermore, the mark will be deactivated
    5741             : by any subsequent point motion key that was not shift-translated, or
    5742             : by any action that normally deactivates the mark in Transient Mark mode.
    5743             : 
    5744             : See `this-command-keys-shift-translated' for the meaning of
    5745             : shift-translation."
    5746             :   :type 'boolean
    5747             :   :group 'editing-basics)
    5748             : 
    5749             : (defun handle-shift-selection ()
    5750             :   "Activate/deactivate mark depending on invocation thru shift translation.
    5751             : This function is called by `call-interactively' when a command
    5752             : with a `^' character in its `interactive' spec is invoked, before
    5753             : running the command itself.
    5754             : 
    5755             : If `shift-select-mode' is enabled and the command was invoked
    5756             : through shift translation, set the mark and activate the region
    5757             : temporarily, unless it was already set in this way.  See
    5758             : `this-command-keys-shift-translated' for the meaning of shift
    5759             : translation.
    5760             : 
    5761             : Otherwise, if the region has been activated temporarily,
    5762             : deactivate it, and restore the variable `transient-mark-mode' to
    5763             : its earlier value."
    5764           0 :   (cond ((and shift-select-mode this-command-keys-shift-translated)
    5765           0 :          (unless (and mark-active
    5766           0 :                       (eq (car-safe transient-mark-mode) 'only))
    5767           0 :            (setq-local transient-mark-mode
    5768           0 :                        (cons 'only
    5769           0 :                              (unless (eq transient-mark-mode 'lambda)
    5770           0 :                                transient-mark-mode)))
    5771           0 :            (push-mark nil nil t)))
    5772           0 :         ((eq (car-safe transient-mark-mode) 'only)
    5773           0 :          (setq transient-mark-mode (cdr transient-mark-mode))
    5774           0 :          (if (eq transient-mark-mode (default-value 'transient-mark-mode))
    5775           0 :              (kill-local-variable 'transient-mark-mode))
    5776           0 :          (deactivate-mark))))
    5777             : 
    5778             : (define-minor-mode transient-mark-mode
    5779             :   "Toggle Transient Mark mode.
    5780             : With a prefix argument ARG, enable Transient Mark mode if ARG is
    5781             : positive, and disable it otherwise.  If called from Lisp, enable
    5782             : Transient Mark mode if ARG is omitted or nil.
    5783             : 
    5784             : Transient Mark mode is a global minor mode.  When enabled, the
    5785             : region is highlighted with the `region' face whenever the mark
    5786             : is active.  The mark is \"deactivated\" by changing the buffer,
    5787             : and after certain other operations that set the mark but whose
    5788             : main purpose is something else--for example, incremental search,
    5789             : \\[beginning-of-buffer], and \\[end-of-buffer].
    5790             : 
    5791             : You can also deactivate the mark by typing \\[keyboard-quit] or
    5792             : \\[keyboard-escape-quit].
    5793             : 
    5794             : Many commands change their behavior when Transient Mark mode is
    5795             : in effect and the mark is active, by acting on the region instead
    5796             : of their usual default part of the buffer's text.  Examples of
    5797             : such commands include \\[comment-dwim], \\[flush-lines], \\[keep-lines],
    5798             : \\[query-replace], \\[query-replace-regexp], \\[ispell], and \\[undo].
    5799             : To see the documentation of commands which are sensitive to the
    5800             : Transient Mark mode, invoke \\[apropos-documentation] and type \"transient\"
    5801             : or \"mark.*active\" at the prompt."
    5802             :   :global t
    5803             :   ;; It's defined in C/cus-start, this stops the d-m-m macro defining it again.
    5804             :   :variable (default-value 'transient-mark-mode))
    5805             : 
    5806             : (defvar widen-automatically t
    5807             :   "Non-nil means it is ok for commands to call `widen' when they want to.
    5808             : Some commands will do this in order to go to positions outside
    5809             : the current accessible part of the buffer.
    5810             : 
    5811             : If `widen-automatically' is nil, these commands will do something else
    5812             : as a fallback, and won't change the buffer bounds.")
    5813             : 
    5814             : (defvar non-essential nil
    5815             :   "Whether the currently executing code is performing an essential task.
    5816             : This variable should be non-nil only when running code which should not
    5817             : disturb the user.  E.g. it can be used to prevent Tramp from prompting the
    5818             : user for a password when we are simply scanning a set of files in the
    5819             : background or displaying possible completions before the user even asked
    5820             : for it.")
    5821             : 
    5822             : (defun pop-global-mark ()
    5823             :   "Pop off global mark ring and jump to the top location."
    5824             :   (interactive)
    5825             :   ;; Pop entries which refer to non-existent buffers.
    5826           0 :   (while (and global-mark-ring (not (marker-buffer (car global-mark-ring))))
    5827           0 :     (setq global-mark-ring (cdr global-mark-ring)))
    5828           0 :   (or global-mark-ring
    5829           0 :       (error "No global mark set"))
    5830           0 :   (let* ((marker (car global-mark-ring))
    5831           0 :          (buffer (marker-buffer marker))
    5832           0 :          (position (marker-position marker)))
    5833           0 :     (setq global-mark-ring (nconc (cdr global-mark-ring)
    5834           0 :                                   (list (car global-mark-ring))))
    5835           0 :     (set-buffer buffer)
    5836           0 :     (or (and (>= position (point-min))
    5837           0 :              (<= position (point-max)))
    5838           0 :         (if widen-automatically
    5839           0 :             (widen)
    5840           0 :           (error "Global mark position is outside accessible part of buffer")))
    5841           0 :     (goto-char position)
    5842           0 :     (switch-to-buffer buffer)))
    5843             : 
    5844             : (defcustom next-line-add-newlines nil
    5845             :   "If non-nil, `next-line' inserts newline to avoid `end of buffer' error."
    5846             :   :type 'boolean
    5847             :   :version "21.1"
    5848             :   :group 'editing-basics)
    5849             : 
    5850             : (defun next-line (&optional arg try-vscroll)
    5851             :   "Move cursor vertically down ARG lines.
    5852             : Interactively, vscroll tall lines if `auto-window-vscroll' is enabled.
    5853             : Non-interactively, use TRY-VSCROLL to control whether to vscroll tall
    5854             : lines: if either `auto-window-vscroll' or TRY-VSCROLL is nil, this
    5855             : function will not vscroll.
    5856             : 
    5857             : ARG defaults to 1.
    5858             : 
    5859             : If there is no character in the target line exactly under the current column,
    5860             : the cursor is positioned after the character in that line which spans this
    5861             : column, or at the end of the line if it is not long enough.
    5862             : If there is no line in the buffer after this one, behavior depends on the
    5863             : value of `next-line-add-newlines'.  If non-nil, it inserts a newline character
    5864             : to create a line, and moves the cursor to that line.  Otherwise it moves the
    5865             : cursor to the end of the buffer.
    5866             : 
    5867             : If the variable `line-move-visual' is non-nil, this command moves
    5868             : by display lines.  Otherwise, it moves by buffer lines, without
    5869             : taking variable-width characters or continued lines into account.
    5870             : See \\[next-logical-line] for a command that always moves by buffer lines.
    5871             : 
    5872             : The command \\[set-goal-column] can be used to create
    5873             : a semipermanent goal column for this command.
    5874             : Then instead of trying to move exactly vertically (or as close as possible),
    5875             : this command moves to the specified goal column (or as close as possible).
    5876             : The goal column is stored in the variable `goal-column', which is nil
    5877             : when there is no goal column.  Note that setting `goal-column'
    5878             : overrides `line-move-visual' and causes this command to move by buffer
    5879             : lines rather than by display lines."
    5880             :   (declare (interactive-only forward-line))
    5881             :   (interactive "^p\np")
    5882           0 :   (or arg (setq arg 1))
    5883           0 :   (if (and next-line-add-newlines (= arg 1))
    5884           0 :       (if (save-excursion (end-of-line) (eobp))
    5885             :           ;; When adding a newline, don't expand an abbrev.
    5886           0 :           (let ((abbrev-mode nil))
    5887           0 :             (end-of-line)
    5888           0 :             (insert (if use-hard-newlines hard-newline "\n")))
    5889           0 :         (line-move arg nil nil try-vscroll))
    5890           0 :     (if (called-interactively-p 'interactive)
    5891           0 :         (condition-case err
    5892           0 :             (line-move arg nil nil try-vscroll)
    5893             :           ((beginning-of-buffer end-of-buffer)
    5894           0 :            (signal (car err) (cdr err))))
    5895           0 :       (line-move arg nil nil try-vscroll)))
    5896             :   nil)
    5897             : 
    5898             : (defun previous-line (&optional arg try-vscroll)
    5899             :   "Move cursor vertically up ARG lines.
    5900             : Interactively, vscroll tall lines if `auto-window-vscroll' is enabled.
    5901             : Non-interactively, use TRY-VSCROLL to control whether to vscroll tall
    5902             : lines: if either `auto-window-vscroll' or TRY-VSCROLL is nil, this
    5903             : function will not vscroll.
    5904             : 
    5905             : ARG defaults to 1.
    5906             : 
    5907             : If there is no character in the target line exactly over the current column,
    5908             : the cursor is positioned after the character in that line which spans this
    5909             : column, or at the end of the line if it is not long enough.
    5910             : 
    5911             : If the variable `line-move-visual' is non-nil, this command moves
    5912             : by display lines.  Otherwise, it moves by buffer lines, without
    5913             : taking variable-width characters or continued lines into account.
    5914             : See \\[previous-logical-line] for a command that always moves by buffer lines.
    5915             : 
    5916             : The command \\[set-goal-column] can be used to create
    5917             : a semipermanent goal column for this command.
    5918             : Then instead of trying to move exactly vertically (or as close as possible),
    5919             : this command moves to the specified goal column (or as close as possible).
    5920             : The goal column is stored in the variable `goal-column', which is nil
    5921             : when there is no goal column.  Note that setting `goal-column'
    5922             : overrides `line-move-visual' and causes this command to move by buffer
    5923             : lines rather than by display lines."
    5924             :   (declare (interactive-only
    5925             :             "use `forward-line' with negative argument instead."))
    5926             :   (interactive "^p\np")
    5927           0 :   (or arg (setq arg 1))
    5928           0 :   (if (called-interactively-p 'interactive)
    5929           0 :       (condition-case err
    5930           0 :           (line-move (- arg) nil nil try-vscroll)
    5931             :         ((beginning-of-buffer end-of-buffer)
    5932           0 :          (signal (car err) (cdr err))))
    5933           0 :     (line-move (- arg) nil nil try-vscroll))
    5934             :   nil)
    5935             : 
    5936             : (defcustom track-eol nil
    5937             :   "Non-nil means vertical motion starting at end of line keeps to ends of lines.
    5938             : This means moving to the end of each line moved onto.
    5939             : The beginning of a blank line does not count as the end of a line.
    5940             : This has no effect when the variable `line-move-visual' is non-nil."
    5941             :   :type 'boolean
    5942             :   :group 'editing-basics)
    5943             : 
    5944             : (defcustom goal-column nil
    5945             :   "Semipermanent goal column for vertical motion, as set by \\[set-goal-column], or nil.
    5946             : A non-nil setting overrides the variable `line-move-visual', which see."
    5947             :   :type '(choice integer
    5948             :                  (const :tag "None" nil))
    5949             :   :group 'editing-basics)
    5950             : (make-variable-buffer-local 'goal-column)
    5951             : 
    5952             : (defvar temporary-goal-column 0
    5953             :   "Current goal column for vertical motion.
    5954             : It is the column where point was at the start of the current run
    5955             : of vertical motion commands.
    5956             : 
    5957             : When moving by visual lines via the function `line-move-visual', it is a cons
    5958             : cell (COL . HSCROLL), where COL is the x-position, in pixels,
    5959             : divided by the default column width, and HSCROLL is the number of
    5960             : columns by which window is scrolled from left margin.
    5961             : 
    5962             : When the `track-eol' feature is doing its job, the value is
    5963             : `most-positive-fixnum'.")
    5964             : 
    5965             : (defvar last--line-number-width 0
    5966             :   "Last value of width used for displaying line numbers.
    5967             : Used internally by `line-move-visual'.")
    5968             : 
    5969             : (defcustom line-move-ignore-invisible t
    5970             :   "Non-nil means commands that move by lines ignore invisible newlines.
    5971             : When this option is non-nil, \\[next-line], \\[previous-line], \\[move-end-of-line], and \\[move-beginning-of-line] behave
    5972             : as if newlines that are invisible didn't exist, and count
    5973             : only visible newlines.  Thus, moving across across 2 newlines
    5974             : one of which is invisible will be counted as a one-line move.
    5975             : Also, a non-nil value causes invisible text to be ignored when
    5976             : counting columns for the purposes of keeping point in the same
    5977             : column by \\[next-line] and \\[previous-line].
    5978             : 
    5979             : Outline mode sets this."
    5980             :   :type 'boolean
    5981             :   :group 'editing-basics)
    5982             : 
    5983             : (defcustom line-move-visual t
    5984             :   "When non-nil, `line-move' moves point by visual lines.
    5985             : This movement is based on where the cursor is displayed on the
    5986             : screen, instead of relying on buffer contents alone.  It takes
    5987             : into account variable-width characters and line continuation.
    5988             : If nil, `line-move' moves point by logical lines.
    5989             : A non-nil setting of `goal-column' overrides the value of this variable
    5990             : and forces movement by logical lines.
    5991             : A window that is  horizontally scrolled also forces movement by logical
    5992             : lines."
    5993             :   :type 'boolean
    5994             :   :group 'editing-basics
    5995             :   :version "23.1")
    5996             : 
    5997             : ;; Only used if display-graphic-p.
    5998             : (declare-function font-info "font.c" (name &optional frame))
    5999             : 
    6000             : (defun default-font-height ()
    6001             :   "Return the height in pixels of the current buffer's default face font.
    6002             : 
    6003             : If the default font is remapped (see `face-remapping-alist'), the
    6004             : function returns the height of the remapped face."
    6005           0 :   (let ((default-font (face-font 'default)))
    6006           0 :     (cond
    6007           0 :      ((and (display-multi-font-p)
    6008             :            ;; Avoid calling font-info if the frame's default font was
    6009             :            ;; not changed since the frame was created.  That's because
    6010             :            ;; font-info is expensive for some fonts, see bug #14838.
    6011           0 :            (not (string= (frame-parameter nil 'font) default-font)))
    6012           0 :       (aref (font-info default-font) 3))
    6013           0 :      (t (frame-char-height)))))
    6014             : 
    6015             : (defun default-font-width ()
    6016             :   "Return the width in pixels of the current buffer's default face font.
    6017             : 
    6018             : If the default font is remapped (see `face-remapping-alist'), the
    6019             : function returns the width of the remapped face."
    6020           0 :   (let ((default-font (face-font 'default)))
    6021           0 :     (cond
    6022           0 :      ((and (display-multi-font-p)
    6023             :            ;; Avoid calling font-info if the frame's default font was
    6024             :            ;; not changed since the frame was created.  That's because
    6025             :            ;; font-info is expensive for some fonts, see bug #14838.
    6026           0 :            (not (string= (frame-parameter nil 'font) default-font)))
    6027           0 :       (let* ((info (font-info (face-font 'default)))
    6028           0 :              (width (aref info 11)))
    6029           0 :         (if (> width 0)
    6030           0 :             width
    6031           0 :           (aref info 10))))
    6032           0 :      (t (frame-char-width)))))
    6033             : 
    6034             : (defun default-line-height ()
    6035             :   "Return the pixel height of current buffer's default-face text line.
    6036             : 
    6037             : The value includes `line-spacing', if any, defined for the buffer
    6038             : or the frame."
    6039           0 :   (let ((dfh (default-font-height))
    6040           0 :         (lsp (if (display-graphic-p)
    6041           0 :                  (or line-spacing
    6042           0 :                      (default-value 'line-spacing)
    6043           0 :                      (frame-parameter nil 'line-spacing)
    6044           0 :                      0)
    6045           0 :                0)))
    6046           0 :     (if (floatp lsp)
    6047           0 :         (setq lsp (truncate (* (frame-char-height) lsp))))
    6048           0 :     (+ dfh lsp)))
    6049             : 
    6050             : (defun window-screen-lines ()
    6051             :   "Return the number of screen lines in the text area of the selected window.
    6052             : 
    6053             : This is different from `window-text-height' in that this function counts
    6054             : lines in units of the height of the font used by the default face displayed
    6055             : in the window, not in units of the frame's default font, and also accounts
    6056             : for `line-spacing', if any, defined for the window's buffer or frame.
    6057             : 
    6058             : The value is a floating-point number."
    6059           0 :   (let ((edges (window-inside-pixel-edges))
    6060           0 :         (dlh (default-line-height)))
    6061           0 :     (/ (float (- (nth 3 edges) (nth 1 edges))) dlh)))
    6062             : 
    6063             : ;; Returns non-nil if partial move was done.
    6064             : (defun line-move-partial (arg noerror &optional _to-end)
    6065           0 :   (if (< arg 0)
    6066             :       ;; Move backward (up).
    6067             :       ;; If already vscrolled, reduce vscroll
    6068           0 :       (let ((vs (window-vscroll nil t))
    6069           0 :             (dlh (default-line-height)))
    6070           0 :         (when (> vs dlh)
    6071           0 :           (set-window-vscroll nil (- vs dlh) t)))
    6072             : 
    6073             :     ;; Move forward (down).
    6074           0 :     (let* ((lh (window-line-height -1))
    6075           0 :            (rowh (car lh))
    6076           0 :            (vpos (nth 1 lh))
    6077           0 :            (ypos (nth 2 lh))
    6078           0 :            (rbot (nth 3 lh))
    6079           0 :            (this-lh (window-line-height))
    6080           0 :            (this-height (car this-lh))
    6081           0 :            (this-ypos (nth 2 this-lh))
    6082           0 :            (dlh (default-line-height))
    6083           0 :            (wslines (window-screen-lines))
    6084           0 :            (edges (window-inside-pixel-edges))
    6085           0 :            (winh (- (nth 3 edges) (nth 1 edges) 1))
    6086             :            py vs last-line)
    6087           0 :       (if (> (mod wslines 1.0) 0.0)
    6088           0 :           (setq wslines (round (+ wslines 0.5))))
    6089           0 :       (when (or (null lh)
    6090           0 :                 (>= rbot dlh)
    6091           0 :                 (<= ypos (- dlh))
    6092           0 :                 (null this-lh)
    6093           0 :                 (<= this-ypos (- dlh)))
    6094           0 :         (unless lh
    6095           0 :           (let ((wend (pos-visible-in-window-p t nil t)))
    6096           0 :             (setq rbot (nth 3 wend)
    6097           0 :                   rowh  (nth 4 wend)
    6098           0 :                   vpos (nth 5 wend))))
    6099           0 :         (unless this-lh
    6100           0 :           (let ((wstart (pos-visible-in-window-p nil nil t)))
    6101           0 :             (setq this-ypos (nth 2 wstart)
    6102           0 :                   this-height (nth 4 wstart))))
    6103           0 :         (setq py
    6104           0 :               (or (nth 1 this-lh)
    6105           0 :                   (let ((ppos (posn-at-point))
    6106             :                         col-row)
    6107           0 :                     (setq col-row (posn-actual-col-row ppos))
    6108           0 :                     (if col-row
    6109           0 :                         (- (cdr col-row) (window-vscroll))
    6110           0 :                       (cdr (posn-col-row ppos))))))
    6111             :         ;; VPOS > 0 means the last line is only partially visible.
    6112             :         ;; But if the part that is visible is at least as tall as the
    6113             :         ;; default font, that means the line is actually fully
    6114             :         ;; readable, and something like line-spacing is hidden.  So in
    6115             :         ;; that case we accept the last line in the window as still
    6116             :         ;; visible, and consider the margin as starting one line
    6117             :         ;; later.
    6118           0 :         (if (and vpos (> vpos 0))
    6119           0 :             (if (and rowh
    6120           0 :                      (>= rowh (default-font-height))
    6121           0 :                      (< rowh dlh))
    6122           0 :                 (setq last-line (min (- wslines scroll-margin) vpos))
    6123           0 :               (setq last-line (min (- wslines scroll-margin 1) (1- vpos)))))
    6124           0 :         (cond
    6125             :          ;; If last line of window is fully visible, and vscrolling
    6126             :          ;; more would make this line invisible, move forward.
    6127           0 :          ((and (or (< (setq vs (window-vscroll nil t)) dlh)
    6128           0 :                    (null this-height)
    6129           0 :                    (<= this-height dlh))
    6130           0 :                (or (null rbot) (= rbot 0)))
    6131             :           nil)
    6132             :          ;; If cursor is not in the bottom scroll margin, and the
    6133             :          ;; current line is is not too tall, move forward.
    6134           0 :          ((and (or (null this-height) (<= this-height winh))
    6135           0 :                vpos
    6136           0 :                (> vpos 0)
    6137           0 :                (< py last-line))
    6138             :           nil)
    6139             :          ;; When already vscrolled, we vscroll some more if we can,
    6140             :          ;; or clear vscroll and move forward at end of tall image.
    6141           0 :          ((> vs 0)
    6142           0 :           (when (or (and rbot (> rbot 0))
    6143           0 :                     (and this-height (> this-height dlh)))
    6144           0 :             (set-window-vscroll nil (+ vs dlh) t)))
    6145             :          ;; If cursor just entered the bottom scroll margin, move forward,
    6146             :          ;; but also optionally vscroll one line so redisplay won't recenter.
    6147           0 :          ((and vpos
    6148           0 :                (> vpos 0)
    6149           0 :                (= py last-line))
    6150             :           ;; Don't vscroll if the partially-visible line at window
    6151             :           ;; bottom is not too tall (a.k.a. "just one more text
    6152             :           ;; line"): in that case, we do want redisplay to behave
    6153             :           ;; normally, i.e. recenter or whatever.
    6154             :           ;;
    6155             :           ;; Note: ROWH + RBOT from the value returned by
    6156             :           ;; pos-visible-in-window-p give the total height of the
    6157             :           ;; partially-visible glyph row at the end of the window.  As
    6158             :           ;; we are dealing with floats, we disregard sub-pixel
    6159             :           ;; discrepancies between that and DLH.
    6160           0 :           (if (and rowh rbot (>= (- (+ rowh rbot) winh) 1))
    6161           0 :               (set-window-vscroll nil dlh t))
    6162           0 :           (line-move-1 arg noerror)
    6163             :           t)
    6164             :          ;; If there are lines above the last line, scroll-up one line.
    6165           0 :          ((and vpos (> vpos 0))
    6166           0 :           (scroll-up 1)
    6167             :           t)
    6168             :          ;; Finally, start vscroll.
    6169             :          (t
    6170           0 :           (set-window-vscroll nil dlh t)))))))
    6171             : 
    6172             : 
    6173             : ;; This is like line-move-1 except that it also performs
    6174             : ;; vertical scrolling of tall images if appropriate.
    6175             : ;; That is not really a clean thing to do, since it mixes
    6176             : ;; scrolling with cursor motion.  But so far we don't have
    6177             : ;; a cleaner solution to the problem of making C-n do something
    6178             : ;; useful given a tall image.
    6179             : (defun line-move (arg &optional noerror _to-end try-vscroll)
    6180             :   "Move forward ARG lines.
    6181             : If NOERROR, don't signal an error if we can't move ARG lines.
    6182             : TO-END is unused.
    6183             : TRY-VSCROLL controls whether to vscroll tall lines: if either
    6184             : `auto-window-vscroll' or TRY-VSCROLL is nil, this function will
    6185             : not vscroll."
    6186           0 :   (if noninteractive
    6187           0 :       (line-move-1 arg noerror)
    6188           0 :     (unless (and auto-window-vscroll try-vscroll
    6189             :                  ;; Only vscroll for single line moves
    6190           0 :                  (= (abs arg) 1)
    6191             :                  ;; Under scroll-conservatively, the display engine
    6192             :                  ;; does this better.
    6193           0 :                  (zerop scroll-conservatively)
    6194             :                  ;; But don't vscroll in a keyboard macro.
    6195           0 :                  (not defining-kbd-macro)
    6196           0 :                  (not executing-kbd-macro)
    6197           0 :                  (line-move-partial arg noerror))
    6198           0 :       (set-window-vscroll nil 0 t)
    6199           0 :       (if (and line-move-visual
    6200             :                ;; Display-based column are incompatible with goal-column.
    6201           0 :                (not goal-column)
    6202             :                ;; When the text in the window is scrolled to the left,
    6203             :                ;; display-based motion doesn't make sense (because each
    6204             :                ;; logical line occupies exactly one screen line).
    6205           0 :                (not (> (window-hscroll) 0))
    6206             :                ;; Likewise when the text _was_ scrolled to the left
    6207             :                ;; when the current run of vertical motion commands
    6208             :                ;; started.
    6209           0 :                (not (and (memq last-command
    6210           0 :                                `(next-line previous-line ,this-command))
    6211           0 :                          auto-hscroll-mode
    6212           0 :                          (numberp temporary-goal-column)
    6213           0 :                          (>= temporary-goal-column
    6214           0 :                             (- (window-width) hscroll-margin)))))
    6215           0 :           (prog1 (line-move-visual arg noerror)
    6216             :             ;; If we moved into a tall line, set vscroll to make
    6217             :             ;; scrolling through tall images more smooth.
    6218           0 :             (let ((lh (line-pixel-height))
    6219           0 :                   (edges (window-inside-pixel-edges))
    6220           0 :                   (dlh (default-line-height))
    6221             :                   winh)
    6222           0 :               (setq winh (- (nth 3 edges) (nth 1 edges) 1))
    6223           0 :               (if (and (< arg 0)
    6224           0 :                        (< (point) (window-start))
    6225           0 :                        (> lh winh))
    6226           0 :                   (set-window-vscroll
    6227             :                    nil
    6228           0 :                    (- lh dlh) t))))
    6229           0 :         (line-move-1 arg noerror)))))
    6230             : 
    6231             : ;; Display-based alternative to line-move-1.
    6232             : ;; Arg says how many lines to move.  The value is t if we can move the
    6233             : ;; specified number of lines.
    6234             : (defun line-move-visual (arg &optional noerror)
    6235             :   "Move ARG lines forward.
    6236             : If NOERROR, don't signal an error if we can't move that many lines."
    6237           0 :   (let ((opoint (point))
    6238           0 :         (hscroll (window-hscroll))
    6239           0 :         (lnum-width (line-number-display-width t))
    6240             :         target-hscroll)
    6241             :     ;; Check if the previous command was a line-motion command, or if
    6242             :     ;; we were called from some other command.
    6243           0 :     (if (and (consp temporary-goal-column)
    6244           0 :              (memq last-command `(next-line previous-line ,this-command)))
    6245             :         ;; If so, there's no need to reset `temporary-goal-column',
    6246             :         ;; but we may need to hscroll.
    6247           0 :         (progn
    6248           0 :           (if (or (/= (cdr temporary-goal-column) hscroll)
    6249           0 :                   (>  (cdr temporary-goal-column) 0))
    6250           0 :               (setq target-hscroll (cdr temporary-goal-column)))
    6251             :           ;; Update the COLUMN part of temporary-goal-column if the
    6252             :           ;; line-number display changed its width since the last
    6253             :           ;; time.
    6254           0 :           (setq temporary-goal-column
    6255           0 :                 (cons (+ (car temporary-goal-column)
    6256           0 :                          (/ (float (- lnum-width last--line-number-width))
    6257           0 :                             (frame-char-width)))
    6258           0 :                       (cdr temporary-goal-column)))
    6259           0 :           (setq last--line-number-width lnum-width))
    6260             :       ;; Otherwise, we should reset `temporary-goal-column'.
    6261           0 :       (let ((posn (posn-at-point))
    6262             :             x-pos)
    6263           0 :         (cond
    6264             :          ;; Handle the `overflow-newline-into-fringe' case
    6265             :          ;; (left-fringe is for the R2L case):
    6266           0 :          ((memq (nth 1 posn) '(right-fringe left-fringe))
    6267           0 :           (setq temporary-goal-column (cons (window-width) hscroll)))
    6268           0 :          ((car (posn-x-y posn))
    6269           0 :           (setq x-pos (car (posn-x-y posn)))
    6270             :           ;; In R2L lines, the X pixel coordinate is measured from the
    6271             :           ;; left edge of the window, but columns are still counted
    6272             :           ;; from the logical-order beginning of the line, i.e. from
    6273             :           ;; the right edge in this case.  We need to adjust for that.
    6274           0 :           (if (eq (current-bidi-paragraph-direction) 'right-to-left)
    6275           0 :               (setq x-pos (- (window-body-width nil t) 1 x-pos)))
    6276           0 :           (setq temporary-goal-column
    6277           0 :                 (cons (/ (float x-pos)
    6278           0 :                          (frame-char-width))
    6279           0 :                       hscroll)))
    6280           0 :          (executing-kbd-macro
    6281             :           ;; When we move beyond the first/last character visible in
    6282             :           ;; the window, posn-at-point will return nil, so we need to
    6283             :           ;; approximate the goal column as below.
    6284           0 :           (setq temporary-goal-column
    6285           0 :                 (mod (current-column) (window-text-width)))))))
    6286           0 :     (if target-hscroll
    6287           0 :         (set-window-hscroll (selected-window) target-hscroll))
    6288             :     ;; vertical-motion can move more than it was asked to if it moves
    6289             :     ;; across display strings with newlines.  We don't want to ring
    6290             :     ;; the bell and announce beginning/end of buffer in that case.
    6291           0 :     (or (and (or (and (>= arg 0)
    6292           0 :                       (>= (vertical-motion
    6293           0 :                            (cons (or goal-column
    6294           0 :                                      (if (consp temporary-goal-column)
    6295           0 :                                          (car temporary-goal-column)
    6296           0 :                                        temporary-goal-column))
    6297           0 :                                  arg))
    6298           0 :                           arg))
    6299           0 :                  (and (< arg 0)
    6300           0 :                       (<= (vertical-motion
    6301           0 :                            (cons (or goal-column
    6302           0 :                                      (if (consp temporary-goal-column)
    6303           0 :                                          (car temporary-goal-column)
    6304           0 :                                        temporary-goal-column))
    6305           0 :                                  arg))
    6306           0 :                           arg)))
    6307           0 :              (or (>= arg 0)
    6308           0 :                  (/= (point) opoint)
    6309             :                  ;; If the goal column lies on a display string,
    6310             :                  ;; `vertical-motion' advances the cursor to the end
    6311             :                  ;; of the string.  For arg < 0, this can cause the
    6312             :                  ;; cursor to get stuck.  (Bug#3020).
    6313           0 :                  (= (vertical-motion arg) arg)))
    6314           0 :         (unless noerror
    6315           0 :           (signal (if (< arg 0) 'beginning-of-buffer 'end-of-buffer)
    6316           0 :                   nil)))))
    6317             : 
    6318             : ;; This is the guts of next-line and previous-line.
    6319             : ;; Arg says how many lines to move.
    6320             : ;; The value is t if we can move the specified number of lines.
    6321             : (defun line-move-1 (arg &optional noerror _to-end)
    6322             :   ;; Don't run any point-motion hooks, and disregard intangibility,
    6323             :   ;; for intermediate positions.
    6324           0 :   (let ((inhibit-point-motion-hooks t)
    6325           0 :         (opoint (point))
    6326           0 :         (orig-arg arg))
    6327           0 :     (if (consp temporary-goal-column)
    6328           0 :         (setq temporary-goal-column (+ (car temporary-goal-column)
    6329           0 :                                        (cdr temporary-goal-column))))
    6330           0 :     (unwind-protect
    6331           0 :         (progn
    6332           0 :           (if (not (memq last-command '(next-line previous-line)))
    6333           0 :               (setq temporary-goal-column
    6334           0 :                     (if (and track-eol (eolp)
    6335             :                              ;; Don't count beg of empty line as end of line
    6336             :                              ;; unless we just did explicit end-of-line.
    6337           0 :                              (or (not (bolp)) (eq last-command 'move-end-of-line)))
    6338           0 :                         most-positive-fixnum
    6339           0 :                       (current-column))))
    6340             : 
    6341           0 :           (if (not (or (integerp selective-display)
    6342           0 :                        line-move-ignore-invisible))
    6343             :               ;; Use just newline characters.
    6344             :               ;; Set ARG to 0 if we move as many lines as requested.
    6345           0 :               (or (if (> arg 0)
    6346           0 :                       (progn (if (> arg 1) (forward-line (1- arg)))
    6347             :                              ;; This way of moving forward ARG lines
    6348             :                              ;; verifies that we have a newline after the last one.
    6349             :                              ;; It doesn't get confused by intangible text.
    6350           0 :                              (end-of-line)
    6351           0 :                              (if (zerop (forward-line 1))
    6352           0 :                                  (setq arg 0)))
    6353           0 :                     (and (zerop (forward-line arg))
    6354           0 :                          (bolp)
    6355           0 :                          (setq arg 0)))
    6356           0 :                   (unless noerror
    6357           0 :                     (signal (if (< arg 0)
    6358             :                                 'beginning-of-buffer
    6359           0 :                               'end-of-buffer)
    6360           0 :                             nil)))
    6361             :             ;; Move by arg lines, but ignore invisible ones.
    6362           0 :             (let (done)
    6363           0 :               (while (and (> arg 0) (not done))
    6364             :                 ;; If the following character is currently invisible,
    6365             :                 ;; skip all characters with that same `invisible' property value.
    6366           0 :                 (while (and (not (eobp)) (invisible-p (point)))
    6367           0 :                   (goto-char (next-char-property-change (point))))
    6368             :                 ;; Move a line.
    6369             :                 ;; We don't use `end-of-line', since we want to escape
    6370             :                 ;; from field boundaries occurring exactly at point.
    6371           0 :                 (goto-char (constrain-to-field
    6372           0 :                             (let ((inhibit-field-text-motion t))
    6373           0 :                               (line-end-position))
    6374           0 :                             (point) t t
    6375           0 :                             'inhibit-line-move-field-capture))
    6376             :                 ;; If there's no invisibility here, move over the newline.
    6377           0 :                 (cond
    6378           0 :                  ((eobp)
    6379           0 :                   (if (not noerror)
    6380           0 :                       (signal 'end-of-buffer nil)
    6381           0 :                     (setq done t)))
    6382           0 :                  ((and (> arg 1)  ;; Use vertical-motion for last move
    6383           0 :                        (not (integerp selective-display))
    6384           0 :                        (not (invisible-p (point))))
    6385             :                   ;; We avoid vertical-motion when possible
    6386             :                   ;; because that has to fontify.
    6387           0 :                   (forward-line 1))
    6388             :                  ;; Otherwise move a more sophisticated way.
    6389           0 :                  ((zerop (vertical-motion 1))
    6390           0 :                   (if (not noerror)
    6391           0 :                       (signal 'end-of-buffer nil)
    6392           0 :                     (setq done t))))
    6393           0 :                 (unless done
    6394           0 :                   (setq arg (1- arg))))
    6395             :               ;; The logic of this is the same as the loop above,
    6396             :               ;; it just goes in the other direction.
    6397           0 :               (while (and (< arg 0) (not done))
    6398             :                 ;; For completely consistency with the forward-motion
    6399             :                 ;; case, we should call beginning-of-line here.
    6400             :                 ;; However, if point is inside a field and on a
    6401             :                 ;; continued line, the call to (vertical-motion -1)
    6402             :                 ;; below won't move us back far enough; then we return
    6403             :                 ;; to the same column in line-move-finish, and point
    6404             :                 ;; gets stuck -- cyd
    6405           0 :                 (forward-line 0)
    6406           0 :                 (cond
    6407           0 :                  ((bobp)
    6408           0 :                   (if (not noerror)
    6409           0 :                       (signal 'beginning-of-buffer nil)
    6410           0 :                     (setq done t)))
    6411           0 :                  ((and (< arg -1) ;; Use vertical-motion for last move
    6412           0 :                        (not (integerp selective-display))
    6413           0 :                        (not (invisible-p (1- (point)))))
    6414           0 :                   (forward-line -1))
    6415           0 :                  ((zerop (vertical-motion -1))
    6416           0 :                   (if (not noerror)
    6417           0 :                       (signal 'beginning-of-buffer nil)
    6418           0 :                     (setq done t))))
    6419           0 :                 (unless done
    6420           0 :                   (setq arg (1+ arg))
    6421           0 :                   (while (and ;; Don't move over previous invis lines
    6422             :                           ;; if our target is the middle of this line.
    6423           0 :                           (or (zerop (or goal-column temporary-goal-column))
    6424           0 :                               (< arg 0))
    6425           0 :                           (not (bobp)) (invisible-p (1- (point))))
    6426           0 :                     (goto-char (previous-char-property-change (point))))))))
    6427             :           ;; This is the value the function returns.
    6428           0 :           (= arg 0))
    6429             : 
    6430           0 :       (cond ((> arg 0)
    6431             :              ;; If we did not move down as far as desired, at least go
    6432             :              ;; to end of line.  Be sure to call point-entered and
    6433             :              ;; point-left-hooks.
    6434           0 :              (let* ((npoint (prog1 (line-end-position)
    6435           0 :                               (goto-char opoint)))
    6436             :                     (inhibit-point-motion-hooks nil))
    6437           0 :                (goto-char npoint)))
    6438           0 :             ((< arg 0)
    6439             :              ;; If we did not move up as far as desired,
    6440             :              ;; at least go to beginning of line.
    6441           0 :              (let* ((npoint (prog1 (line-beginning-position)
    6442           0 :                               (goto-char opoint)))
    6443             :                     (inhibit-point-motion-hooks nil))
    6444           0 :                (goto-char npoint)))
    6445             :             (t
    6446           0 :              (line-move-finish (or goal-column temporary-goal-column)
    6447           0 :                                opoint (> orig-arg 0)))))))
    6448             : 
    6449             : (defun line-move-finish (column opoint forward)
    6450           0 :   (let ((repeat t))
    6451           0 :     (while repeat
    6452             :       ;; Set REPEAT to t to repeat the whole thing.
    6453           0 :       (setq repeat nil)
    6454             : 
    6455           0 :       (let (new
    6456           0 :             (old (point))
    6457           0 :             (line-beg (line-beginning-position))
    6458             :             (line-end
    6459             :              ;; Compute the end of the line
    6460             :              ;; ignoring effectively invisible newlines.
    6461           0 :              (save-excursion
    6462             :                ;; Like end-of-line but ignores fields.
    6463           0 :                (skip-chars-forward "^\n")
    6464           0 :                (while (and (not (eobp)) (invisible-p (point)))
    6465           0 :                  (goto-char (next-char-property-change (point)))
    6466           0 :                  (skip-chars-forward "^\n"))
    6467           0 :                (point))))
    6468             : 
    6469             :         ;; Move to the desired column.
    6470           0 :         (if (and line-move-visual
    6471           0 :                  (not (or truncate-lines truncate-partial-width-windows)))
    6472             :             ;; Under line-move-visual, goal-column should be
    6473             :             ;; interpreted in units of the frame's canonical character
    6474             :             ;; width, which is exactly what vertical-motion does.
    6475           0 :             (vertical-motion (cons column 0))
    6476           0 :           (line-move-to-column (truncate column)))
    6477             : 
    6478             :         ;; Corner case: suppose we start out in a field boundary in
    6479             :         ;; the middle of a continued line.  When we get to
    6480             :         ;; line-move-finish, point is at the start of a new *screen*
    6481             :         ;; line but the same text line; then line-move-to-column would
    6482             :         ;; move us backwards.  Test using C-n with point on the "x" in
    6483             :         ;;   (insert "a" (propertize "x" 'field t) (make-string 89 ?y))
    6484           0 :         (and forward
    6485           0 :              (< (point) old)
    6486           0 :              (goto-char old))
    6487             : 
    6488           0 :         (setq new (point))
    6489             : 
    6490             :         ;; Process intangibility within a line.
    6491             :         ;; With inhibit-point-motion-hooks bound to nil, a call to
    6492             :         ;; goto-char moves point past intangible text.
    6493             : 
    6494             :         ;; However, inhibit-point-motion-hooks controls both the
    6495             :         ;; intangibility and the point-entered/point-left hooks.  The
    6496             :         ;; following hack avoids calling the point-* hooks
    6497             :         ;; unnecessarily.  Note that we move *forward* past intangible
    6498             :         ;; text when the initial and final points are the same.
    6499           0 :         (goto-char new)
    6500           0 :         (let ((inhibit-point-motion-hooks nil))
    6501           0 :           (goto-char new)
    6502             : 
    6503             :           ;; If intangibility moves us to a different (later) place
    6504             :           ;; in the same line, use that as the destination.
    6505           0 :           (if (<= (point) line-end)
    6506           0 :               (setq new (point))
    6507             :             ;; If that position is "too late",
    6508             :             ;; try the previous allowable position.
    6509             :             ;; See if it is ok.
    6510           0 :             (backward-char)
    6511           0 :             (if (if forward
    6512             :                     ;; If going forward, don't accept the previous
    6513             :                     ;; allowable position if it is before the target line.
    6514           0 :                     (< line-beg (point))
    6515             :                   ;; If going backward, don't accept the previous
    6516             :                   ;; allowable position if it is still after the target line.
    6517           0 :                   (<= (point) line-end))
    6518           0 :                 (setq new (point))
    6519             :               ;; As a last resort, use the end of the line.
    6520           0 :               (setq new line-end))))
    6521             : 
    6522             :         ;; Now move to the updated destination, processing fields
    6523             :         ;; as well as intangibility.
    6524           0 :         (goto-char opoint)
    6525           0 :         (let ((inhibit-point-motion-hooks nil))
    6526           0 :           (goto-char
    6527             :            ;; Ignore field boundaries if the initial and final
    6528             :            ;; positions have the same `field' property, even if the
    6529             :            ;; fields are non-contiguous.  This seems to be "nicer"
    6530             :            ;; behavior in many situations.
    6531           0 :            (if (eq (get-char-property new 'field)
    6532           0 :                    (get-char-property opoint 'field))
    6533           0 :                new
    6534           0 :              (constrain-to-field new opoint t t
    6535           0 :                                  'inhibit-line-move-field-capture))))
    6536             : 
    6537             :         ;; If all this moved us to a different line,
    6538             :         ;; retry everything within that new line.
    6539           0 :         (when (or (< (point) line-beg) (> (point) line-end))
    6540             :           ;; Repeat the intangibility and field processing.
    6541           0 :           (setq repeat t))))))
    6542             : 
    6543             : (defun line-move-to-column (col)
    6544             :   "Try to find column COL, considering invisibility.
    6545             : This function works only in certain cases,
    6546             : because what we really need is for `move-to-column'
    6547             : and `current-column' to be able to ignore invisible text."
    6548           0 :   (if (zerop col)
    6549           0 :       (beginning-of-line)
    6550           0 :     (move-to-column col))
    6551             : 
    6552           0 :   (when (and line-move-ignore-invisible
    6553           0 :              (not (bolp)) (invisible-p (1- (point))))
    6554           0 :     (let ((normal-location (point))
    6555           0 :           (normal-column (current-column)))
    6556             :       ;; If the following character is currently invisible,
    6557             :       ;; skip all characters with that same `invisible' property value.
    6558           0 :       (while (and (not (eobp))
    6559           0 :                   (invisible-p (point)))
    6560           0 :         (goto-char (next-char-property-change (point))))
    6561             :       ;; Have we advanced to a larger column position?
    6562           0 :       (if (> (current-column) normal-column)
    6563             :           ;; We have made some progress towards the desired column.
    6564             :           ;; See if we can make any further progress.
    6565           0 :           (line-move-to-column (+ (current-column) (- col normal-column)))
    6566             :         ;; Otherwise, go to the place we originally found
    6567             :         ;; and move back over invisible text.
    6568             :         ;; that will get us to the same place on the screen
    6569             :         ;; but with a more reasonable buffer position.
    6570           0 :         (goto-char normal-location)
    6571           0 :         (let ((line-beg
    6572             :                ;; We want the real line beginning, so it's consistent
    6573             :                ;; with bolp below, otherwise we might infloop.
    6574           0 :                (let ((inhibit-field-text-motion t))
    6575           0 :                  (line-beginning-position))))
    6576           0 :           (while (and (not (bolp)) (invisible-p (1- (point))))
    6577           0 :             (goto-char (previous-char-property-change (point) line-beg))))))))
    6578             : 
    6579             : (defun move-end-of-line (arg)
    6580             :   "Move point to end of current line as displayed.
    6581             : With argument ARG not nil or 1, move forward ARG - 1 lines first.
    6582             : If point reaches the beginning or end of buffer, it stops there.
    6583             : 
    6584             : To ignore the effects of the `intangible' text or overlay
    6585             : property, bind `inhibit-point-motion-hooks' to t.
    6586             : If there is an image in the current line, this function
    6587             : disregards newlines that are part of the text on which the image
    6588             : rests."
    6589             :   (interactive "^p")
    6590           0 :   (or arg (setq arg 1))
    6591           0 :   (let (done)
    6592           0 :     (while (not done)
    6593           0 :       (let ((newpos
    6594           0 :              (save-excursion
    6595           0 :                (let ((goal-column 0)
    6596             :                      (line-move-visual nil))
    6597           0 :                  (and (line-move arg t)
    6598             :                       ;; With bidi reordering, we may not be at bol,
    6599             :                       ;; so make sure we are.
    6600           0 :                       (skip-chars-backward "^\n")
    6601           0 :                       (not (bobp))
    6602           0 :                       (progn
    6603           0 :                         (while (and (not (bobp)) (invisible-p (1- (point))))
    6604           0 :                           (goto-char (previous-single-char-property-change
    6605           0 :                                       (point) 'invisible)))
    6606           0 :                         (backward-char 1)))
    6607           0 :                  (point)))))
    6608           0 :         (goto-char newpos)
    6609           0 :         (if (and (> (point) newpos)
    6610           0 :                  (eq (preceding-char) ?\n))
    6611           0 :             (backward-char 1)
    6612           0 :           (if (and (> (point) newpos) (not (eobp))
    6613           0 :                    (not (eq (following-char) ?\n)))
    6614             :               ;; If we skipped something intangible and now we're not
    6615             :               ;; really at eol, keep going.
    6616           0 :               (setq arg 1)
    6617           0 :             (setq done t)))))))
    6618             : 
    6619             : (defun move-beginning-of-line (arg)
    6620             :   "Move point to beginning of current line as displayed.
    6621             : \(If there's an image in the line, this disregards newlines
    6622             : which are part of the text that the image rests on.)
    6623             : 
    6624             : With argument ARG not nil or 1, move forward ARG - 1 lines first.
    6625             : If point reaches the beginning or end of buffer, it stops there.
    6626             : \(But if the buffer doesn't end in a newline, it stops at the
    6627             : beginning of the last line.)
    6628             : To ignore intangibility, bind `inhibit-point-motion-hooks' to t."
    6629             :   (interactive "^p")
    6630           0 :   (or arg (setq arg 1))
    6631             : 
    6632           0 :   (let ((orig (point))
    6633             :         first-vis first-vis-field-value)
    6634             : 
    6635             :     ;; Move by lines, if ARG is not 1 (the default).
    6636           0 :     (if (/= arg 1)
    6637           0 :         (let ((line-move-visual nil))
    6638           0 :           (line-move (1- arg) t)))
    6639             : 
    6640             :     ;; Move to beginning-of-line, ignoring fields and invisible text.
    6641           0 :     (skip-chars-backward "^\n")
    6642           0 :     (while (and (not (bobp)) (invisible-p (1- (point))))
    6643           0 :       (goto-char (previous-char-property-change (point)))
    6644           0 :       (skip-chars-backward "^\n"))
    6645             : 
    6646             :     ;; Now find first visible char in the line.
    6647           0 :     (while (and (< (point) orig) (invisible-p (point)))
    6648           0 :       (goto-char (next-char-property-change (point) orig)))
    6649           0 :     (setq first-vis (point))
    6650             : 
    6651             :     ;; See if fields would stop us from reaching FIRST-VIS.
    6652           0 :     (setq first-vis-field-value
    6653           0 :           (constrain-to-field first-vis orig (/= arg 1) t nil))
    6654             : 
    6655           0 :     (goto-char (if (/= first-vis-field-value first-vis)
    6656             :                    ;; If yes, obey them.
    6657           0 :                    first-vis-field-value
    6658             :                  ;; Otherwise, move to START with attention to fields.
    6659             :                  ;; (It is possible that fields never matter in this case.)
    6660           0 :                  (constrain-to-field (point) orig
    6661           0 :                                      (/= arg 1) t nil)))))
    6662             : 
    6663             : 
    6664             : ;; Many people have said they rarely use this feature, and often type
    6665             : ;; it by accident.  Maybe it shouldn't even be on a key.
    6666             : (put 'set-goal-column 'disabled t)
    6667             : 
    6668             : (defun set-goal-column (arg)
    6669             :   "Set the current horizontal position as a goal for \\[next-line] and \\[previous-line].
    6670             : Those commands will move to this position in the line moved to
    6671             : rather than trying to keep the same horizontal position.
    6672             : With a non-nil argument ARG, clears out the goal column
    6673             : so that \\[next-line] and \\[previous-line] resume vertical motion.
    6674             : The goal column is stored in the variable `goal-column'.
    6675             : This is a buffer-local setting."
    6676             :   (interactive "P")
    6677           0 :   (if arg
    6678           0 :       (progn
    6679           0 :         (setq goal-column nil)
    6680           0 :         (message "No goal column"))
    6681           0 :     (setq goal-column (current-column))
    6682             :     ;; The older method below can be erroneous if `set-goal-column' is bound
    6683             :     ;; to a sequence containing %
    6684             :     ;;(message (substitute-command-keys
    6685             :     ;;"Goal column %d (use \\[set-goal-column] with an arg to unset it)")
    6686             :     ;;goal-column)
    6687           0 :     (message "%s"
    6688           0 :              (concat
    6689           0 :               (format "Goal column %d " goal-column)
    6690           0 :               (substitute-command-keys
    6691           0 :                "(use \\[set-goal-column] with an arg to unset it)")))
    6692             : 
    6693           0 :     )
    6694             :   nil)
    6695             : 
    6696             : ;;; Editing based on visual lines, as opposed to logical lines.
    6697             : 
    6698             : (defun end-of-visual-line (&optional n)
    6699             :   "Move point to end of current visual line.
    6700             : With argument N not nil or 1, move forward N - 1 visual lines first.
    6701             : If point reaches the beginning or end of buffer, it stops there.
    6702             : To ignore intangibility, bind `inhibit-point-motion-hooks' to t."
    6703             :   (interactive "^p")
    6704           0 :   (or n (setq n 1))
    6705           0 :   (if (/= n 1)
    6706           0 :       (let ((line-move-visual t))
    6707           0 :         (line-move (1- n) t)))
    6708             :   ;; Unlike `move-beginning-of-line', `move-end-of-line' doesn't
    6709             :   ;; constrain to field boundaries, so we don't either.
    6710           0 :   (vertical-motion (cons (window-width) 0)))
    6711             : 
    6712             : (defun beginning-of-visual-line (&optional n)
    6713             :   "Move point to beginning of current visual line.
    6714             : With argument N not nil or 1, move forward N - 1 visual lines first.
    6715             : If point reaches the beginning or end of buffer, it stops there.
    6716             : \(But if the buffer doesn't end in a newline, it stops at the
    6717             : beginning of the last visual line.)
    6718             : To ignore intangibility, bind `inhibit-point-motion-hooks' to t."
    6719             :   (interactive "^p")
    6720           0 :   (or n (setq n 1))
    6721           0 :   (let ((opoint (point)))
    6722           0 :     (if (/= n 1)
    6723           0 :         (let ((line-move-visual t))
    6724           0 :           (line-move (1- n) t)))
    6725           0 :     (vertical-motion 0)
    6726             :     ;; Constrain to field boundaries, like `move-beginning-of-line'.
    6727           0 :     (goto-char (constrain-to-field (point) opoint (/= n 1)))))
    6728             : 
    6729             : (defun kill-visual-line (&optional arg)
    6730             :   "Kill the rest of the visual line.
    6731             : With prefix argument ARG, kill that many visual lines from point.
    6732             : If ARG is negative, kill visual lines backward.
    6733             : If ARG is zero, kill the text before point on the current visual
    6734             : line.
    6735             : 
    6736             : If you want to append the killed line to the last killed text,
    6737             : use \\[append-next-kill] before \\[kill-line].
    6738             : 
    6739             : If the buffer is read-only, Emacs will beep and refrain from deleting
    6740             : the line, but put the line in the kill ring anyway.  This means that
    6741             : you can use this command to copy text from a read-only buffer.
    6742             : \(If the variable `kill-read-only-ok' is non-nil, then this won't
    6743             : even beep.)"
    6744             :   (interactive "P")
    6745             :   ;; Like in `kill-line', it's better to move point to the other end
    6746             :   ;; of the kill before killing.
    6747           0 :   (let ((opoint (point))
    6748           0 :         (kill-whole-line (and kill-whole-line (bolp))))
    6749           0 :     (if arg
    6750           0 :         (vertical-motion (prefix-numeric-value arg))
    6751           0 :       (end-of-visual-line 1)
    6752           0 :       (if (= (point) opoint)
    6753           0 :           (vertical-motion 1)
    6754             :         ;; Skip any trailing whitespace at the end of the visual line.
    6755             :         ;; We used to do this only if `show-trailing-whitespace' is
    6756             :         ;; nil, but that's wrong; the correct thing would be to check
    6757             :         ;; whether the trailing whitespace is highlighted.  But, it's
    6758             :         ;; OK to just do this unconditionally.
    6759           0 :         (skip-chars-forward " \t")))
    6760           0 :     (kill-region opoint (if (and kill-whole-line (= (following-char) ?\n))
    6761           0 :                             (1+ (point))
    6762           0 :                           (point)))))
    6763             : 
    6764             : (defun next-logical-line (&optional arg try-vscroll)
    6765             :   "Move cursor vertically down ARG lines.
    6766             : This is identical to `next-line', except that it always moves
    6767             : by logical lines instead of visual lines, ignoring the value of
    6768             : the variable `line-move-visual'."
    6769             :   (interactive "^p\np")
    6770           0 :   (let ((line-move-visual nil))
    6771           0 :     (with-no-warnings
    6772           0 :       (next-line arg try-vscroll))))
    6773             : 
    6774             : (defun previous-logical-line (&optional arg try-vscroll)
    6775             :   "Move cursor vertically up ARG lines.
    6776             : This is identical to `previous-line', except that it always moves
    6777             : by logical lines instead of visual lines, ignoring the value of
    6778             : the variable `line-move-visual'."
    6779             :   (interactive "^p\np")
    6780           0 :   (let ((line-move-visual nil))
    6781           0 :     (with-no-warnings
    6782           0 :       (previous-line arg try-vscroll))))
    6783             : 
    6784             : (defgroup visual-line nil
    6785             :   "Editing based on visual lines."
    6786             :   :group 'convenience
    6787             :   :version "23.1")
    6788             : 
    6789             : (defvar visual-line-mode-map
    6790             :   (let ((map (make-sparse-keymap)))
    6791             :     (define-key map [remap kill-line] 'kill-visual-line)
    6792             :     (define-key map [remap move-beginning-of-line] 'beginning-of-visual-line)
    6793             :     (define-key map [remap move-end-of-line]  'end-of-visual-line)
    6794             :     ;; These keybindings interfere with xterm function keys.  Are
    6795             :     ;; there any other suitable bindings?
    6796             :     ;; (define-key map "\M-[" 'previous-logical-line)
    6797             :     ;; (define-key map "\M-]" 'next-logical-line)
    6798             :     map))
    6799             : 
    6800             : (defcustom visual-line-fringe-indicators '(nil nil)
    6801             :   "How fringe indicators are shown for wrapped lines in `visual-line-mode'.
    6802             : The value should be a list of the form (LEFT RIGHT), where LEFT
    6803             : and RIGHT are symbols representing the bitmaps to display, to
    6804             : indicate wrapped lines, in the left and right fringes respectively.
    6805             : See also `fringe-indicator-alist'.
    6806             : The default is not to display fringe indicators for wrapped lines.
    6807             : This variable does not affect fringe indicators displayed for
    6808             : other purposes."
    6809             :   :type '(list (choice (const :tag "Hide left indicator" nil)
    6810             :                        (const :tag "Left curly arrow" left-curly-arrow)
    6811             :                        (symbol :tag "Other bitmap"))
    6812             :                (choice (const :tag "Hide right indicator" nil)
    6813             :                        (const :tag "Right curly arrow" right-curly-arrow)
    6814             :                        (symbol :tag "Other bitmap")))
    6815             :   :set (lambda (symbol value)
    6816             :          (dolist (buf (buffer-list))
    6817             :            (with-current-buffer buf
    6818             :              (when (and (boundp 'visual-line-mode)
    6819             :                         (symbol-value 'visual-line-mode))
    6820             :                (setq fringe-indicator-alist
    6821             :                      (cons (cons 'continuation value)
    6822             :                            (assq-delete-all
    6823             :                             'continuation
    6824             :                             (copy-tree fringe-indicator-alist)))))))
    6825             :          (set-default symbol value)))
    6826             : 
    6827             : (defvar visual-line--saved-state nil)
    6828             : 
    6829             : (define-minor-mode visual-line-mode
    6830             :   "Toggle visual line based editing (Visual Line mode).
    6831             : With a prefix argument ARG, enable Visual Line mode if ARG is
    6832             : positive, and disable it otherwise.  If called from Lisp, enable
    6833             : the mode if ARG is omitted or nil.
    6834             : 
    6835             : When Visual Line mode is enabled, `word-wrap' is turned on in
    6836             : this buffer, and simple editing commands are redefined to act on
    6837             : visual lines, not logical lines.  See Info node `Visual Line
    6838             : Mode' for details."
    6839             :   :keymap visual-line-mode-map
    6840             :   :group 'visual-line
    6841             :   :lighter " Wrap"
    6842           0 :   (if visual-line-mode
    6843           0 :       (progn
    6844           0 :         (set (make-local-variable 'visual-line--saved-state) nil)
    6845             :         ;; Save the local values of some variables, to be restored if
    6846             :         ;; visual-line-mode is turned off.
    6847           0 :         (dolist (var '(line-move-visual truncate-lines
    6848             :                        truncate-partial-width-windows
    6849             :                        word-wrap fringe-indicator-alist))
    6850           0 :           (if (local-variable-p var)
    6851           0 :               (push (cons var (symbol-value var))
    6852           0 :                     visual-line--saved-state)))
    6853           0 :         (set (make-local-variable 'line-move-visual) t)
    6854           0 :         (set (make-local-variable 'truncate-partial-width-windows) nil)
    6855           0 :         (setq truncate-lines nil
    6856             :               word-wrap t
    6857             :               fringe-indicator-alist
    6858           0 :               (cons (cons 'continuation visual-line-fringe-indicators)
    6859           0 :                     fringe-indicator-alist)))
    6860           0 :     (kill-local-variable 'line-move-visual)
    6861           0 :     (kill-local-variable 'word-wrap)
    6862           0 :     (kill-local-variable 'truncate-lines)
    6863           0 :     (kill-local-variable 'truncate-partial-width-windows)
    6864           0 :     (kill-local-variable 'fringe-indicator-alist)
    6865           0 :     (dolist (saved visual-line--saved-state)
    6866           0 :       (set (make-local-variable (car saved)) (cdr saved)))
    6867           0 :     (kill-local-variable 'visual-line--saved-state)))
    6868             : 
    6869             : (defun turn-on-visual-line-mode ()
    6870           0 :   (visual-line-mode 1))
    6871             : 
    6872             : (define-globalized-minor-mode global-visual-line-mode
    6873             :   visual-line-mode turn-on-visual-line-mode)
    6874             : 
    6875             : 
    6876             : (defun transpose-chars (arg)
    6877             :   "Interchange characters around point, moving forward one character.
    6878             : With prefix arg ARG, effect is to take character before point
    6879             : and drag it forward past ARG other characters (backward if ARG negative).
    6880             : If no argument and at end of line, the previous two chars are exchanged."
    6881             :   (interactive "*P")
    6882           0 :   (when (and (null arg) (eolp) (not (bobp))
    6883           0 :              (not (get-text-property (1- (point)) 'read-only)))
    6884           0 :     (forward-char -1))
    6885           0 :   (transpose-subr 'forward-char (prefix-numeric-value arg)))
    6886             : 
    6887             : (defun transpose-words (arg)
    6888             :   "Interchange words around point, leaving point at end of them.
    6889             : With prefix arg ARG, effect is to take word before or around point
    6890             : and drag it forward past ARG other words (backward if ARG negative).
    6891             : If ARG is zero, the words around or after point and around or after mark
    6892             : are interchanged."
    6893             :   ;; FIXME: `foo a!nd bar' should transpose into `bar and foo'.
    6894             :   (interactive "*p")
    6895           0 :   (transpose-subr 'forward-word arg))
    6896             : 
    6897             : (defun transpose-sexps (arg)
    6898             :   "Like \\[transpose-chars] (`transpose-chars'), but applies to sexps.
    6899             : Unlike `transpose-words', point must be between the two sexps and not
    6900             : in the middle of a sexp to be transposed.
    6901             : With non-zero prefix arg ARG, effect is to take the sexp before point
    6902             : and drag it forward past ARG other sexps (backward if ARG is negative).
    6903             : If ARG is zero, the sexps ending at or after point and at or after mark
    6904             : are interchanged."
    6905             :   (interactive "*p")
    6906           0 :   (transpose-subr
    6907             :    (lambda (arg)
    6908             :      ;; Here we should try to simulate the behavior of
    6909             :      ;; (cons (progn (forward-sexp x) (point))
    6910             :      ;;       (progn (forward-sexp (- x)) (point)))
    6911             :      ;; Except that we don't want to rely on the second forward-sexp
    6912             :      ;; putting us back to where we want to be, since forward-sexp-function
    6913             :      ;; might do funny things like infix-precedence.
    6914           0 :      (if (if (> arg 0)
    6915           0 :              (looking-at "\\sw\\|\\s_")
    6916           0 :            (and (not (bobp))
    6917           0 :                 (save-excursion (forward-char -1) (looking-at "\\sw\\|\\s_"))))
    6918             :          ;; Jumping over a symbol.  We might be inside it, mind you.
    6919           0 :          (progn (funcall (if (> arg 0)
    6920           0 :                              'skip-syntax-backward 'skip-syntax-forward)
    6921           0 :                          "w_")
    6922           0 :                 (cons (save-excursion (forward-sexp arg) (point)) (point)))
    6923             :        ;; Otherwise, we're between sexps.  Take a step back before jumping
    6924             :        ;; to make sure we'll obey the same precedence no matter which direction
    6925             :        ;; we're going.
    6926           0 :        (funcall (if (> arg 0) 'skip-syntax-backward 'skip-syntax-forward) " .")
    6927           0 :        (cons (save-excursion (forward-sexp arg) (point))
    6928           0 :              (progn (while (or (forward-comment (if (> arg 0) 1 -1))
    6929           0 :                                (not (zerop (funcall (if (> arg 0)
    6930             :                                                         'skip-syntax-forward
    6931           0 :                                                       'skip-syntax-backward)
    6932           0 :                                                     ".")))))
    6933           0 :                     (point)))))
    6934           0 :    arg 'special))
    6935             : 
    6936             : (defun transpose-lines (arg)
    6937             :   "Exchange current line and previous line, leaving point after both.
    6938             : With argument ARG, takes previous line and moves it past ARG lines.
    6939             : With argument 0, interchanges line point is in with line mark is in."
    6940             :   (interactive "*p")
    6941           0 :   (transpose-subr (function
    6942             :                    (lambda (arg)
    6943           0 :                      (if (> arg 0)
    6944           0 :                          (progn
    6945             :                            ;; Move forward over ARG lines,
    6946             :                            ;; but create newlines if necessary.
    6947           0 :                            (setq arg (forward-line arg))
    6948           0 :                            (if (/= (preceding-char) ?\n)
    6949           0 :                                (setq arg (1+ arg)))
    6950           0 :                            (if (> arg 0)
    6951           0 :                                (newline arg)))
    6952           0 :                        (forward-line arg))))
    6953           0 :                   arg))
    6954             : 
    6955             : ;; FIXME seems to leave point BEFORE the current object when ARG = 0,
    6956             : ;; which seems inconsistent with the ARG /= 0 case.
    6957             : ;; FIXME document SPECIAL.
    6958             : (defun transpose-subr (mover arg &optional special)
    6959             :   "Subroutine to do the work of transposing objects.
    6960             : Works for lines, sentences, paragraphs, etc.  MOVER is a function that
    6961             : moves forward by units of the given object (e.g. forward-sentence,
    6962             : forward-paragraph).  If ARG is zero, exchanges the current object
    6963             : with the one containing mark.  If ARG is an integer, moves the
    6964             : current object past ARG following (if ARG is positive) or
    6965             : preceding (if ARG is negative) objects, leaving point after the
    6966             : current object."
    6967           0 :   (let ((aux (if special mover
    6968             :                (lambda (x)
    6969           0 :                  (cons (progn (funcall mover x) (point))
    6970           0 :                        (progn (funcall mover (- x)) (point))))))
    6971             :         pos1 pos2)
    6972           0 :     (cond
    6973           0 :      ((= arg 0)
    6974           0 :       (save-excursion
    6975           0 :         (setq pos1 (funcall aux 1))
    6976           0 :         (goto-char (or (mark) (error "No mark set in this buffer")))
    6977           0 :         (setq pos2 (funcall aux 1))
    6978           0 :         (transpose-subr-1 pos1 pos2))
    6979           0 :       (exchange-point-and-mark))
    6980           0 :      ((> arg 0)
    6981           0 :       (setq pos1 (funcall aux -1))
    6982           0 :       (setq pos2 (funcall aux arg))
    6983           0 :       (transpose-subr-1 pos1 pos2)
    6984           0 :       (goto-char (car pos2)))
    6985             :      (t
    6986           0 :       (setq pos1 (funcall aux -1))
    6987           0 :       (goto-char (car pos1))
    6988           0 :       (setq pos2 (funcall aux arg))
    6989           0 :       (transpose-subr-1 pos1 pos2)
    6990           0 :       (goto-char (+ (car pos2) (- (cdr pos1) (car pos1))))))))
    6991             : 
    6992             : (defun transpose-subr-1 (pos1 pos2)
    6993           0 :   (when (> (car pos1) (cdr pos1)) (setq pos1 (cons (cdr pos1) (car pos1))))
    6994           0 :   (when (> (car pos2) (cdr pos2)) (setq pos2 (cons (cdr pos2) (car pos2))))
    6995           0 :   (when (> (car pos1) (car pos2))
    6996           0 :     (let ((swap pos1))
    6997           0 :       (setq pos1 pos2 pos2 swap)))
    6998           0 :   (if (> (cdr pos1) (car pos2)) (error "Don't have two things to transpose"))
    6999           0 :   (atomic-change-group
    7000             :     ;; This sequence of insertions attempts to preserve marker
    7001             :     ;; positions at the start and end of the transposed objects.
    7002           0 :     (let* ((word (buffer-substring (car pos2) (cdr pos2)))
    7003           0 :            (len1 (- (cdr pos1) (car pos1)))
    7004           0 :            (len2 (length word))
    7005           0 :            (boundary (make-marker)))
    7006           0 :       (set-marker boundary (car pos2))
    7007           0 :       (goto-char (cdr pos1))
    7008           0 :       (insert-before-markers word)
    7009           0 :       (setq word (delete-and-extract-region (car pos1) (+ (car pos1) len1)))
    7010           0 :       (goto-char boundary)
    7011           0 :       (insert word)
    7012           0 :       (goto-char (+ boundary len1))
    7013           0 :       (delete-region (point) (+ (point) len2))
    7014           0 :       (set-marker boundary nil))))
    7015             : 
    7016             : (defun backward-word (&optional arg)
    7017             :   "Move backward until encountering the beginning of a word.
    7018             : With argument ARG, do this that many times.
    7019             : If ARG is omitted or nil, move point backward one word.
    7020             : 
    7021             : The word boundaries are normally determined by the buffer's syntax
    7022             : table, but `find-word-boundary-function-table', such as set up
    7023             : by `subword-mode', can change that.  If a Lisp program needs to
    7024             : move by words determined strictly by the syntax table, it should
    7025             : use `backward-word-strictly' instead."
    7026             :   (interactive "^p")
    7027           0 :   (forward-word (- (or arg 1))))
    7028             : 
    7029             : (defun mark-word (&optional arg allow-extend)
    7030             :   "Set mark ARG words away from point.
    7031             : The place mark goes is the same place \\[forward-word] would
    7032             : move to with the same argument.
    7033             : Interactively, if this command is repeated
    7034             : or (in Transient Mark mode) if the mark is active,
    7035             : it marks the next ARG words after the ones already marked."
    7036             :   (interactive "P\np")
    7037           0 :   (cond ((and allow-extend
    7038           0 :               (or (and (eq last-command this-command) (mark t))
    7039           0 :                   (region-active-p)))
    7040           0 :          (setq arg (if arg (prefix-numeric-value arg)
    7041           0 :                      (if (< (mark) (point)) -1 1)))
    7042           0 :          (set-mark
    7043           0 :           (save-excursion
    7044           0 :             (goto-char (mark))
    7045           0 :             (forward-word arg)
    7046           0 :             (point))))
    7047             :         (t
    7048           0 :          (push-mark
    7049           0 :           (save-excursion
    7050           0 :             (forward-word (prefix-numeric-value arg))
    7051           0 :             (point))
    7052           0 :           nil t))))
    7053             : 
    7054             : (defun kill-word (arg)
    7055             :   "Kill characters forward until encountering the end of a word.
    7056             : With argument ARG, do this that many times."
    7057             :   (interactive "p")
    7058           0 :   (kill-region (point) (progn (forward-word arg) (point))))
    7059             : 
    7060             : (defun backward-kill-word (arg)
    7061             :   "Kill characters backward until encountering the beginning of a word.
    7062             : With argument ARG, do this that many times."
    7063             :   (interactive "p")
    7064           0 :   (kill-word (- arg)))
    7065             : 
    7066             : (defun current-word (&optional strict really-word)
    7067             :   "Return the word at or near point, as a string.
    7068             : The return value includes no text properties.
    7069             : 
    7070             : If optional arg STRICT is non-nil, return nil unless point is
    7071             : within or adjacent to a word, otherwise look for a word within
    7072             : point's line.  If there is no word anywhere on point's line, the
    7073             : value is nil regardless of STRICT.
    7074             : 
    7075             : By default, this function treats as a single word any sequence of
    7076             : characters that have either word or symbol syntax.  If optional
    7077             : arg REALLY-WORD is non-nil, only characters of word syntax can
    7078             : constitute a word."
    7079           0 :   (save-excursion
    7080           0 :     (let* ((oldpoint (point)) (start (point)) (end (point))
    7081           0 :            (syntaxes (if really-word "w" "w_"))
    7082           0 :            (not-syntaxes (concat "^" syntaxes)))
    7083           0 :       (skip-syntax-backward syntaxes) (setq start (point))
    7084           0 :       (goto-char oldpoint)
    7085           0 :       (skip-syntax-forward syntaxes) (setq end (point))
    7086           0 :       (when (and (eq start oldpoint) (eq end oldpoint)
    7087             :                  ;; Point is neither within nor adjacent to a word.
    7088           0 :                  (not strict))
    7089             :         ;; Look for preceding word in same line.
    7090           0 :         (skip-syntax-backward not-syntaxes (line-beginning-position))
    7091           0 :         (if (bolp)
    7092             :             ;; No preceding word in same line.
    7093             :             ;; Look for following word in same line.
    7094           0 :             (progn
    7095           0 :               (skip-syntax-forward not-syntaxes (line-end-position))
    7096           0 :               (setq start (point))
    7097           0 :               (skip-syntax-forward syntaxes)
    7098           0 :               (setq end (point)))
    7099           0 :           (setq end (point))
    7100           0 :           (skip-syntax-backward syntaxes)
    7101           0 :           (setq start (point))))
    7102             :       ;; If we found something nonempty, return it as a string.
    7103           0 :       (unless (= start end)
    7104           0 :         (buffer-substring-no-properties start end)))))
    7105             : 
    7106             : (defcustom fill-prefix nil
    7107             :   "String for filling to insert at front of new line, or nil for none."
    7108             :   :type '(choice (const :tag "None" nil)
    7109             :                  string)
    7110             :   :group 'fill)
    7111             : (make-variable-buffer-local 'fill-prefix)
    7112             : (put 'fill-prefix 'safe-local-variable 'string-or-null-p)
    7113             : 
    7114             : (defcustom auto-fill-inhibit-regexp nil
    7115             :   "Regexp to match lines which should not be auto-filled."
    7116             :   :type '(choice (const :tag "None" nil)
    7117             :                  regexp)
    7118             :   :group 'fill)
    7119             : 
    7120             : (defun do-auto-fill ()
    7121             :   "The default value for `normal-auto-fill-function'.
    7122             : This is the default auto-fill function, some major modes use a different one.
    7123             : Returns t if it really did any work."
    7124           0 :   (let (fc justify give-up
    7125           0 :            (fill-prefix fill-prefix))
    7126           0 :     (if (or (not (setq justify (current-justification)))
    7127           0 :             (null (setq fc (current-fill-column)))
    7128           0 :             (and (eq justify 'left)
    7129           0 :                  (<= (current-column) fc))
    7130           0 :             (and auto-fill-inhibit-regexp
    7131           0 :                  (save-excursion (beginning-of-line)
    7132           0 :                                  (looking-at auto-fill-inhibit-regexp))))
    7133             :         nil ;; Auto-filling not required
    7134           0 :       (if (memq justify '(full center right))
    7135           0 :           (save-excursion (unjustify-current-line)))
    7136             : 
    7137             :       ;; Choose a fill-prefix automatically.
    7138           0 :       (when (and adaptive-fill-mode
    7139           0 :                  (or (null fill-prefix) (string= fill-prefix "")))
    7140           0 :         (let ((prefix
    7141           0 :                (fill-context-prefix
    7142           0 :                 (save-excursion (fill-forward-paragraph -1) (point))
    7143           0 :                 (save-excursion (fill-forward-paragraph 1) (point)))))
    7144           0 :           (and prefix (not (equal prefix ""))
    7145             :                ;; Use auto-indentation rather than a guessed empty prefix.
    7146           0 :                (not (and fill-indent-according-to-mode
    7147           0 :                          (string-match "\\`[ \t]*\\'" prefix)))
    7148           0 :                (setq fill-prefix prefix))))
    7149             : 
    7150           0 :       (while (and (not give-up) (> (current-column) fc))
    7151             :         ;; Determine where to split the line.
    7152           0 :         (let* (after-prefix
    7153             :                (fill-point
    7154           0 :                 (save-excursion
    7155           0 :                   (beginning-of-line)
    7156           0 :                   (setq after-prefix (point))
    7157           0 :                   (and fill-prefix
    7158           0 :                        (looking-at (regexp-quote fill-prefix))
    7159           0 :                        (setq after-prefix (match-end 0)))
    7160           0 :                   (move-to-column (1+ fc))
    7161           0 :                   (fill-move-to-break-point after-prefix)
    7162           0 :                   (point))))
    7163             : 
    7164             :           ;; See whether the place we found is any good.
    7165           0 :           (if (save-excursion
    7166           0 :                 (goto-char fill-point)
    7167           0 :                 (or (bolp)
    7168             :                     ;; There is no use breaking at end of line.
    7169           0 :                     (save-excursion (skip-chars-forward " ") (eolp))
    7170             :                     ;; It is futile to split at the end of the prefix
    7171             :                     ;; since we would just insert the prefix again.
    7172           0 :                     (and after-prefix (<= (point) after-prefix))
    7173             :                     ;; Don't split right after a comment starter
    7174             :                     ;; since we would just make another comment starter.
    7175           0 :                     (and comment-start-skip
    7176           0 :                          (let ((limit (point)))
    7177           0 :                            (beginning-of-line)
    7178           0 :                            (and (re-search-forward comment-start-skip
    7179           0 :                                                    limit t)
    7180           0 :                                 (eq (point) limit))))))
    7181             :               ;; No good place to break => stop trying.
    7182           0 :               (setq give-up t)
    7183             :             ;; Ok, we have a useful place to break the line.  Do it.
    7184           0 :             (let ((prev-column (current-column)))
    7185             :               ;; If point is at the fill-point, do not `save-excursion'.
    7186             :               ;; Otherwise, if a comment prefix or fill-prefix is inserted,
    7187             :               ;; point will end up before it rather than after it.
    7188           0 :               (if (save-excursion
    7189           0 :                     (skip-chars-backward " \t")
    7190           0 :                     (= (point) fill-point))
    7191           0 :                   (default-indent-new-line t)
    7192           0 :                 (save-excursion
    7193           0 :                   (goto-char fill-point)
    7194           0 :                   (default-indent-new-line t)))
    7195             :               ;; Now do justification, if required
    7196           0 :               (if (not (eq justify 'left))
    7197           0 :                   (save-excursion
    7198           0 :                     (end-of-line 0)
    7199           0 :                     (justify-current-line justify nil t)))
    7200             :               ;; If making the new line didn't reduce the hpos of
    7201             :               ;; the end of the line, then give up now;
    7202             :               ;; trying again will not help.
    7203           0 :               (if (>= (current-column) prev-column)
    7204           0 :                   (setq give-up t))))))
    7205             :       ;; Justify last line.
    7206           0 :       (justify-current-line justify t t)
    7207           0 :       t)))
    7208             : 
    7209             : (defvar comment-line-break-function 'comment-indent-new-line
    7210             :   "Mode-specific function which line breaks and continues a comment.
    7211             : This function is called during auto-filling when a comment syntax
    7212             : is defined.
    7213             : The function should take a single optional argument, which is a flag
    7214             : indicating whether it should use soft newlines.")
    7215             : 
    7216             : (defun default-indent-new-line (&optional soft)
    7217             :   "Break line at point and indent.
    7218             : If a comment syntax is defined, call `comment-indent-new-line'.
    7219             : 
    7220             : The inserted newline is marked hard if variable `use-hard-newlines' is true,
    7221             : unless optional argument SOFT is non-nil."
    7222             :   (interactive)
    7223           0 :   (if comment-start
    7224           0 :       (funcall comment-line-break-function soft)
    7225             :     ;; Insert the newline before removing empty space so that markers
    7226             :     ;; get preserved better.
    7227           0 :     (if soft (insert-and-inherit ?\n) (newline 1))
    7228           0 :     (save-excursion (forward-char -1) (delete-horizontal-space))
    7229           0 :     (delete-horizontal-space)
    7230             : 
    7231           0 :     (if (and fill-prefix (not adaptive-fill-mode))
    7232             :         ;; Blindly trust a non-adaptive fill-prefix.
    7233           0 :         (progn
    7234           0 :           (indent-to-left-margin)
    7235           0 :           (insert-before-markers-and-inherit fill-prefix))
    7236             : 
    7237           0 :       (cond
    7238             :        ;; If there's an adaptive prefix, use it unless we're inside
    7239             :        ;; a comment and the prefix is not a comment starter.
    7240           0 :        (fill-prefix
    7241           0 :         (indent-to-left-margin)
    7242           0 :         (insert-and-inherit fill-prefix))
    7243             :        ;; If we're not inside a comment, just try to indent.
    7244           0 :        (t (indent-according-to-mode))))))
    7245             : 
    7246             : (defun internal-auto-fill ()
    7247             :   "The function called by `self-insert-command' to perform auto-filling."
    7248           0 :   (when (or (not comment-start)
    7249           0 :             (not comment-auto-fill-only-comments)
    7250           0 :             (nth 4 (syntax-ppss)))
    7251           0 :     (funcall auto-fill-function)))
    7252             : 
    7253             : (defvar normal-auto-fill-function 'do-auto-fill
    7254             :   "The function to use for `auto-fill-function' if Auto Fill mode is turned on.
    7255             : Some major modes set this.")
    7256             : 
    7257             : (put 'auto-fill-function :minor-mode-function 'auto-fill-mode)
    7258             : ;; `functions' and `hooks' are usually unsafe to set, but setting
    7259             : ;; auto-fill-function to nil in a file-local setting is safe and
    7260             : ;; can be useful to prevent auto-filling.
    7261             : (put 'auto-fill-function 'safe-local-variable 'null)
    7262             : 
    7263             : (define-minor-mode auto-fill-mode
    7264             :   "Toggle automatic line breaking (Auto Fill mode).
    7265             : With a prefix argument ARG, enable Auto Fill mode if ARG is
    7266             : positive, and disable it otherwise.  If called from Lisp, enable
    7267             : the mode if ARG is omitted or nil.
    7268             : 
    7269             : When Auto Fill mode is enabled, inserting a space at a column
    7270             : beyond `current-fill-column' automatically breaks the line at a
    7271             : previous space.
    7272             : 
    7273             : When `auto-fill-mode' is on, the `auto-fill-function' variable is
    7274             : non-nil.
    7275             : 
    7276             : The value of `normal-auto-fill-function' specifies the function to use
    7277             : for `auto-fill-function' when turning Auto Fill mode on."
    7278             :   :variable (auto-fill-function
    7279             :              . (lambda (v) (setq auto-fill-function
    7280             :                             (if v normal-auto-fill-function)))))
    7281             : 
    7282             : ;; This holds a document string used to document auto-fill-mode.
    7283             : (defun auto-fill-function ()
    7284             :   "Automatically break line at a previous space, in insertion of text."
    7285             :   nil)
    7286             : 
    7287             : (defun turn-on-auto-fill ()
    7288             :   "Unconditionally turn on Auto Fill mode."
    7289           0 :   (auto-fill-mode 1))
    7290             : 
    7291             : (defun turn-off-auto-fill ()
    7292             :   "Unconditionally turn off Auto Fill mode."
    7293           0 :   (auto-fill-mode -1))
    7294             : 
    7295             : (custom-add-option 'text-mode-hook 'turn-on-auto-fill)
    7296             : 
    7297             : (defun set-fill-column (arg)
    7298             :   "Set `fill-column' to specified argument.
    7299             : Use \\[universal-argument] followed by a number to specify a column.
    7300             : Just \\[universal-argument] as argument means to use the current column."
    7301             :   (interactive
    7302           0 :    (list (or current-prefix-arg
    7303             :              ;; We used to use current-column silently, but C-x f is too easily
    7304             :              ;; typed as a typo for C-x C-f, so we turned it into an error and
    7305             :              ;; now an interactive prompt.
    7306           0 :              (read-number "Set fill-column to: " (current-column)))))
    7307           0 :   (if (consp arg)
    7308           0 :       (setq arg (current-column)))
    7309           0 :   (if (not (integerp arg))
    7310             :       ;; Disallow missing argument; it's probably a typo for C-x C-f.
    7311           0 :       (error "set-fill-column requires an explicit argument")
    7312           0 :     (message "Fill column set to %d (was %d)" arg fill-column)
    7313           0 :     (setq fill-column arg)))
    7314             : 
    7315             : (defun set-selective-display (arg)
    7316             :   "Set `selective-display' to ARG; clear it if no arg.
    7317             : When the value of `selective-display' is a number > 0,
    7318             : lines whose indentation is >= that value are not displayed.
    7319             : The variable `selective-display' has a separate value for each buffer."
    7320             :   (interactive "P")
    7321           0 :   (if (eq selective-display t)
    7322           0 :       (error "selective-display already in use for marked lines"))
    7323           0 :   (let ((current-vpos
    7324           0 :          (save-restriction
    7325           0 :            (narrow-to-region (point-min) (point))
    7326           0 :            (goto-char (window-start))
    7327           0 :            (vertical-motion (window-height)))))
    7328           0 :     (setq selective-display
    7329           0 :           (and arg (prefix-numeric-value arg)))
    7330           0 :     (recenter current-vpos))
    7331           0 :   (set-window-start (selected-window) (window-start))
    7332           0 :   (princ "selective-display set to " t)
    7333           0 :   (prin1 selective-display t)
    7334           0 :   (princ "." t))
    7335             : 
    7336             : (defvaralias 'indicate-unused-lines 'indicate-empty-lines)
    7337             : 
    7338             : (defun toggle-truncate-lines (&optional arg)
    7339             :   "Toggle truncating of long lines for the current buffer.
    7340             : When truncating is off, long lines are folded.
    7341             : With prefix argument ARG, truncate long lines if ARG is positive,
    7342             : otherwise fold them.  Note that in side-by-side windows, this
    7343             : command has no effect if `truncate-partial-width-windows' is
    7344             : non-nil."
    7345             :   (interactive "P")
    7346           0 :   (setq truncate-lines
    7347           0 :         (if (null arg)
    7348           0 :             (not truncate-lines)
    7349           0 :           (> (prefix-numeric-value arg) 0)))
    7350           0 :   (force-mode-line-update)
    7351           0 :   (unless truncate-lines
    7352           0 :     (let ((buffer (current-buffer)))
    7353           0 :       (walk-windows (lambda (window)
    7354           0 :                       (if (eq buffer (window-buffer window))
    7355           0 :                           (set-window-hscroll window 0)))
    7356           0 :                     nil t)))
    7357           0 :   (message "Truncate long lines %s"
    7358           0 :            (if truncate-lines "enabled" "disabled")))
    7359             : 
    7360             : (defun toggle-word-wrap (&optional arg)
    7361             :   "Toggle whether to use word-wrapping for continuation lines.
    7362             : With prefix argument ARG, wrap continuation lines at word boundaries
    7363             : if ARG is positive, otherwise wrap them at the right screen edge.
    7364             : This command toggles the value of `word-wrap'.  It has no effect
    7365             : if long lines are truncated."
    7366             :   (interactive "P")
    7367           0 :   (setq word-wrap
    7368           0 :         (if (null arg)
    7369           0 :             (not word-wrap)
    7370           0 :           (> (prefix-numeric-value arg) 0)))
    7371           0 :   (force-mode-line-update)
    7372           0 :   (message "Word wrapping %s"
    7373           0 :            (if word-wrap "enabled" "disabled")))
    7374             : 
    7375             : (defvar overwrite-mode-textual (purecopy " Ovwrt")
    7376             :   "The string displayed in the mode line when in overwrite mode.")
    7377             : (defvar overwrite-mode-binary (purecopy " Bin Ovwrt")
    7378             :   "The string displayed in the mode line when in binary overwrite mode.")
    7379             : 
    7380             : (define-minor-mode overwrite-mode
    7381             :   "Toggle Overwrite mode.
    7382             : With a prefix argument ARG, enable Overwrite mode if ARG is
    7383             : positive, and disable it otherwise.  If called from Lisp, enable
    7384             : the mode if ARG is omitted or nil.
    7385             : 
    7386             : When Overwrite mode is enabled, printing characters typed in
    7387             : replace existing text on a one-for-one basis, rather than pushing
    7388             : it to the right.  At the end of a line, such characters extend
    7389             : the line.  Before a tab, such characters insert until the tab is
    7390             : filled in.  \\[quoted-insert] still inserts characters in
    7391             : overwrite mode; this is supposed to make it easier to insert
    7392             : characters when necessary."
    7393             :   :variable (overwrite-mode
    7394             :              . (lambda (v) (setq overwrite-mode (if v 'overwrite-mode-textual)))))
    7395             : 
    7396             : (define-minor-mode binary-overwrite-mode
    7397             :   "Toggle Binary Overwrite mode.
    7398             : With a prefix argument ARG, enable Binary Overwrite mode if ARG
    7399             : is positive, and disable it otherwise.  If called from Lisp,
    7400             : enable the mode if ARG is omitted or nil.
    7401             : 
    7402             : When Binary Overwrite mode is enabled, printing characters typed
    7403             : in replace existing text.  Newlines are not treated specially, so
    7404             : typing at the end of a line joins the line to the next, with the
    7405             : typed character between them.  Typing before a tab character
    7406             : simply replaces the tab with the character typed.
    7407             : \\[quoted-insert] replaces the text at the cursor, just as
    7408             : ordinary typing characters do.
    7409             : 
    7410             : Note that Binary Overwrite mode is not its own minor mode; it is
    7411             : a specialization of overwrite mode, entered by setting the
    7412             : `overwrite-mode' variable to `overwrite-mode-binary'."
    7413             :   :variable (overwrite-mode
    7414             :              . (lambda (v) (setq overwrite-mode (if v 'overwrite-mode-binary)))))
    7415             : 
    7416             : (define-minor-mode line-number-mode
    7417             :   "Toggle line number display in the mode line (Line Number mode).
    7418             : With a prefix argument ARG, enable Line Number mode if ARG is
    7419             : positive, and disable it otherwise.  If called from Lisp, enable
    7420             : the mode if ARG is omitted or nil.
    7421             : 
    7422             : Line numbers do not appear for very large buffers and buffers
    7423             : with very long lines; see variables `line-number-display-limit'
    7424             : and `line-number-display-limit-width'."
    7425             :   :init-value t :global t :group 'mode-line)
    7426             : 
    7427             : (define-minor-mode column-number-mode
    7428             :   "Toggle column number display in the mode line (Column Number mode).
    7429             : With a prefix argument ARG, enable Column Number mode if ARG is
    7430             : positive, and disable it otherwise.
    7431             : 
    7432             : If called from Lisp, enable the mode if ARG is omitted or nil."
    7433             :   :global t :group 'mode-line)
    7434             : 
    7435             : (define-minor-mode size-indication-mode
    7436             :   "Toggle buffer size display in the mode line (Size Indication mode).
    7437             : With a prefix argument ARG, enable Size Indication mode if ARG is
    7438             : positive, and disable it otherwise.
    7439             : 
    7440             : If called from Lisp, enable the mode if ARG is omitted or nil."
    7441             :   :global t :group 'mode-line)
    7442             : 
    7443             : (define-minor-mode auto-save-mode
    7444             :   "Toggle auto-saving in the current buffer (Auto Save mode).
    7445             : With a prefix argument ARG, enable Auto Save mode if ARG is
    7446             : positive, and disable it otherwise.
    7447             : 
    7448             : If called from Lisp, enable the mode if ARG is omitted or nil."
    7449             :   :variable ((and buffer-auto-save-file-name
    7450             :                   ;; If auto-save is off because buffer has shrunk,
    7451             :                   ;; then toggling should turn it on.
    7452             :                   (>= buffer-saved-size 0))
    7453             :              . (lambda (val)
    7454             :                  (setq buffer-auto-save-file-name
    7455             :                        (cond
    7456             :                         ((null val) nil)
    7457             :                         ((and buffer-file-name auto-save-visited-file-name
    7458             :                               (not buffer-read-only))
    7459             :                          buffer-file-name)
    7460             :                         (t (make-auto-save-file-name))))))
    7461             :   ;; If -1 was stored here, to temporarily turn off saving,
    7462             :   ;; turn it back on.
    7463           0 :   (and (< buffer-saved-size 0)
    7464           0 :        (setq buffer-saved-size 0)))
    7465             : 
    7466             : (defgroup paren-blinking nil
    7467             :   "Blinking matching of parens and expressions."
    7468             :   :prefix "blink-matching-"
    7469             :   :group 'paren-matching)
    7470             : 
    7471             : (defcustom blink-matching-paren t
    7472             :   "Non-nil means show matching open-paren when close-paren is inserted.
    7473             : If t, highlight the paren.  If `jump', briefly move cursor to its
    7474             : position.  If `jump-offscreen', move cursor there even if the
    7475             : position is off screen.  With any other non-nil value, the
    7476             : off-screen position of the opening paren will be shown in the
    7477             : echo area."
    7478             :   :type '(choice
    7479             :           (const :tag "Disable" nil)
    7480             :           (const :tag "Highlight" t)
    7481             :           (const :tag "Move cursor" jump)
    7482             :           (const :tag "Move cursor, even if off screen" jump-offscreen))
    7483             :   :group 'paren-blinking)
    7484             : 
    7485             : (defcustom blink-matching-paren-on-screen t
    7486             :   "Non-nil means show matching open-paren when it is on screen.
    7487             : If nil, don't show it (but the open-paren can still be shown
    7488             : in the echo area when it is off screen).
    7489             : 
    7490             : This variable has no effect if `blink-matching-paren' is nil.
    7491             : \(In that case, the open-paren is never shown.)
    7492             : It is also ignored if `show-paren-mode' is enabled."
    7493             :   :type 'boolean
    7494             :   :group 'paren-blinking)
    7495             : 
    7496             : (defcustom blink-matching-paren-distance (* 100 1024)
    7497             :   "If non-nil, maximum distance to search backwards for matching open-paren.
    7498             : If nil, search stops at the beginning of the accessible portion of the buffer."
    7499             :   :version "23.2"                       ; 25->100k
    7500             :   :type '(choice (const nil) integer)
    7501             :   :group 'paren-blinking)
    7502             : 
    7503             : (defcustom blink-matching-delay 1
    7504             :   "Time in seconds to delay after showing a matching paren."
    7505             :   :type 'number
    7506             :   :group 'paren-blinking)
    7507             : 
    7508             : (defcustom blink-matching-paren-dont-ignore-comments nil
    7509             :   "If nil, `blink-matching-paren' ignores comments.
    7510             : More precisely, when looking for the matching parenthesis,
    7511             : it skips the contents of comments that end before point."
    7512             :   :type 'boolean
    7513             :   :group 'paren-blinking)
    7514             : 
    7515             : (defun blink-matching-check-mismatch (start end)
    7516             :   "Return whether or not START...END are matching parens.
    7517             : END is the current point and START is the blink position.
    7518             : START might be nil if no matching starter was found.
    7519             : Returns non-nil if we find there is a mismatch."
    7520           0 :   (let* ((end-syntax (syntax-after (1- end)))
    7521           0 :          (matching-paren (and (consp end-syntax)
    7522           0 :                               (eq (syntax-class end-syntax) 5)
    7523           0 :                               (cdr end-syntax))))
    7524             :     ;; For self-matched chars like " and $, we can't know when they're
    7525             :     ;; mismatched or unmatched, so we can only do it for parens.
    7526           0 :     (when matching-paren
    7527           0 :       (not (and start
    7528           0 :                 (or
    7529           0 :                  (eq (char-after start) matching-paren)
    7530             :                  ;; The cdr might hold a new paren-class info rather than
    7531             :                  ;; a matching-char info, in which case the two CDRs
    7532             :                  ;; should match.
    7533           0 :                  (eq matching-paren (cdr-safe (syntax-after start)))))))))
    7534             : 
    7535             : (defvar blink-matching-check-function #'blink-matching-check-mismatch
    7536             :   "Function to check parentheses mismatches.
    7537             : The function takes two arguments (START and END) where START is the
    7538             : position just before the opening token and END is the position right after.
    7539             : START can be nil, if it was not found.
    7540             : The function should return non-nil if the two tokens do not match.")
    7541             : 
    7542             : (defvar blink-matching--overlay
    7543             :   (let ((ol (make-overlay (point) (point) nil t)))
    7544             :     (overlay-put ol 'face 'show-paren-match)
    7545             :     (delete-overlay ol)
    7546             :     ol)
    7547             :   "Overlay used to highlight the matching paren.")
    7548             : 
    7549             : (defun blink-matching-open ()
    7550             :   "Momentarily highlight the beginning of the sexp before point."
    7551             :   (interactive)
    7552           0 :   (when (and (not (bobp))
    7553           0 :              blink-matching-paren)
    7554           0 :     (let* ((oldpos (point))
    7555             :            (message-log-max nil) ; Don't log messages about paren matching.
    7556             :            (blinkpos
    7557           0 :             (save-excursion
    7558           0 :               (save-restriction
    7559           0 :                 (if blink-matching-paren-distance
    7560           0 :                     (narrow-to-region
    7561           0 :                      (max (minibuffer-prompt-end) ;(point-min) unless minibuf.
    7562           0 :                           (- (point) blink-matching-paren-distance))
    7563           0 :                      oldpos))
    7564           0 :                 (let ((parse-sexp-ignore-comments
    7565           0 :                        (and parse-sexp-ignore-comments
    7566           0 :                             (not blink-matching-paren-dont-ignore-comments))))
    7567           0 :                   (condition-case ()
    7568           0 :                       (progn
    7569           0 :                         (syntax-propertize (point))
    7570           0 :                         (forward-sexp -1)
    7571             :                         ;; backward-sexp skips backward over prefix chars,
    7572             :                         ;; so move back to the matching paren.
    7573           0 :                         (while (and (< (point) (1- oldpos))
    7574           0 :                                     (let ((code (syntax-after (point))))
    7575           0 :                                       (or (eq (syntax-class code) 6)
    7576           0 :                                           (eq (logand 1048576 (car code))
    7577           0 :                                               1048576))))
    7578           0 :                           (forward-char 1))
    7579           0 :                         (point))
    7580           0 :                     (error nil))))))
    7581           0 :            (mismatch (funcall blink-matching-check-function blinkpos oldpos)))
    7582           0 :       (cond
    7583           0 :        (mismatch
    7584           0 :         (if blinkpos
    7585           0 :             (if (minibufferp)
    7586           0 :                 (minibuffer-message "Mismatched parentheses")
    7587           0 :               (message "Mismatched parentheses"))
    7588           0 :           (if (minibufferp)
    7589           0 :               (minibuffer-message "No matching parenthesis found")
    7590           0 :             (message "No matching parenthesis found"))))
    7591           0 :        ((not blinkpos) nil)
    7592           0 :        ((or
    7593           0 :          (eq blink-matching-paren 'jump-offscreen)
    7594           0 :          (pos-visible-in-window-p blinkpos))
    7595             :         ;; Matching open within window, temporarily move to or highlight
    7596             :         ;; char after blinkpos but only if `blink-matching-paren-on-screen'
    7597             :         ;; is non-nil.
    7598           0 :         (and blink-matching-paren-on-screen
    7599           0 :              (not show-paren-mode)
    7600           0 :              (if (memq blink-matching-paren '(jump jump-offscreen))
    7601           0 :                  (save-excursion
    7602           0 :                    (goto-char blinkpos)
    7603           0 :                    (sit-for blink-matching-delay))
    7604           0 :                (unwind-protect
    7605           0 :                    (progn
    7606           0 :                      (move-overlay blink-matching--overlay blinkpos (1+ blinkpos)
    7607           0 :                                    (current-buffer))
    7608           0 :                      (sit-for blink-matching-delay))
    7609           0 :                  (delete-overlay blink-matching--overlay)))))
    7610             :        (t
    7611           0 :         (let ((open-paren-line-string
    7612           0 :                (save-excursion
    7613           0 :                  (goto-char blinkpos)
    7614             :                  ;; Show what precedes the open in its line, if anything.
    7615           0 :                  (cond
    7616           0 :                   ((save-excursion (skip-chars-backward " \t") (not (bolp)))
    7617           0 :                    (buffer-substring (line-beginning-position)
    7618           0 :                                      (1+ blinkpos)))
    7619             :                   ;; Show what follows the open in its line, if anything.
    7620           0 :                   ((save-excursion
    7621           0 :                      (forward-char 1)
    7622           0 :                      (skip-chars-forward " \t")
    7623           0 :                      (not (eolp)))
    7624           0 :                    (buffer-substring blinkpos
    7625           0 :                                      (line-end-position)))
    7626             :                   ;; Otherwise show the previous nonblank line,
    7627             :                   ;; if there is one.
    7628           0 :                   ((save-excursion (skip-chars-backward "\n \t") (not (bobp)))
    7629           0 :                    (concat
    7630           0 :                     (buffer-substring (progn
    7631           0 :                                         (skip-chars-backward "\n \t")
    7632           0 :                                         (line-beginning-position))
    7633           0 :                                       (progn (end-of-line)
    7634           0 :                                              (skip-chars-backward " \t")
    7635           0 :                                              (point)))
    7636             :                     ;; Replace the newline and other whitespace with `...'.
    7637             :                     "..."
    7638           0 :                     (buffer-substring blinkpos (1+ blinkpos))))
    7639             :                   ;; There is nothing to show except the char itself.
    7640           0 :                   (t (buffer-substring blinkpos (1+ blinkpos)))))))
    7641           0 :           (minibuffer-message
    7642             :            "Matches %s"
    7643           0 :            (substring-no-properties open-paren-line-string))))))))
    7644             : 
    7645             : (defvar blink-paren-function 'blink-matching-open
    7646             :   "Function called, if non-nil, whenever a close parenthesis is inserted.
    7647             : More precisely, a char with closeparen syntax is self-inserted.")
    7648             : 
    7649             : (defun blink-paren-post-self-insert-function ()
    7650           0 :   (when (and (eq (char-before) last-command-event) ; Sanity check.
    7651           0 :              (memq (char-syntax last-command-event) '(?\) ?\$))
    7652           0 :              blink-paren-function
    7653           0 :              (not executing-kbd-macro)
    7654           0 :              (not noninteractive)
    7655             :              ;; Verify an even number of quoting characters precede the close.
    7656             :              ;; FIXME: Also check if this parenthesis closes a comment as
    7657             :              ;; can happen in Pascal and SML.
    7658           0 :              (= 1 (logand 1 (- (point)
    7659           0 :                                (save-excursion
    7660           0 :                                  (forward-char -1)
    7661           0 :                                  (skip-syntax-backward "/\\")
    7662           0 :                                  (point))))))
    7663           0 :     (funcall blink-paren-function)))
    7664             : 
    7665             : (put 'blink-paren-post-self-insert-function 'priority 100)
    7666             : 
    7667             : (add-hook 'post-self-insert-hook #'blink-paren-post-self-insert-function
    7668             :           ;; Most likely, this hook is nil, so this arg doesn't matter,
    7669             :           ;; but I use it as a reminder that this function usually
    7670             :           ;; likes to be run after others since it does
    7671             :           ;; `sit-for'. That's also the reason it get a `priority' prop
    7672             :           ;; of 100.
    7673             :           'append)
    7674             : 
    7675             : ;; This executes C-g typed while Emacs is waiting for a command.
    7676             : ;; Quitting out of a program does not go through here;
    7677             : ;; that happens in the maybe_quit function at the C code level.
    7678             : (defun keyboard-quit ()
    7679             :   "Signal a `quit' condition.
    7680             : During execution of Lisp code, this character causes a quit directly.
    7681             : At top-level, as an editor command, this simply beeps."
    7682             :   (interactive)
    7683             :   ;; Avoid adding the region to the window selection.
    7684           0 :   (setq saved-region-selection nil)
    7685           0 :   (let (select-active-regions)
    7686           0 :     (deactivate-mark))
    7687           0 :   (if (fboundp 'kmacro-keyboard-quit)
    7688           0 :       (kmacro-keyboard-quit))
    7689           0 :   (when completion-in-region-mode
    7690           0 :     (completion-in-region-mode -1))
    7691             :   ;; Force the next redisplay cycle to remove the "Def" indicator from
    7692             :   ;; all the mode lines.
    7693           0 :   (if defining-kbd-macro
    7694           0 :       (force-mode-line-update t))
    7695           0 :   (setq defining-kbd-macro nil)
    7696           0 :   (let ((debug-on-quit nil))
    7697           0 :     (signal 'quit nil)))
    7698             : 
    7699             : (defvar buffer-quit-function nil
    7700             :   "Function to call to \"quit\" the current buffer, or nil if none.
    7701             : \\[keyboard-escape-quit] calls this function when its more local actions
    7702             : \(such as canceling a prefix argument, minibuffer or region) do not apply.")
    7703             : 
    7704             : (defun keyboard-escape-quit ()
    7705             :   "Exit the current \"mode\" (in a generalized sense of the word).
    7706             : This command can exit an interactive command such as `query-replace',
    7707             : can clear out a prefix argument or a region,
    7708             : can get out of the minibuffer or other recursive edit,
    7709             : cancel the use of the current buffer (for special-purpose buffers),
    7710             : or go back to just one window (by deleting all but the selected window)."
    7711             :   (interactive)
    7712           0 :   (cond ((eq last-command 'mode-exited) nil)
    7713           0 :         ((region-active-p)
    7714           0 :          (deactivate-mark))
    7715           0 :         ((> (minibuffer-depth) 0)
    7716           0 :          (abort-recursive-edit))
    7717           0 :         (current-prefix-arg
    7718             :          nil)
    7719           0 :         ((> (recursion-depth) 0)
    7720           0 :          (exit-recursive-edit))
    7721           0 :         (buffer-quit-function
    7722           0 :          (funcall buffer-quit-function))
    7723           0 :         ((not (one-window-p t))
    7724           0 :          (delete-other-windows))
    7725           0 :         ((string-match "^ \\*" (buffer-name (current-buffer)))
    7726           0 :          (bury-buffer))))
    7727             : 
    7728             : (defun play-sound-file (file &optional volume device)
    7729             :   "Play sound stored in FILE.
    7730             : VOLUME and DEVICE correspond to the keywords of the sound
    7731             : specification for `play-sound'."
    7732             :   (interactive "fPlay sound file: ")
    7733           0 :   (let ((sound (list :file file)))
    7734           0 :     (if volume
    7735           0 :         (plist-put sound :volume volume))
    7736           0 :     (if device
    7737           0 :         (plist-put sound :device device))
    7738           0 :     (push 'sound sound)
    7739           0 :     (play-sound sound)))
    7740             : 
    7741             : 
    7742             : (defcustom read-mail-command 'rmail
    7743             :   "Your preference for a mail reading package.
    7744             : This is used by some keybindings which support reading mail.
    7745             : See also `mail-user-agent' concerning sending mail."
    7746             :   :type '(radio (function-item :tag "Rmail" :format "%t\n" rmail)
    7747             :                 (function-item :tag "Gnus" :format "%t\n" gnus)
    7748             :                 (function-item :tag "Emacs interface to MH"
    7749             :                                :format "%t\n" mh-rmail)
    7750             :                 (function :tag "Other"))
    7751             :   :version "21.1"
    7752             :   :group 'mail)
    7753             : 
    7754             : (defcustom mail-user-agent 'message-user-agent
    7755             :   "Your preference for a mail composition package.
    7756             : Various Emacs Lisp packages (e.g. Reporter) require you to compose an
    7757             : outgoing email message.  This variable lets you specify which
    7758             : mail-sending package you prefer.
    7759             : 
    7760             : Valid values include:
    7761             : 
    7762             :   `message-user-agent'  -- use the Message package.
    7763             :                            See Info node `(message)'.
    7764             :   `sendmail-user-agent' -- use the Mail package.
    7765             :                            See Info node `(emacs)Sending Mail'.
    7766             :   `mh-e-user-agent'     -- use the Emacs interface to the MH mail system.
    7767             :                            See Info node `(mh-e)'.
    7768             :   `gnus-user-agent'     -- like `message-user-agent', but with Gnus
    7769             :                            paraphernalia if Gnus is running, particularly
    7770             :                            the Gcc: header for archiving.
    7771             : 
    7772             : Additional valid symbols may be available; check with the author of
    7773             : your package for details.  The function should return non-nil if it
    7774             : succeeds.
    7775             : 
    7776             : See also `read-mail-command' concerning reading mail."
    7777             :   :type '(radio (function-item :tag "Message package"
    7778             :                                :format "%t\n"
    7779             :                                message-user-agent)
    7780             :                 (function-item :tag "Mail package"
    7781             :                                :format "%t\n"
    7782             :                                sendmail-user-agent)
    7783             :                 (function-item :tag "Emacs interface to MH"
    7784             :                                :format "%t\n"
    7785             :                                mh-e-user-agent)
    7786             :                 (function-item :tag "Message with full Gnus features"
    7787             :                                :format "%t\n"
    7788             :                                gnus-user-agent)
    7789             :                 (function :tag "Other"))
    7790             :   :version "23.2"                       ; sendmail->message
    7791             :   :group 'mail)
    7792             : 
    7793             : (defcustom compose-mail-user-agent-warnings t
    7794             :   "If non-nil, `compose-mail' warns about changes in `mail-user-agent'.
    7795             : If the value of `mail-user-agent' is the default, and the user
    7796             : appears to have customizations applying to the old default,
    7797             : `compose-mail' issues a warning."
    7798             :   :type 'boolean
    7799             :   :version "23.2"
    7800             :   :group 'mail)
    7801             : 
    7802             : (defun rfc822-goto-eoh ()
    7803             :   "If the buffer starts with a mail header, move point to the header's end.
    7804             : Otherwise, moves to `point-min'.
    7805             : The end of the header is the start of the next line, if there is one,
    7806             : else the end of the last line.  This function obeys RFC822."
    7807           0 :   (goto-char (point-min))
    7808           0 :   (when (re-search-forward
    7809           0 :          "^\\([:\n]\\|[^: \t\n]+[ \t\n]\\)" nil 'move)
    7810           0 :     (goto-char (match-beginning 0))))
    7811             : 
    7812             : ;; Used by Rmail (e.g., rmail-forward).
    7813             : (defvar mail-encode-mml nil
    7814             :   "If non-nil, mail-user-agent's `sendfunc' command should mml-encode
    7815             : the outgoing message before sending it.")
    7816             : 
    7817             : (defun compose-mail (&optional to subject other-headers continue
    7818             :                      switch-function yank-action send-actions
    7819             :                      return-action)
    7820             :   "Start composing a mail message to send.
    7821             : This uses the user's chosen mail composition package
    7822             : as selected with the variable `mail-user-agent'.
    7823             : The optional arguments TO and SUBJECT specify recipients
    7824             : and the initial Subject field, respectively.
    7825             : 
    7826             : OTHER-HEADERS is an alist specifying additional
    7827             : header fields.  Elements look like (HEADER . VALUE) where both
    7828             : HEADER and VALUE are strings.
    7829             : 
    7830             : CONTINUE, if non-nil, says to continue editing a message already
    7831             : being composed.  Interactively, CONTINUE is the prefix argument.
    7832             : 
    7833             : SWITCH-FUNCTION, if non-nil, is a function to use to
    7834             : switch to and display the buffer used for mail composition.
    7835             : 
    7836             : YANK-ACTION, if non-nil, is an action to perform, if and when necessary,
    7837             : to insert the raw text of the message being replied to.
    7838             : It has the form (FUNCTION . ARGS).  The user agent will apply
    7839             : FUNCTION to ARGS, to insert the raw text of the original message.
    7840             : \(The user agent will also run `mail-citation-hook', *after* the
    7841             : original text has been inserted in this way.)
    7842             : 
    7843             : SEND-ACTIONS is a list of actions to call when the message is sent.
    7844             : Each action has the form (FUNCTION . ARGS).
    7845             : 
    7846             : RETURN-ACTION, if non-nil, is an action for returning to the
    7847             : caller.  It has the form (FUNCTION . ARGS).  The function is
    7848             : called after the mail has been sent or put aside, and the mail
    7849             : buffer buried."
    7850             :   (interactive
    7851           0 :    (list nil nil nil current-prefix-arg))
    7852             : 
    7853             :   ;; In Emacs 23.2, the default value of `mail-user-agent' changed
    7854             :   ;; from sendmail-user-agent to message-user-agent.  Some users may
    7855             :   ;; encounter incompatibilities.  This hack tries to detect problems
    7856             :   ;; and warn about them.
    7857           0 :   (and compose-mail-user-agent-warnings
    7858           0 :        (eq mail-user-agent 'message-user-agent)
    7859           0 :        (let (warn-vars)
    7860           0 :          (dolist (var '(mail-mode-hook mail-send-hook mail-setup-hook
    7861             :                         mail-yank-hooks mail-archive-file-name
    7862             :                         mail-default-reply-to mail-mailing-lists
    7863             :                         mail-self-blind))
    7864           0 :            (and (boundp var)
    7865           0 :                 (symbol-value var)
    7866           0 :                 (push var warn-vars)))
    7867           0 :          (when warn-vars
    7868           0 :            (display-warning 'mail
    7869           0 :                             (format-message "\
    7870             : The default mail mode is now Message mode.
    7871             : You have the following Mail mode variable%s customized:
    7872             : \n  %s\n\nTo use Mail mode, set `mail-user-agent' to sendmail-user-agent.
    7873             : To disable this warning, set `compose-mail-user-agent-warnings' to nil."
    7874           0 :                                     (if (> (length warn-vars) 1) "s" "")
    7875           0 :                                     (mapconcat 'symbol-name
    7876           0 :                                                warn-vars " "))))))
    7877             : 
    7878           0 :   (let ((function (get mail-user-agent 'composefunc)))
    7879           0 :     (funcall function to subject other-headers continue switch-function
    7880           0 :              yank-action send-actions return-action)))
    7881             : 
    7882             : (defun compose-mail-other-window (&optional to subject other-headers continue
    7883             :                                             yank-action send-actions
    7884             :                                             return-action)
    7885             :   "Like \\[compose-mail], but edit the outgoing message in another window."
    7886           0 :   (interactive (list nil nil nil current-prefix-arg))
    7887           0 :   (compose-mail to subject other-headers continue
    7888           0 :                 'switch-to-buffer-other-window yank-action send-actions
    7889           0 :                 return-action))
    7890             : 
    7891             : (defun compose-mail-other-frame (&optional to subject other-headers continue
    7892             :                                             yank-action send-actions
    7893             :                                             return-action)
    7894             :   "Like \\[compose-mail], but edit the outgoing message in another frame."
    7895           0 :   (interactive (list nil nil nil current-prefix-arg))
    7896           0 :   (compose-mail to subject other-headers continue
    7897           0 :                 'switch-to-buffer-other-frame yank-action send-actions
    7898           0 :                 return-action))
    7899             : 
    7900             : 
    7901             : (defvar set-variable-value-history nil
    7902             :   "History of values entered with `set-variable'.
    7903             : 
    7904             : Maximum length of the history list is determined by the value
    7905             : of `history-length', which see.")
    7906             : 
    7907             : (defun set-variable (variable value &optional make-local)
    7908             :   "Set VARIABLE to VALUE.  VALUE is a Lisp object.
    7909             : VARIABLE should be a user option variable name, a Lisp variable
    7910             : meant to be customized by users.  You should enter VALUE in Lisp syntax,
    7911             : so if you want VALUE to be a string, you must surround it with doublequotes.
    7912             : VALUE is used literally, not evaluated.
    7913             : 
    7914             : If VARIABLE has a `variable-interactive' property, that is used as if
    7915             : it were the arg to `interactive' (which see) to interactively read VALUE.
    7916             : 
    7917             : If VARIABLE has been defined with `defcustom', then the type information
    7918             : in the definition is used to check that VALUE is valid.
    7919             : 
    7920             : Note that this function is at heart equivalent to the basic `set' function.
    7921             : For a variable defined with `defcustom', it does not pay attention to
    7922             : any :set property that the variable might have (if you want that, use
    7923             : \\[customize-set-variable] instead).
    7924             : 
    7925             : With a prefix argument, set VARIABLE to VALUE buffer-locally."
    7926             :   (interactive
    7927           0 :    (let* ((default-var (variable-at-point))
    7928           0 :           (var (if (custom-variable-p default-var)
    7929           0 :                    (read-variable (format "Set variable (default %s): " default-var)
    7930           0 :                                   default-var)
    7931           0 :                  (read-variable "Set variable: ")))
    7932             :           (minibuffer-help-form '(describe-variable var))
    7933           0 :           (prop (get var 'variable-interactive))
    7934           0 :           (obsolete (car (get var 'byte-obsolete-variable)))
    7935           0 :           (prompt (format "Set %s %s to value: " var
    7936           0 :                           (cond ((local-variable-p var)
    7937             :                                  "(buffer-local)")
    7938           0 :                                 ((or current-prefix-arg
    7939           0 :                                      (local-variable-if-set-p var))
    7940             :                                  "buffer-locally")
    7941           0 :                                 (t "globally"))))
    7942           0 :           (val (progn
    7943           0 :                  (when obsolete
    7944           0 :                    (message (concat "`%S' is obsolete; "
    7945           0 :                                     (if (symbolp obsolete) "use `%S' instead" "%s"))
    7946           0 :                             var obsolete)
    7947           0 :                    (sit-for 3))
    7948           0 :                  (if prop
    7949             :                      ;; Use VAR's `variable-interactive' property
    7950             :                      ;; as an interactive spec for prompting.
    7951           0 :                      (call-interactively `(lambda (arg)
    7952           0 :                                             (interactive ,prop)
    7953           0 :                                             arg))
    7954           0 :                    (read-from-minibuffer prompt nil
    7955           0 :                                          read-expression-map t
    7956             :                                          'set-variable-value-history
    7957           0 :                                          (format "%S" (symbol-value var)))))))
    7958           0 :      (list var val current-prefix-arg)))
    7959             : 
    7960           0 :   (and (custom-variable-p variable)
    7961           0 :        (not (get variable 'custom-type))
    7962           0 :        (custom-load-symbol variable))
    7963           0 :   (let ((type (get variable 'custom-type)))
    7964           0 :     (when type
    7965             :       ;; Match with custom type.
    7966           0 :       (require 'cus-edit)
    7967           0 :       (setq type (widget-convert type))
    7968           0 :       (unless (widget-apply type :match value)
    7969           0 :         (user-error "Value `%S' does not match type %S of %S"
    7970           0 :                     value (car type) variable))))
    7971             : 
    7972           0 :   (if make-local
    7973           0 :       (make-local-variable variable))
    7974             : 
    7975           0 :   (set variable value)
    7976             : 
    7977             :   ;; Force a thorough redisplay for the case that the variable
    7978             :   ;; has an effect on the display, like `tab-width' has.
    7979           0 :   (force-mode-line-update))
    7980             : 
    7981             : ;; Define the major mode for lists of completions.
    7982             : 
    7983             : (defvar completion-list-mode-map
    7984             :   (let ((map (make-sparse-keymap)))
    7985             :     (define-key map [mouse-2] 'choose-completion)
    7986             :     (define-key map [follow-link] 'mouse-face)
    7987             :     (define-key map [down-mouse-2] nil)
    7988             :     (define-key map "\C-m" 'choose-completion)
    7989             :     (define-key map "\e\e\e" 'delete-completion-window)
    7990             :     (define-key map [left] 'previous-completion)
    7991             :     (define-key map [right] 'next-completion)
    7992             :     (define-key map [?\t] 'next-completion)
    7993             :     (define-key map [backtab] 'previous-completion)
    7994             :     (define-key map "q" 'quit-window)
    7995             :     (define-key map "z" 'kill-current-buffer)
    7996             :     map)
    7997             :   "Local map for completion list buffers.")
    7998             : 
    7999             : ;; Completion mode is suitable only for specially formatted data.
    8000             : (put 'completion-list-mode 'mode-class 'special)
    8001             : 
    8002             : (defvar completion-reference-buffer nil
    8003             :   "Record the buffer that was current when the completion list was requested.
    8004             : This is a local variable in the completion list buffer.
    8005             : Initial value is nil to avoid some compiler warnings.")
    8006             : 
    8007             : (defvar completion-no-auto-exit nil
    8008             :   "Non-nil means `choose-completion-string' should never exit the minibuffer.
    8009             : This also applies to other functions such as `choose-completion'.")
    8010             : 
    8011             : (defvar completion-base-position nil
    8012             :   "Position of the base of the text corresponding to the shown completions.
    8013             : This variable is used in the *Completions* buffers.
    8014             : Its value is a list of the form (START END) where START is the place
    8015             : where the completion should be inserted and END (if non-nil) is the end
    8016             : of the text to replace.  If END is nil, point is used instead.")
    8017             : 
    8018             : (defvar completion-list-insert-choice-function #'completion--replace
    8019             :   "Function to use to insert the text chosen in *Completions*.
    8020             : Called with three arguments (BEG END TEXT), it should replace the text
    8021             : between BEG and END with TEXT.  Expected to be set buffer-locally
    8022             : in the *Completions* buffer.")
    8023             : 
    8024             : (defvar completion-base-size nil
    8025             :   "Number of chars before point not involved in completion.
    8026             : This is a local variable in the completion list buffer.
    8027             : It refers to the chars in the minibuffer if completing in the
    8028             : minibuffer, or in `completion-reference-buffer' otherwise.
    8029             : Only characters in the field at point are included.
    8030             : 
    8031             : If nil, Emacs determines which part of the tail end of the
    8032             : buffer's text is involved in completion by comparing the text
    8033             : directly.")
    8034             : (make-obsolete-variable 'completion-base-size 'completion-base-position "23.2")
    8035             : 
    8036             : (defun delete-completion-window ()
    8037             :   "Delete the completion list window.
    8038             : Go to the window from which completion was requested."
    8039             :   (interactive)
    8040           0 :   (let ((buf completion-reference-buffer))
    8041           0 :     (if (one-window-p t)
    8042           0 :         (if (window-dedicated-p) (delete-frame))
    8043           0 :       (delete-window (selected-window))
    8044           0 :       (if (get-buffer-window buf)
    8045           0 :           (select-window (get-buffer-window buf))))))
    8046             : 
    8047             : (defun previous-completion (n)
    8048             :   "Move to the previous item in the completion list."
    8049             :   (interactive "p")
    8050           0 :   (next-completion (- n)))
    8051             : 
    8052             : (defun next-completion (n)
    8053             :   "Move to the next item in the completion list.
    8054             : With prefix argument N, move N items (negative N means move backward)."
    8055             :   (interactive "p")
    8056           0 :   (let ((beg (point-min)) (end (point-max)))
    8057           0 :     (while (and (> n 0) (not (eobp)))
    8058             :       ;; If in a completion, move to the end of it.
    8059           0 :       (when (get-text-property (point) 'mouse-face)
    8060           0 :         (goto-char (next-single-property-change (point) 'mouse-face nil end)))
    8061             :       ;; Move to start of next one.
    8062           0 :       (unless (get-text-property (point) 'mouse-face)
    8063           0 :         (goto-char (next-single-property-change (point) 'mouse-face nil end)))
    8064           0 :       (setq n (1- n)))
    8065           0 :     (while (and (< n 0) (not (bobp)))
    8066           0 :       (let ((prop (get-text-property (1- (point)) 'mouse-face)))
    8067             :         ;; If in a completion, move to the start of it.
    8068           0 :         (when (and prop (eq prop (get-text-property (point) 'mouse-face)))
    8069           0 :           (goto-char (previous-single-property-change
    8070           0 :                       (point) 'mouse-face nil beg)))
    8071             :         ;; Move to end of the previous completion.
    8072           0 :         (unless (or (bobp) (get-text-property (1- (point)) 'mouse-face))
    8073           0 :           (goto-char (previous-single-property-change
    8074           0 :                       (point) 'mouse-face nil beg)))
    8075             :         ;; Move to the start of that one.
    8076           0 :         (goto-char (previous-single-property-change
    8077           0 :                     (point) 'mouse-face nil beg))
    8078           0 :         (setq n (1+ n))))))
    8079             : 
    8080             : (defun choose-completion (&optional event)
    8081             :   "Choose the completion at point.
    8082             : If EVENT, use EVENT's position to determine the starting position."
    8083           0 :   (interactive (list last-nonmenu-event))
    8084             :   ;; In case this is run via the mouse, give temporary modes such as
    8085             :   ;; isearch a chance to turn off.
    8086           0 :   (run-hooks 'mouse-leave-buffer-hook)
    8087           0 :   (with-current-buffer (window-buffer (posn-window (event-start event)))
    8088           0 :     (let ((buffer completion-reference-buffer)
    8089           0 :           (base-size completion-base-size)
    8090           0 :           (base-position completion-base-position)
    8091           0 :           (insert-function completion-list-insert-choice-function)
    8092             :           (choice
    8093           0 :            (save-excursion
    8094           0 :              (goto-char (posn-point (event-start event)))
    8095           0 :              (let (beg end)
    8096           0 :                (cond
    8097           0 :                 ((and (not (eobp)) (get-text-property (point) 'mouse-face))
    8098           0 :                  (setq end (point) beg (1+ (point))))
    8099           0 :                 ((and (not (bobp))
    8100           0 :                       (get-text-property (1- (point)) 'mouse-face))
    8101           0 :                  (setq end (1- (point)) beg (point)))
    8102           0 :                 (t (error "No completion here")))
    8103           0 :                (setq beg (previous-single-property-change beg 'mouse-face))
    8104           0 :                (setq end (or (next-single-property-change end 'mouse-face)
    8105           0 :                              (point-max)))
    8106           0 :                (buffer-substring-no-properties beg end)))))
    8107             : 
    8108           0 :       (unless (buffer-live-p buffer)
    8109           0 :         (error "Destination buffer is dead"))
    8110           0 :       (quit-window nil (posn-window (event-start event)))
    8111             : 
    8112           0 :       (with-current-buffer buffer
    8113           0 :         (choose-completion-string
    8114           0 :          choice buffer
    8115           0 :          (or base-position
    8116           0 :              (when base-size
    8117             :                ;; Someone's using old completion code that doesn't know
    8118             :                ;; about base-position yet.
    8119           0 :                (list (+ base-size (field-beginning))))
    8120             :              ;; If all else fails, just guess.
    8121           0 :              (list (choose-completion-guess-base-position choice)))
    8122           0 :          insert-function)))))
    8123             : 
    8124             : ;; Delete the longest partial match for STRING
    8125             : ;; that can be found before POINT.
    8126             : (defun choose-completion-guess-base-position (string)
    8127           0 :   (save-excursion
    8128           0 :     (let ((opoint (point))
    8129             :           len)
    8130             :       ;; Try moving back by the length of the string.
    8131           0 :       (goto-char (max (- (point) (length string))
    8132           0 :                       (minibuffer-prompt-end)))
    8133             :       ;; See how far back we were actually able to move.  That is the
    8134             :       ;; upper bound on how much we can match and delete.
    8135           0 :       (setq len (- opoint (point)))
    8136           0 :       (if completion-ignore-case
    8137           0 :           (setq string (downcase string)))
    8138           0 :       (while (and (> len 0)
    8139           0 :                   (let ((tail (buffer-substring (point) opoint)))
    8140           0 :                     (if completion-ignore-case
    8141           0 :                         (setq tail (downcase tail)))
    8142           0 :                     (not (string= tail (substring string 0 len)))))
    8143           0 :         (setq len (1- len))
    8144           0 :         (forward-char 1))
    8145           0 :       (point))))
    8146             : 
    8147             : (defun choose-completion-delete-max-match (string)
    8148             :   (declare (obsolete choose-completion-guess-base-position "23.2"))
    8149           0 :   (delete-region (choose-completion-guess-base-position string) (point)))
    8150             : 
    8151             : (defvar choose-completion-string-functions nil
    8152             :   "Functions that may override the normal insertion of a completion choice.
    8153             : These functions are called in order with three arguments:
    8154             : CHOICE - the string to insert in the buffer,
    8155             : BUFFER - the buffer in which the choice should be inserted,
    8156             : BASE-POSITION - where to insert the completion.
    8157             : 
    8158             : If a function in the list returns non-nil, that function is supposed
    8159             : to have inserted the CHOICE in the BUFFER, and possibly exited
    8160             : the minibuffer; no further functions will be called.
    8161             : 
    8162             : If all functions in the list return nil, that means to use
    8163             : the default method of inserting the completion in BUFFER.")
    8164             : 
    8165             : (defun choose-completion-string (choice &optional
    8166             :                                         buffer base-position insert-function)
    8167             :   "Switch to BUFFER and insert the completion choice CHOICE.
    8168             : BASE-POSITION says where to insert the completion.
    8169             : INSERT-FUNCTION says how to insert the completion and falls
    8170             : back on `completion-list-insert-choice-function' when nil."
    8171             : 
    8172             :   ;; If BUFFER is the minibuffer, exit the minibuffer
    8173             :   ;; unless it is reading a file name and CHOICE is a directory,
    8174             :   ;; or completion-no-auto-exit is non-nil.
    8175             : 
    8176             :   ;; Some older code may call us passing `base-size' instead of
    8177             :   ;; `base-position'.  It's difficult to make any use of `base-size',
    8178             :   ;; so we just ignore it.
    8179           0 :   (unless (consp base-position)
    8180           0 :     (message "Obsolete `base-size' passed to choose-completion-string")
    8181           0 :     (setq base-position nil))
    8182             : 
    8183           0 :   (let* ((buffer (or buffer completion-reference-buffer))
    8184           0 :          (mini-p (minibufferp buffer)))
    8185             :     ;; If BUFFER is a minibuffer, barf unless it's the currently
    8186             :     ;; active minibuffer.
    8187           0 :     (if (and mini-p
    8188           0 :              (not (and (active-minibuffer-window)
    8189           0 :                        (equal buffer
    8190           0 :                              (window-buffer (active-minibuffer-window))))))
    8191           0 :         (error "Minibuffer is not active for completion")
    8192             :       ;; Set buffer so buffer-local choose-completion-string-functions works.
    8193           0 :       (set-buffer buffer)
    8194           0 :       (unless (run-hook-with-args-until-success
    8195             :                'choose-completion-string-functions
    8196             :                ;; The fourth arg used to be `mini-p' but was useless
    8197             :                ;; (since minibufferp can be used on the `buffer' arg)
    8198             :                ;; and indeed unused.  The last used to be `base-size', so we
    8199             :                ;; keep it to try and avoid breaking old code.
    8200           0 :                choice buffer base-position nil)
    8201             :         ;; This remove-text-properties should be unnecessary since `choice'
    8202             :         ;; comes from buffer-substring-no-properties.
    8203             :         ;;(remove-text-properties 0 (length choice) '(mouse-face nil) choice)
    8204             :         ;; Insert the completion into the buffer where it was requested.
    8205           0 :         (funcall (or insert-function completion-list-insert-choice-function)
    8206           0 :                  (or (car base-position) (point))
    8207           0 :                  (or (cadr base-position) (point))
    8208           0 :                  choice)
    8209             :         ;; Update point in the window that BUFFER is showing in.
    8210           0 :         (let ((window (get-buffer-window buffer t)))
    8211           0 :           (set-window-point window (point)))
    8212             :         ;; If completing for the minibuffer, exit it with this choice.
    8213           0 :         (and (not completion-no-auto-exit)
    8214           0 :              (minibufferp buffer)
    8215           0 :              minibuffer-completion-table
    8216             :              ;; If this is reading a file name, and the file name chosen
    8217             :              ;; is a directory, don't exit the minibuffer.
    8218           0 :              (let* ((result (buffer-substring (field-beginning) (point)))
    8219             :                     (bounds
    8220           0 :                      (completion-boundaries result minibuffer-completion-table
    8221           0 :                                             minibuffer-completion-predicate
    8222           0 :                                             "")))
    8223           0 :                (if (eq (car bounds) (length result))
    8224             :                    ;; The completion chosen leads to a new set of completions
    8225             :                    ;; (e.g. it's a directory): don't exit the minibuffer yet.
    8226           0 :                    (let ((mini (active-minibuffer-window)))
    8227           0 :                      (select-window mini)
    8228           0 :                      (when minibuffer-auto-raise
    8229           0 :                        (raise-frame (window-frame mini))))
    8230           0 :                  (exit-minibuffer))))))))
    8231             : 
    8232             : (define-derived-mode completion-list-mode nil "Completion List"
    8233             :   "Major mode for buffers showing lists of possible completions.
    8234             : Type \\<completion-list-mode-map>\\[choose-completion] in the completion list\
    8235             :  to select the completion near point.
    8236             : Or click to select one with the mouse.
    8237             : 
    8238             : \\{completion-list-mode-map}"
    8239           0 :   (set (make-local-variable 'completion-base-size) nil))
    8240             : 
    8241             : (defun completion-list-mode-finish ()
    8242             :   "Finish setup of the completions buffer.
    8243             : Called from `temp-buffer-show-hook'."
    8244           0 :   (when (eq major-mode 'completion-list-mode)
    8245           0 :     (setq buffer-read-only t)))
    8246             : 
    8247             : (add-hook 'temp-buffer-show-hook 'completion-list-mode-finish)
    8248             : 
    8249             : 
    8250             : ;; Variables and faces used in `completion-setup-function'.
    8251             : 
    8252             : (defcustom completion-show-help t
    8253             :   "Non-nil means show help message in *Completions* buffer."
    8254             :   :type 'boolean
    8255             :   :version "22.1"
    8256             :   :group 'completion)
    8257             : 
    8258             : ;; This function goes in completion-setup-hook, so that it is called
    8259             : ;; after the text of the completion list buffer is written.
    8260             : (defun completion-setup-function ()
    8261           0 :   (let* ((mainbuf (current-buffer))
    8262             :          (base-dir
    8263             :           ;; FIXME: This is a bad hack.  We try to set the default-directory
    8264             :           ;; in the *Completions* buffer so that the relative file names
    8265             :           ;; displayed there can be treated as valid file names, independently
    8266             :           ;; from the completion context.  But this suffers from many problems:
    8267             :           ;; - It's not clear when the completions are file names.  With some
    8268             :           ;;   completion tables (e.g. bzr revision specs), the listed
    8269             :           ;;   completions can mix file names and other things.
    8270             :           ;; - It doesn't pay attention to possible quoting.
    8271             :           ;; - With fancy completion styles, the code below will not always
    8272             :           ;;   find the right base directory.
    8273           0 :           (if minibuffer-completing-file-name
    8274           0 :               (file-name-as-directory
    8275           0 :                (expand-file-name
    8276           0 :                 (buffer-substring (minibuffer-prompt-end)
    8277           0 :                                   (- (point) (or completion-base-size 0))))))))
    8278           0 :     (with-current-buffer standard-output
    8279           0 :       (let ((base-size completion-base-size) ;Read before killing localvars.
    8280           0 :             (base-position completion-base-position)
    8281           0 :             (insert-fun completion-list-insert-choice-function))
    8282           0 :         (completion-list-mode)
    8283           0 :         (set (make-local-variable 'completion-base-size) base-size)
    8284           0 :         (set (make-local-variable 'completion-base-position) base-position)
    8285           0 :         (set (make-local-variable 'completion-list-insert-choice-function)
    8286           0 :              insert-fun))
    8287           0 :       (set (make-local-variable 'completion-reference-buffer) mainbuf)
    8288           0 :       (if base-dir (setq default-directory base-dir))
    8289             :       ;; Maybe insert help string.
    8290           0 :       (when completion-show-help
    8291           0 :         (goto-char (point-min))
    8292           0 :         (if (display-mouse-p)
    8293           0 :             (insert "Click on a completion to select it.\n"))
    8294           0 :         (insert (substitute-command-keys
    8295             :                  "In this buffer, type \\[choose-completion] to \
    8296           0 : select the completion near point.\n\n"))))))
    8297             : 
    8298             : (add-hook 'completion-setup-hook 'completion-setup-function)
    8299             : 
    8300             : (define-key minibuffer-local-completion-map [prior] 'switch-to-completions)
    8301             : (define-key minibuffer-local-completion-map "\M-v"  'switch-to-completions)
    8302             : 
    8303             : (defun switch-to-completions ()
    8304             :   "Select the completion list window."
    8305             :   (interactive)
    8306           0 :   (let ((window (or (get-buffer-window "*Completions*" 0)
    8307             :                     ;; Make sure we have a completions window.
    8308           0 :                     (progn (minibuffer-completion-help)
    8309           0 :                            (get-buffer-window "*Completions*" 0)))))
    8310           0 :     (when window
    8311           0 :       (select-window window)
    8312             :       ;; In the new buffer, go to the first completion.
    8313             :       ;; FIXME: Perhaps this should be done in `minibuffer-completion-help'.
    8314           0 :       (when (bobp)
    8315           0 :         (next-completion 1)))))
    8316             : 
    8317             : ;;; Support keyboard commands to turn on various modifiers.
    8318             : 
    8319             : ;; These functions -- which are not commands -- each add one modifier
    8320             : ;; to the following event.
    8321             : 
    8322             : (defun event-apply-alt-modifier (_ignore-prompt)
    8323             :   "\\<function-key-map>Add the Alt modifier to the following event.
    8324             : For example, type \\[event-apply-alt-modifier] & to enter Alt-&."
    8325           0 :   (vector (event-apply-modifier (read-event) 'alt 22 "A-")))
    8326             : (defun event-apply-super-modifier (_ignore-prompt)
    8327             :   "\\<function-key-map>Add the Super modifier to the following event.
    8328             : For example, type \\[event-apply-super-modifier] & to enter Super-&."
    8329           0 :   (vector (event-apply-modifier (read-event) 'super 23 "s-")))
    8330             : (defun event-apply-hyper-modifier (_ignore-prompt)
    8331             :   "\\<function-key-map>Add the Hyper modifier to the following event.
    8332             : For example, type \\[event-apply-hyper-modifier] & to enter Hyper-&."
    8333           0 :   (vector (event-apply-modifier (read-event) 'hyper 24 "H-")))
    8334             : (defun event-apply-shift-modifier (_ignore-prompt)
    8335             :   "\\<function-key-map>Add the Shift modifier to the following event.
    8336             : For example, type \\[event-apply-shift-modifier] & to enter Shift-&."
    8337           0 :   (vector (event-apply-modifier (read-event) 'shift 25 "S-")))
    8338             : (defun event-apply-control-modifier (_ignore-prompt)
    8339             :   "\\<function-key-map>Add the Ctrl modifier to the following event.
    8340             : For example, type \\[event-apply-control-modifier] & to enter Ctrl-&."
    8341           0 :   (vector (event-apply-modifier (read-event) 'control 26 "C-")))
    8342             : (defun event-apply-meta-modifier (_ignore-prompt)
    8343             :   "\\<function-key-map>Add the Meta modifier to the following event.
    8344             : For example, type \\[event-apply-meta-modifier] & to enter Meta-&."
    8345           0 :   (vector (event-apply-modifier (read-event) 'meta 27 "M-")))
    8346             : 
    8347             : (defun event-apply-modifier (event symbol lshiftby prefix)
    8348             :   "Apply a modifier flag to event EVENT.
    8349             : SYMBOL is the name of this modifier, as a symbol.
    8350             : LSHIFTBY is the numeric value of this modifier, in keyboard events.
    8351             : PREFIX is the string that represents this modifier in an event type symbol."
    8352           0 :   (if (numberp event)
    8353           0 :       (cond ((eq symbol 'control)
    8354           0 :              (if (and (<= (downcase event) ?z)
    8355           0 :                       (>= (downcase event) ?a))
    8356           0 :                  (- (downcase event) ?a -1)
    8357           0 :                (if (and (<= (downcase event) ?Z)
    8358           0 :                         (>= (downcase event) ?A))
    8359           0 :                    (- (downcase event) ?A -1)
    8360           0 :                  (logior (lsh 1 lshiftby) event))))
    8361           0 :             ((eq symbol 'shift)
    8362           0 :              (if (and (<= (downcase event) ?z)
    8363           0 :                       (>= (downcase event) ?a))
    8364           0 :                  (upcase event)
    8365           0 :                (logior (lsh 1 lshiftby) event)))
    8366             :             (t
    8367           0 :              (logior (lsh 1 lshiftby) event)))
    8368           0 :     (if (memq symbol (event-modifiers event))
    8369           0 :         event
    8370           0 :       (let ((event-type (if (symbolp event) event (car event))))
    8371           0 :         (setq event-type (intern (concat prefix (symbol-name event-type))))
    8372           0 :         (if (symbolp event)
    8373           0 :             event-type
    8374           0 :           (cons event-type (cdr event)))))))
    8375             : 
    8376             : (define-key function-key-map [?\C-x ?@ ?h] 'event-apply-hyper-modifier)
    8377             : (define-key function-key-map [?\C-x ?@ ?s] 'event-apply-super-modifier)
    8378             : (define-key function-key-map [?\C-x ?@ ?m] 'event-apply-meta-modifier)
    8379             : (define-key function-key-map [?\C-x ?@ ?a] 'event-apply-alt-modifier)
    8380             : (define-key function-key-map [?\C-x ?@ ?S] 'event-apply-shift-modifier)
    8381             : (define-key function-key-map [?\C-x ?@ ?c] 'event-apply-control-modifier)
    8382             : 
    8383             : ;;;; Keypad support.
    8384             : 
    8385             : ;; Make the keypad keys act like ordinary typing keys.  If people add
    8386             : ;; bindings for the function key symbols, then those bindings will
    8387             : ;; override these, so this shouldn't interfere with any existing
    8388             : ;; bindings.
    8389             : 
    8390             : ;; Also tell read-char how to handle these keys.
    8391             : (mapc
    8392             :  (lambda (keypad-normal)
    8393             :    (let ((keypad (nth 0 keypad-normal))
    8394             :          (normal (nth 1 keypad-normal)))
    8395             :      (put keypad 'ascii-character normal)
    8396             :      (define-key function-key-map (vector keypad) (vector normal))))
    8397             :  ;; See also kp-keys bound in bindings.el.
    8398             :  '((kp-space ?\s)
    8399             :    (kp-tab ?\t)
    8400             :    (kp-enter ?\r)
    8401             :    (kp-separator ?,)
    8402             :    (kp-equal ?=)
    8403             :    ;; Do the same for various keys that are represented as symbols under
    8404             :    ;; GUIs but naturally correspond to characters.
    8405             :    (backspace 127)
    8406             :    (delete 127)
    8407             :    (tab ?\t)
    8408             :    (linefeed ?\n)
    8409             :    (clear ?\C-l)
    8410             :    (return ?\C-m)
    8411             :    (escape ?\e)
    8412             :    ))
    8413             : 
    8414             : ;;;;
    8415             : ;;;; forking a twin copy of a buffer.
    8416             : ;;;;
    8417             : 
    8418             : (defvar clone-buffer-hook nil
    8419             :   "Normal hook to run in the new buffer at the end of `clone-buffer'.")
    8420             : 
    8421             : (defvar clone-indirect-buffer-hook nil
    8422             :   "Normal hook to run in the new buffer at the end of `clone-indirect-buffer'.")
    8423             : 
    8424             : (defun clone-process (process &optional newname)
    8425             :   "Create a twin copy of PROCESS.
    8426             : If NEWNAME is nil, it defaults to PROCESS' name;
    8427             : NEWNAME is modified by adding or incrementing <N> at the end as necessary.
    8428             : If PROCESS is associated with a buffer, the new process will be associated
    8429             :   with the current buffer instead.
    8430             : Returns nil if PROCESS has already terminated."
    8431           0 :   (setq newname (or newname (process-name process)))
    8432           0 :   (if (string-match "<[0-9]+>\\'" newname)
    8433           0 :       (setq newname (substring newname 0 (match-beginning 0))))
    8434           0 :   (when (memq (process-status process) '(run stop open))
    8435           0 :     (let* ((process-connection-type (process-tty-name process))
    8436             :            (new-process
    8437           0 :             (if (memq (process-status process) '(open))
    8438           0 :                 (let ((args (process-contact process t)))
    8439           0 :                   (setq args (plist-put args :name newname))
    8440           0 :                   (setq args (plist-put args :buffer
    8441           0 :                                         (if (process-buffer process)
    8442           0 :                                             (current-buffer))))
    8443           0 :                   (apply 'make-network-process args))
    8444           0 :               (apply 'start-process newname
    8445           0 :                      (if (process-buffer process) (current-buffer))
    8446           0 :                      (process-command process)))))
    8447           0 :       (set-process-query-on-exit-flag
    8448           0 :        new-process (process-query-on-exit-flag process))
    8449           0 :       (set-process-inherit-coding-system-flag
    8450           0 :        new-process (process-inherit-coding-system-flag process))
    8451           0 :       (set-process-filter new-process (process-filter process))
    8452           0 :       (set-process-sentinel new-process (process-sentinel process))
    8453           0 :       (set-process-plist new-process (copy-sequence (process-plist process)))
    8454           0 :       new-process)))
    8455             : 
    8456             : ;; things to maybe add (currently partly covered by `funcall mode'):
    8457             : ;; - syntax-table
    8458             : ;; - overlays
    8459             : (defun clone-buffer (&optional newname display-flag)
    8460             :   "Create and return a twin copy of the current buffer.
    8461             : Unlike an indirect buffer, the new buffer can be edited
    8462             : independently of the old one (if it is not read-only).
    8463             : NEWNAME is the name of the new buffer.  It may be modified by
    8464             : adding or incrementing <N> at the end as necessary to create a
    8465             : unique buffer name.  If nil, it defaults to the name of the
    8466             : current buffer, with the proper suffix.  If DISPLAY-FLAG is
    8467             : non-nil, the new buffer is shown with `pop-to-buffer'.  Trying to
    8468             : clone a file-visiting buffer, or a buffer whose major mode symbol
    8469             : has a non-nil `no-clone' property, results in an error.
    8470             : 
    8471             : Interactively, DISPLAY-FLAG is t and NEWNAME is the name of the
    8472             : current buffer with appropriate suffix.  However, if a prefix
    8473             : argument is given, then the command prompts for NEWNAME in the
    8474             : minibuffer.
    8475             : 
    8476             : This runs the normal hook `clone-buffer-hook' in the new buffer
    8477             : after it has been set up properly in other respects."
    8478             :   (interactive
    8479           0 :    (progn
    8480           0 :      (if buffer-file-name
    8481           0 :          (error "Cannot clone a file-visiting buffer"))
    8482           0 :      (if (get major-mode 'no-clone)
    8483           0 :          (error "Cannot clone a buffer in %s mode" mode-name))
    8484           0 :      (list (if current-prefix-arg
    8485           0 :                (read-buffer "Name of new cloned buffer: " (current-buffer)))
    8486           0 :            t)))
    8487           0 :   (if buffer-file-name
    8488           0 :       (error "Cannot clone a file-visiting buffer"))
    8489           0 :   (if (get major-mode 'no-clone)
    8490           0 :       (error "Cannot clone a buffer in %s mode" mode-name))
    8491           0 :   (setq newname (or newname (buffer-name)))
    8492           0 :   (if (string-match "<[0-9]+>\\'" newname)
    8493           0 :       (setq newname (substring newname 0 (match-beginning 0))))
    8494           0 :   (let ((buf (current-buffer))
    8495           0 :         (ptmin (point-min))
    8496           0 :         (ptmax (point-max))
    8497           0 :         (pt (point))
    8498           0 :         (mk (if mark-active (mark t)))
    8499           0 :         (modified (buffer-modified-p))
    8500           0 :         (mode major-mode)
    8501           0 :         (lvars (buffer-local-variables))
    8502           0 :         (process (get-buffer-process (current-buffer)))
    8503           0 :         (new (generate-new-buffer (or newname (buffer-name)))))
    8504           0 :     (save-restriction
    8505           0 :       (widen)
    8506           0 :       (with-current-buffer new
    8507           0 :         (insert-buffer-substring buf)))
    8508           0 :     (with-current-buffer new
    8509           0 :       (narrow-to-region ptmin ptmax)
    8510           0 :       (goto-char pt)
    8511           0 :       (if mk (set-mark mk))
    8512           0 :       (set-buffer-modified-p modified)
    8513             : 
    8514             :       ;; Clone the old buffer's process, if any.
    8515           0 :       (when process (clone-process process))
    8516             : 
    8517             :       ;; Now set up the major mode.
    8518           0 :       (funcall mode)
    8519             : 
    8520             :       ;; Set up other local variables.
    8521           0 :       (mapc (lambda (v)
    8522           0 :               (condition-case ()        ;in case var is read-only
    8523           0 :                   (if (symbolp v)
    8524           0 :                       (makunbound v)
    8525           0 :                     (set (make-local-variable (car v)) (cdr v)))
    8526           0 :                 (error nil)))
    8527           0 :             lvars)
    8528             : 
    8529             :       ;; Run any hooks (typically set up by the major mode
    8530             :       ;; for cloning to work properly).
    8531           0 :       (run-hooks 'clone-buffer-hook))
    8532           0 :     (if display-flag
    8533             :         ;; Presumably the current buffer is shown in the selected frame, so
    8534             :         ;; we want to display the clone elsewhere.
    8535           0 :         (let ((same-window-regexps nil)
    8536             :               (same-window-buffer-names))
    8537           0 :           (pop-to-buffer new)))
    8538           0 :     new))
    8539             : 
    8540             : 
    8541             : (defun clone-indirect-buffer (newname display-flag &optional norecord)
    8542             :   "Create an indirect buffer that is a twin copy of the current buffer.
    8543             : 
    8544             : Give the indirect buffer name NEWNAME.  Interactively, read NEWNAME
    8545             : from the minibuffer when invoked with a prefix arg.  If NEWNAME is nil
    8546             : or if not called with a prefix arg, NEWNAME defaults to the current
    8547             : buffer's name.  The name is modified by adding a `<N>' suffix to it
    8548             : or by incrementing the N in an existing suffix.  Trying to clone a
    8549             : buffer whose major mode symbol has a non-nil `no-clone-indirect'
    8550             : property results in an error.
    8551             : 
    8552             : DISPLAY-FLAG non-nil means show the new buffer with `pop-to-buffer'.
    8553             : This is always done when called interactively.
    8554             : 
    8555             : Optional third arg NORECORD non-nil means do not put this buffer at the
    8556             : front of the list of recently selected ones.
    8557             : 
    8558             : Returns the newly created indirect buffer."
    8559             :   (interactive
    8560           0 :    (progn
    8561           0 :      (if (get major-mode 'no-clone-indirect)
    8562           0 :          (error "Cannot indirectly clone a buffer in %s mode" mode-name))
    8563           0 :      (list (if current-prefix-arg
    8564           0 :                (read-buffer "Name of indirect buffer: " (current-buffer)))
    8565           0 :            t)))
    8566           0 :   (if (get major-mode 'no-clone-indirect)
    8567           0 :       (error "Cannot indirectly clone a buffer in %s mode" mode-name))
    8568           0 :   (setq newname (or newname (buffer-name)))
    8569           0 :   (if (string-match "<[0-9]+>\\'" newname)
    8570           0 :       (setq newname (substring newname 0 (match-beginning 0))))
    8571           0 :   (let* ((name (generate-new-buffer-name newname))
    8572           0 :          (buffer (make-indirect-buffer (current-buffer) name t)))
    8573           0 :     (with-current-buffer buffer
    8574           0 :       (run-hooks 'clone-indirect-buffer-hook))
    8575           0 :     (when display-flag
    8576           0 :       (pop-to-buffer buffer nil norecord))
    8577           0 :     buffer))
    8578             : 
    8579             : 
    8580             : (defun clone-indirect-buffer-other-window (newname display-flag &optional norecord)
    8581             :   "Like `clone-indirect-buffer' but display in another window."
    8582             :   (interactive
    8583           0 :    (progn
    8584           0 :      (if (get major-mode 'no-clone-indirect)
    8585           0 :          (error "Cannot indirectly clone a buffer in %s mode" mode-name))
    8586           0 :      (list (if current-prefix-arg
    8587           0 :                (read-buffer "Name of indirect buffer: " (current-buffer)))
    8588           0 :            t)))
    8589           0 :   (let ((pop-up-windows t))
    8590           0 :     (clone-indirect-buffer newname display-flag norecord)))
    8591             : 
    8592             : 
    8593             : ;;; Handling of Backspace and Delete keys.
    8594             : 
    8595             : (defcustom normal-erase-is-backspace 'maybe
    8596             :   "Set the default behavior of the Delete and Backspace keys.
    8597             : 
    8598             : If set to t, Delete key deletes forward and Backspace key deletes
    8599             : backward.
    8600             : 
    8601             : If set to nil, both Delete and Backspace keys delete backward.
    8602             : 
    8603             : If set to `maybe' (which is the default), Emacs automatically
    8604             : selects a behavior.  On window systems, the behavior depends on
    8605             : the keyboard used.  If the keyboard has both a Backspace key and
    8606             : a Delete key, and both are mapped to their usual meanings, the
    8607             : option's default value is set to t, so that Backspace can be used
    8608             : to delete backward, and Delete can be used to delete forward.
    8609             : 
    8610             : If not running under a window system, customizing this option
    8611             : accomplishes a similar effect by mapping C-h, which is usually
    8612             : generated by the Backspace key, to DEL, and by mapping DEL to C-d
    8613             : via `keyboard-translate'.  The former functionality of C-h is
    8614             : available on the F1 key.  You should probably not use this
    8615             : setting if you don't have both Backspace, Delete and F1 keys.
    8616             : 
    8617             : Setting this variable with setq doesn't take effect.  Programmatically,
    8618             : call `normal-erase-is-backspace-mode' (which see) instead."
    8619             :   :type '(choice (const :tag "Off" nil)
    8620             :                  (const :tag "Maybe" maybe)
    8621             :                  (other :tag "On" t))
    8622             :   :group 'editing-basics
    8623             :   :version "21.1"
    8624             :   :set (lambda (symbol value)
    8625             :          ;; The fboundp is because of a problem with :set when
    8626             :          ;; dumping Emacs.  It doesn't really matter.
    8627             :          (if (fboundp 'normal-erase-is-backspace-mode)
    8628             :              (normal-erase-is-backspace-mode (or value 0))
    8629             :            (set-default symbol value))))
    8630             : 
    8631             : (defun normal-erase-is-backspace-setup-frame (&optional frame)
    8632             :   "Set up `normal-erase-is-backspace-mode' on FRAME, if necessary."
    8633           0 :   (unless frame (setq frame (selected-frame)))
    8634           0 :   (with-selected-frame frame
    8635           0 :     (unless (terminal-parameter nil 'normal-erase-is-backspace)
    8636           0 :       (normal-erase-is-backspace-mode
    8637           0 :        (if (if (eq normal-erase-is-backspace 'maybe)
    8638           0 :                (and (not noninteractive)
    8639           0 :                     (or (memq system-type '(ms-dos windows-nt))
    8640           0 :                         (memq window-system '(w32 ns))
    8641           0 :                         (and (memq window-system '(x))
    8642           0 :                              (fboundp 'x-backspace-delete-keys-p)
    8643           0 :                              (x-backspace-delete-keys-p))
    8644             :                         ;; If the terminal Emacs is running on has erase char
    8645             :                         ;; set to ^H, use the Backspace key for deleting
    8646             :                         ;; backward, and the Delete key for deleting forward.
    8647           0 :                         (and (null window-system)
    8648           0 :                              (eq tty-erase-char ?\^H))))
    8649           0 :              normal-erase-is-backspace)
    8650           0 :            1 0)))))
    8651             : 
    8652             : (define-minor-mode normal-erase-is-backspace-mode
    8653             :   "Toggle the Erase and Delete mode of the Backspace and Delete keys.
    8654             : With a prefix argument ARG, enable this feature if ARG is
    8655             : positive, and disable it otherwise.  If called from Lisp, enable
    8656             : the mode if ARG is omitted or nil.
    8657             : 
    8658             : On window systems, when this mode is on, Delete is mapped to C-d
    8659             : and Backspace is mapped to DEL; when this mode is off, both
    8660             : Delete and Backspace are mapped to DEL.  (The remapping goes via
    8661             : `local-function-key-map', so binding Delete or Backspace in the
    8662             : global or local keymap will override that.)
    8663             : 
    8664             : In addition, on window systems, the bindings of C-Delete, M-Delete,
    8665             : C-M-Delete, C-Backspace, M-Backspace, and C-M-Backspace are changed in
    8666             : the global keymap in accordance with the functionality of Delete and
    8667             : Backspace.  For example, if Delete is remapped to C-d, which deletes
    8668             : forward, C-Delete is bound to `kill-word', but if Delete is remapped
    8669             : to DEL, which deletes backward, C-Delete is bound to
    8670             : `backward-kill-word'.
    8671             : 
    8672             : If not running on a window system, a similar effect is accomplished by
    8673             : remapping C-h (normally produced by the Backspace key) and DEL via
    8674             : `keyboard-translate': if this mode is on, C-h is mapped to DEL and DEL
    8675             : to C-d; if it's off, the keys are not remapped.
    8676             : 
    8677             : When not running on a window system, and this mode is turned on, the
    8678             : former functionality of C-h is available on the F1 key.  You should
    8679             : probably not turn on this mode on a text-only terminal if you don't
    8680             : have both Backspace, Delete and F1 keys.
    8681             : 
    8682             : See also `normal-erase-is-backspace'."
    8683             :   :variable ((eq (terminal-parameter nil 'normal-erase-is-backspace) 1)
    8684             :              . (lambda (v)
    8685             :                  (setf (terminal-parameter nil 'normal-erase-is-backspace)
    8686             :                        (if v 1 0))))
    8687           0 :   (let ((enabled (eq 1 (terminal-parameter
    8688           0 :                         nil 'normal-erase-is-backspace))))
    8689             : 
    8690           0 :     (cond ((or (memq window-system '(x w32 ns pc))
    8691           0 :                (memq system-type '(ms-dos windows-nt)))
    8692           0 :            (let ((bindings
    8693           0 :                   `(([M-delete] [M-backspace])
    8694             :                     ([C-M-delete] [C-M-backspace])
    8695           0 :                     ([?\e C-delete] [?\e C-backspace]))))
    8696             : 
    8697           0 :              (if enabled
    8698           0 :                  (progn
    8699           0 :                    (define-key local-function-key-map [delete] [deletechar])
    8700           0 :                    (define-key local-function-key-map [kp-delete] [deletechar])
    8701           0 :                    (define-key local-function-key-map [backspace] [?\C-?])
    8702           0 :                    (dolist (b bindings)
    8703             :                      ;; Not sure if input-decode-map is really right, but
    8704             :                      ;; keyboard-translate-table (used below) only works
    8705             :                      ;; for integer events, and key-translation-table is
    8706             :                      ;; global (like the global-map, used earlier).
    8707           0 :                      (define-key input-decode-map (car b) nil)
    8708           0 :                      (define-key input-decode-map (cadr b) nil)))
    8709           0 :                (define-key local-function-key-map [delete] [?\C-?])
    8710           0 :                (define-key local-function-key-map [kp-delete] [?\C-?])
    8711           0 :                (define-key local-function-key-map [backspace] [?\C-?])
    8712           0 :                (dolist (b bindings)
    8713           0 :                  (define-key input-decode-map (car b) (cadr b))
    8714           0 :                  (define-key input-decode-map (cadr b) (car b))))))
    8715             :           (t
    8716           0 :            (if enabled
    8717           0 :                (progn
    8718           0 :                  (keyboard-translate ?\C-h ?\C-?)
    8719           0 :                  (keyboard-translate ?\C-? ?\C-d))
    8720           0 :              (keyboard-translate ?\C-h ?\C-h)
    8721           0 :              (keyboard-translate ?\C-? ?\C-?))))
    8722             : 
    8723           0 :     (if (called-interactively-p 'interactive)
    8724           0 :         (message "Delete key deletes %s"
    8725           0 :                  (if (eq 1 (terminal-parameter nil 'normal-erase-is-backspace))
    8726           0 :                      "forward" "backward")))))
    8727             : 
    8728             : (defvar vis-mode-saved-buffer-invisibility-spec nil
    8729             :   "Saved value of `buffer-invisibility-spec' when Visible mode is on.")
    8730             : 
    8731             : (define-minor-mode read-only-mode
    8732             :   "Change whether the current buffer is read-only.
    8733             : With prefix argument ARG, make the buffer read-only if ARG is
    8734             : positive, otherwise make it writable.  If buffer is read-only
    8735             : and `view-read-only' is non-nil, enter view mode.
    8736             : 
    8737             : Do not call this from a Lisp program unless you really intend to
    8738             : do the same thing as the \\[read-only-mode] command, including
    8739             : possibly enabling or disabling View mode.  Also, note that this
    8740             : command works by setting the variable `buffer-read-only', which
    8741             : does not affect read-only regions caused by text properties.  To
    8742             : ignore read-only status in a Lisp program (whether due to text
    8743             : properties or buffer state), bind `inhibit-read-only' temporarily
    8744             : to a non-nil value."
    8745             :   :variable buffer-read-only
    8746           0 :   (cond
    8747           0 :    ((and (not buffer-read-only) view-mode)
    8748           0 :     (View-exit-and-edit)
    8749           0 :     (make-local-variable 'view-read-only)
    8750           0 :     (setq view-read-only t))            ; Must leave view mode.
    8751           0 :    ((and buffer-read-only view-read-only
    8752             :          ;; If view-mode is already active, `view-mode-enter' is a nop.
    8753           0 :          (not view-mode)
    8754           0 :          (not (eq (get major-mode 'mode-class) 'special)))
    8755           0 :     (view-mode-enter))))
    8756             : 
    8757             : (define-minor-mode visible-mode
    8758             :   "Toggle making all invisible text temporarily visible (Visible mode).
    8759             : With a prefix argument ARG, enable Visible mode if ARG is
    8760             : positive, and disable it otherwise.  If called from Lisp, enable
    8761             : the mode if ARG is omitted or nil.
    8762             : 
    8763             : This mode works by saving the value of `buffer-invisibility-spec'
    8764             : and setting it to nil."
    8765             :   :lighter " Vis"
    8766             :   :group 'editing-basics
    8767           0 :   (when (local-variable-p 'vis-mode-saved-buffer-invisibility-spec)
    8768           0 :     (setq buffer-invisibility-spec vis-mode-saved-buffer-invisibility-spec)
    8769           0 :     (kill-local-variable 'vis-mode-saved-buffer-invisibility-spec))
    8770           0 :   (when visible-mode
    8771           0 :     (set (make-local-variable 'vis-mode-saved-buffer-invisibility-spec)
    8772           0 :          buffer-invisibility-spec)
    8773           0 :     (setq buffer-invisibility-spec nil)))
    8774             : 
    8775             : (defvar messages-buffer-mode-map
    8776             :   (let ((map (make-sparse-keymap)))
    8777             :     (set-keymap-parent map special-mode-map)
    8778             :     (define-key map "g" nil)            ; nothing to revert
    8779             :     map))
    8780             : 
    8781             : (define-derived-mode messages-buffer-mode special-mode "Messages"
    8782             :   "Major mode used in the \"*Messages*\" buffer.")
    8783             : 
    8784             : (defun messages-buffer ()
    8785             :   "Return the \"*Messages*\" buffer.
    8786             : If it does not exist, create and it switch it to `messages-buffer-mode'."
    8787         159 :   (or (get-buffer "*Messages*")
    8788           0 :       (with-current-buffer (get-buffer-create "*Messages*")
    8789           0 :         (messages-buffer-mode)
    8790         159 :         (current-buffer))))
    8791             : 
    8792             : 
    8793             : ;; Minibuffer prompt stuff.
    8794             : 
    8795             : ;;(defun minibuffer-prompt-modification (start end)
    8796             : ;;  (error "You cannot modify the prompt"))
    8797             : ;;
    8798             : ;;
    8799             : ;;(defun minibuffer-prompt-insertion (start end)
    8800             : ;;  (let ((inhibit-modification-hooks t))
    8801             : ;;    (delete-region start end)
    8802             : ;;    ;; Discard undo information for the text insertion itself
    8803             : ;;    ;; and for the text deletion.above.
    8804             : ;;    (when (consp buffer-undo-list)
    8805             : ;;      (setq buffer-undo-list (cddr buffer-undo-list)))
    8806             : ;;    (message "You cannot modify the prompt")))
    8807             : ;;
    8808             : ;;
    8809             : ;;(setq minibuffer-prompt-properties
    8810             : ;;  (list 'modification-hooks '(minibuffer-prompt-modification)
    8811             : ;;      'insert-in-front-hooks '(minibuffer-prompt-insertion)))
    8812             : 
    8813             : 
    8814             : ;;;; Problematic external packages.
    8815             : 
    8816             : ;; rms says this should be done by specifying symbols that define
    8817             : ;; versions together with bad values.  This is therefore not as
    8818             : ;; flexible as it could be.  See the thread:
    8819             : ;; http://lists.gnu.org/archive/html/emacs-devel/2007-08/msg00300.html
    8820             : (defconst bad-packages-alist
    8821             :   ;; Not sure exactly which semantic versions have problems.
    8822             :   ;; Definitely 2.0pre3, probably all 2.0pre's before this.
    8823             :   '((semantic semantic-version "\\`2\\.0pre[1-3]\\'"
    8824             :               "The version of `semantic' loaded does not work in Emacs 22.
    8825             : It can cause constant high CPU load.
    8826             : Upgrade to at least Semantic 2.0pre4 (distributed with CEDET 1.0pre4).")
    8827             :     ;; CUA-mode does not work with GNU Emacs version 22.1 and newer.
    8828             :     ;; Except for version 1.2, all of the 1.x and 2.x version of cua-mode
    8829             :     ;; provided the `CUA-mode' feature.  Since this is no longer true,
    8830             :     ;; we can warn the user if the `CUA-mode' feature is ever provided.
    8831             :     (CUA-mode t nil
    8832             : "CUA-mode is now part of the standard GNU Emacs distribution,
    8833             : so you can now enable CUA via the Options menu or by customizing `cua-mode'.
    8834             : 
    8835             : You have loaded an older version of CUA-mode which does not work
    8836             : correctly with this version of Emacs.  You should remove the old
    8837             : version and use the one distributed with Emacs."))
    8838             :   "Alist of packages known to cause problems in this version of Emacs.
    8839             : Each element has the form (PACKAGE SYMBOL REGEXP STRING).
    8840             : PACKAGE is either a regular expression to match file names, or a
    8841             : symbol (a feature name), like for `with-eval-after-load'.
    8842             : SYMBOL is either the name of a string variable, or t.  Upon
    8843             : loading PACKAGE, if SYMBOL is t or matches REGEXP, display a
    8844             : warning using STRING as the message.")
    8845             : 
    8846             : (defun bad-package-check (package)
    8847             :   "Run a check using the element from `bad-packages-alist' matching PACKAGE."
    8848           0 :   (condition-case nil
    8849           0 :       (let* ((list (assoc package bad-packages-alist))
    8850           0 :              (symbol (nth 1 list)))
    8851           0 :         (and list
    8852           0 :              (boundp symbol)
    8853           0 :              (or (eq symbol t)
    8854           0 :                  (and (stringp (setq symbol (eval symbol)))
    8855           0 :                       (string-match-p (nth 2 list) symbol)))
    8856           0 :              (display-warning package (nth 3 list) :warning)))
    8857           0 :     (error nil)))
    8858             : 
    8859             : (dolist (elem bad-packages-alist)
    8860             :   (let ((pkg (car elem)))
    8861             :     (with-eval-after-load pkg
    8862             :       (bad-package-check pkg))))
    8863             : 
    8864             : 
    8865             : ;;; Generic dispatcher commands
    8866             : 
    8867             : ;; Macro `define-alternatives' is used to create generic commands.
    8868             : ;; Generic commands are these (like web, mail, news, encrypt, irc, etc.)
    8869             : ;; that can have different alternative implementations where choosing
    8870             : ;; among them is exclusively a matter of user preference.
    8871             : 
    8872             : ;; (define-alternatives COMMAND) creates a new interactive command
    8873             : ;; M-x COMMAND and a customizable variable COMMAND-alternatives.
    8874             : ;; Typically, the user will not need to customize this variable; packages
    8875             : ;; wanting to add alternative implementations should use
    8876             : ;;
    8877             : ;; ;;;###autoload (push '("My impl name" . my-impl-symbol) COMMAND-alternatives
    8878             : 
    8879             : (defmacro define-alternatives (command &rest customizations)
    8880             :   "Define the new command `COMMAND'.
    8881             : 
    8882             : The argument `COMMAND' should be a symbol.
    8883             : 
    8884             : Running `M-x COMMAND RET' for the first time prompts for which
    8885             : alternative to use and records the selected command as a custom
    8886             : variable.
    8887             : 
    8888             : Running `C-u M-x COMMAND RET' prompts again for an alternative
    8889             : and overwrites the previous choice.
    8890             : 
    8891             : The variable `COMMAND-alternatives' contains an alist with
    8892             : alternative implementations of COMMAND.  `define-alternatives'
    8893             : does not have any effect until this variable is set.
    8894             : 
    8895             : CUSTOMIZATIONS, if non-nil, should be composed of alternating
    8896             : `defcustom' keywords and values to add to the declaration of
    8897             : `COMMAND-alternatives' (typically :group and :version)."
    8898           0 :   (let* ((command-name (symbol-name command))
    8899           0 :          (varalt-name (concat command-name "-alternatives"))
    8900           0 :          (varalt-sym (intern varalt-name))
    8901           0 :          (varimp-sym (intern (concat command-name "--implementation"))))
    8902           0 :     `(progn
    8903             : 
    8904           0 :        (defcustom ,varalt-sym nil
    8905           0 :          ,(format "Alist of alternative implementations for the `%s' command.
    8906             : 
    8907             : Each entry must be a pair (ALTNAME . ALTFUN), where:
    8908             : ALTNAME - The name shown at user to describe the alternative implementation.
    8909             : ALTFUN  - The function called to implement this alternative."
    8910           0 :                   command-name)
    8911             :          :type '(alist :key-type string :value-type function)
    8912           0 :          ,@customizations)
    8913             : 
    8914           0 :        (put ',varalt-sym 'definition-name ',command)
    8915           0 :        (defvar ,varimp-sym nil "Internal use only.")
    8916             : 
    8917           0 :        (defun ,command (&optional arg)
    8918           0 :          ,(format "Run generic command `%s'.
    8919             : If used for the first time, or with interactive ARG, ask the user which
    8920             : implementation to use for `%s'.  The variable `%s'
    8921             : contains the list of implementations currently supported for this command."
    8922           0 :                   command-name command-name varalt-name)
    8923             :          (interactive "P")
    8924           0 :          (when (or arg (null ,varimp-sym))
    8925             :            (let ((val (completing-read
    8926           0 :                        ,(format-message
    8927             :                          "Select implementation for command `%s': "
    8928           0 :                          command-name)
    8929           0 :                        ,varalt-sym nil t)))
    8930             :              (unless (string-equal val "")
    8931           0 :                (when (null ,varimp-sym)
    8932             :                  (message
    8933             :                   "Use C-u M-x %s RET`to select another implementation"
    8934           0 :                   ,command-name)
    8935             :                  (sit-for 3))
    8936           0 :                (customize-save-variable ',varimp-sym
    8937           0 :                                         (cdr (assoc-string val ,varalt-sym))))))
    8938           0 :          (if ,varimp-sym
    8939           0 :              (call-interactively ,varimp-sym)
    8940           0 :            (message "%s" ,(format-message
    8941             :                            "No implementation selected for command `%s'"
    8942           0 :                            command-name)))))))
    8943             : 
    8944             : 
    8945             : ;;; Functions for changing capitalization that Do What I Mean
    8946             : (defun upcase-dwim (arg)
    8947             :   "Upcase words in the region, if active; if not, upcase word at point.
    8948             : If the region is active, this function calls `upcase-region'.
    8949             : Otherwise, it calls `upcase-word', with prefix argument passed to it
    8950             : to upcase ARG words."
    8951             :   (interactive "*p")
    8952           0 :   (if (use-region-p)
    8953           0 :       (upcase-region (region-beginning) (region-end))
    8954           0 :     (upcase-word arg)))
    8955             : 
    8956             : (defun downcase-dwim (arg)
    8957             :     "Downcase words in the region, if active; if not, downcase word at point.
    8958             : If the region is active, this function calls `downcase-region'.
    8959             : Otherwise, it calls `downcase-word', with prefix argument passed to it
    8960             : to downcase ARG words."
    8961             :   (interactive "*p")
    8962           0 :   (if (use-region-p)
    8963           0 :       (downcase-region (region-beginning) (region-end))
    8964           0 :     (downcase-word arg)))
    8965             : 
    8966             : (defun capitalize-dwim (arg)
    8967             :   "Capitalize words in the region, if active; if not, capitalize word at point.
    8968             : If the region is active, this function calls `capitalize-region'.
    8969             : Otherwise, it calls `capitalize-word', with prefix argument passed to it
    8970             : to capitalize ARG words."
    8971             :   (interactive "*p")
    8972           0 :   (if (use-region-p)
    8973           0 :       (capitalize-region (region-beginning) (region-end))
    8974           0 :     (capitalize-word arg)))
    8975             : 
    8976             : 
    8977             : 
    8978             : (provide 'simple)
    8979             : 
    8980             : ;;; simple.el ends here

Generated by: LCOV version 1.12