Created
June 10, 2020 17:21
-
-
Save linktohack/142faeae523fdbf0df1e752ac61ddfeb to your computer and use it in GitHub Desktop.
Tramp thread safe
This file contains hidden or bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
| ;;; files.el --- file input and output commands for Emacs -*- lexical-binding:t -*- | |
| ;; Copyright (C) 1985-1987, 1992-2020 Free Software Foundation, Inc. | |
| ;; Maintainer: [email protected] | |
| ;; Package: emacs | |
| ;; This file is part of GNU Emacs. | |
| ;; GNU Emacs is free software: you can redistribute it and/or modify | |
| ;; it under the terms of the GNU General Public License as published by | |
| ;; the Free Software Foundation, either version 3 of the License, or | |
| ;; (at your option) any later version. | |
| ;; GNU Emacs is distributed in the hope that it will be useful, | |
| ;; but WITHOUT ANY WARRANTY; without even the implied warranty of | |
| ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
| ;; GNU General Public License for more details. | |
| ;; You should have received a copy of the GNU General Public License | |
| ;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. | |
| ;;; Commentary: | |
| ;; Defines most of Emacs's file- and directory-handling functions, | |
| ;; including basic file visiting, backup generation, link handling, | |
| ;; ITS-id version control, load- and write-hook handling, and the like. | |
| ;;; Code: | |
| (eval-when-compile | |
| (require 'pcase) | |
| (require 'easy-mmode)) ; For `define-minor-mode'. | |
| (defvar font-lock-keywords) | |
| (defgroup backup nil | |
| "Backups of edited data files." | |
| :group 'files) | |
| (defgroup find-file nil | |
| "Finding files." | |
| :group 'files) | |
| (defcustom delete-auto-save-files t | |
| "Non-nil means delete auto-save file when a buffer is saved or killed. | |
| Note that the auto-save file will not be deleted if the buffer is killed | |
| when it has unsaved changes." | |
| :type 'boolean | |
| :group 'auto-save) | |
| (defcustom directory-abbrev-alist | |
| nil | |
| "Alist of abbreviations for file directories. | |
| A list of elements of the form (FROM . TO), each meaning to replace | |
| a match for FROM with TO when a directory name matches FROM. This | |
| replacement is done when setting up the default directory of a | |
| newly visited file buffer. | |
| FROM is a regexp that is matched against directory names anchored at | |
| the first character, so it should start with a \"\\\\\\=`\", or, if | |
| directory names cannot have embedded newlines, with a \"^\". | |
| FROM and TO should be equivalent names, which refer to the | |
| same directory. TO should be an absolute directory name. | |
| Do not use `~' in the TO strings. | |
| Use this feature when you have directories that you normally refer to | |
| via absolute symbolic links. Make TO the name of the link, and FROM | |
| a regexp matching the name it is linked to." | |
| :type '(repeat (cons :format "%v" | |
| :value ("\\`" . "") | |
| (regexp :tag "From") | |
| (string :tag "To"))) | |
| :group 'abbrev | |
| :group 'find-file) | |
| (defcustom make-backup-files t | |
| "Non-nil means make a backup of a file the first time it is saved. | |
| This can be done by renaming the file or by copying. | |
| Renaming means that Emacs renames the existing file so that it is a | |
| backup file, then writes the buffer into a new file. Any other names | |
| that the old file had will now refer to the backup file. The new file | |
| is owned by you and its group is defaulted. | |
| Copying means that Emacs copies the existing file into the backup | |
| file, then writes the buffer on top of the existing file. Any other | |
| names that the old file had will now refer to the new (edited) file. | |
| The file's owner and group are unchanged. | |
| The choice of renaming or copying is controlled by the variables | |
| `backup-by-copying', `backup-by-copying-when-linked', | |
| `backup-by-copying-when-mismatch' and | |
| `backup-by-copying-when-privileged-mismatch'. See also `backup-inhibited'." | |
| :type 'boolean | |
| :group 'backup) | |
| ;; Do this so that local variables based on the file name | |
| ;; are not overridden by the major mode. | |
| (defvar backup-inhibited nil | |
| "If non-nil, backups will be inhibited. | |
| This variable is intended for use by making it local to a buffer, | |
| but it is not an automatically buffer-local variable.") | |
| (put 'backup-inhibited 'permanent-local t) | |
| (defcustom backup-by-copying nil | |
| "Non-nil means always use copying to create backup files. | |
| See documentation of variable `make-backup-files'." | |
| :type 'boolean | |
| :group 'backup) | |
| (defcustom backup-by-copying-when-linked nil | |
| "Non-nil means use copying to create backups for files with multiple names. | |
| This causes the alternate names to refer to the latest version as edited. | |
| This variable is relevant only if `backup-by-copying' is nil." | |
| :type 'boolean | |
| :group 'backup) | |
| (defcustom backup-by-copying-when-mismatch t | |
| "Non-nil means create backups by copying if this preserves owner or group. | |
| Renaming may still be used (subject to control of other variables) | |
| when it would not result in changing the owner or group of the file; | |
| that is, for files that are owned by you and whose group matches | |
| the default for a new file created there by you. | |
| This variable is relevant only if `backup-by-copying' is nil." | |
| :version "24.1" | |
| :type 'boolean | |
| :group 'backup) | |
| (put 'backup-by-copying-when-mismatch 'permanent-local t) | |
| (defcustom backup-by-copying-when-privileged-mismatch 200 | |
| "Non-nil means create backups by copying to preserve a privileged owner. | |
| Renaming may still be used (subject to control of other variables) | |
| when it would not result in changing the owner of the file or if the | |
| user id and group id of the file are both greater than the value of | |
| this variable. This is useful when low-numbered uid's and gid's are | |
| used for special system users (such as root) that must maintain | |
| ownership of certain files. | |
| This variable is relevant only if `backup-by-copying' and | |
| `backup-by-copying-when-mismatch' are nil." | |
| :type '(choice (const nil) integer) | |
| :group 'backup) | |
| (defvar backup-enable-predicate 'normal-backup-enable-predicate | |
| "Predicate that looks at a file name and decides whether to make backups. | |
| Called with an absolute file name as argument, it returns t to enable backup.") | |
| (defcustom buffer-offer-save nil | |
| "Non-nil in a buffer means always offer to save buffer on exiting Emacs. | |
| Do so even if the buffer is not visiting a file. | |
| Automatically local in all buffers. | |
| Set to the symbol `always' to offer to save buffer whenever | |
| `save-some-buffers' is called. | |
| Note that this option has no effect on `kill-buffer'; | |
| if you want to control what happens when a buffer is killed, | |
| use `kill-buffer-query-functions'." | |
| :type '(choice (const :tag "Never" nil) | |
| (const :tag "On Emacs exit" t) | |
| (const :tag "Whenever save-some-buffers is called" always)) | |
| :group 'backup) | |
| (make-variable-buffer-local 'buffer-offer-save) | |
| (put 'buffer-offer-save 'permanent-local t) | |
| (defcustom find-file-existing-other-name t | |
| "Non-nil means find a file under alternative names, in existing buffers. | |
| This means if any existing buffer is visiting the file you want | |
| under another name, you get the existing buffer instead of a new buffer." | |
| :type 'boolean | |
| :group 'find-file) | |
| (defcustom find-file-visit-truename nil | |
| "Non-nil means visiting a file uses its truename as the visited-file name. | |
| That is, the buffer visiting the file has the truename as the | |
| value of `buffer-file-name'. The truename of a file is found by | |
| chasing all links both at the file level and at the levels of the | |
| containing directories." | |
| :type 'boolean | |
| :group 'find-file) | |
| (defcustom revert-without-query nil | |
| "Specify which files should be reverted without query. | |
| The value is a list of regular expressions. | |
| If the file name matches one of these regular expressions, | |
| then `revert-buffer' reverts the file without querying | |
| if the file has changed on disk and you have not edited the buffer." | |
| :type '(repeat regexp) | |
| :group 'find-file) | |
| (defvar buffer-file-number nil | |
| "The device number and file number of the file visited in the current buffer. | |
| The value is a list of the form (FILENUM DEVNUM). | |
| This pair of numbers uniquely identifies the file. | |
| If the buffer is visiting a new file, the value is nil.") | |
| (make-variable-buffer-local 'buffer-file-number) | |
| (put 'buffer-file-number 'permanent-local t) | |
| (defvar buffer-file-numbers-unique (not (memq system-type '(windows-nt))) | |
| "Non-nil means that `buffer-file-number' uniquely identifies files.") | |
| (defvar buffer-file-read-only nil | |
| "Non-nil if visited file was read-only when visited.") | |
| (make-variable-buffer-local 'buffer-file-read-only) | |
| (defcustom small-temporary-file-directory | |
| (if (eq system-type 'ms-dos) (getenv "TMPDIR")) | |
| "The directory for writing small temporary files. | |
| If non-nil, this directory is used instead of `temporary-file-directory' | |
| by programs that create small temporary files. This is for systems that | |
| have fast storage with limited space, such as a RAM disk." | |
| :group 'files | |
| :initialize 'custom-initialize-delay | |
| :type '(choice (const nil) directory)) | |
| ;; The system null device. (Should reference NULL_DEVICE from C.) | |
| (defvar null-device (purecopy "/dev/null") "The system null device.") | |
| (declare-function msdos-long-file-names "msdos.c") | |
| (declare-function w32-long-file-name "w32proc.c") | |
| (declare-function dired-get-filename "dired" (&optional localp no-error-if-not-filep)) | |
| (declare-function dired-unmark "dired" (arg &optional interactive)) | |
| (declare-function dired-do-flagged-delete "dired" (&optional nomessage)) | |
| (declare-function dos-8+3-filename "dos-fns" (filename)) | |
| (declare-function dosified-file-name "dos-fns" (file-name)) | |
| (defvar file-name-invalid-regexp | |
| (cond ((and (eq system-type 'ms-dos) (not (msdos-long-file-names))) | |
| (purecopy | |
| (concat "^\\([^A-Z[-`a-z]\\|..+\\)?:\\|" ; colon except after drive | |
| "[+, ;=|<>\"?*]\\|\\[\\|\\]\\|" ; invalid characters | |
| "[\000-\037]\\|" ; control characters | |
| "\\(/\\.\\.?[^/]\\)\\|" ; leading dots | |
| "\\(/[^/.]+\\.[^/.]*\\.\\)"))) ; more than a single dot | |
| ((memq system-type '(ms-dos windows-nt cygwin)) | |
| (purecopy | |
| (concat "^\\([^A-Z[-`a-z]\\|..+\\)?:\\|" ; colon except after drive | |
| "[|<>\"?*\000-\037]"))) ; invalid characters | |
| (t (purecopy "[\000]"))) | |
| "Regexp recognizing file names that aren't allowed by the filesystem.") | |
| (defcustom file-precious-flag nil | |
| "Non-nil means protect against I/O errors while saving files. | |
| Some modes set this non-nil in particular buffers. | |
| This feature works by writing the new contents into a temporary file | |
| and then renaming the temporary file to replace the original. | |
| In this way, any I/O error in writing leaves the original untouched, | |
| and there is never any instant where the file is nonexistent. | |
| Note that this feature forces backups to be made by copying. | |
| Yet, at the same time, saving a precious file | |
| breaks any hard links between it and other files. | |
| This feature is advisory: for example, if the directory in which the | |
| file is being saved is not writable, Emacs may ignore a non-nil value | |
| of `file-precious-flag' and write directly into the file. | |
| See also: `break-hardlink-on-save'." | |
| :type 'boolean | |
| :group 'backup) | |
| (defcustom break-hardlink-on-save nil | |
| "Whether to allow breaking hardlinks when saving files. | |
| If non-nil, then when saving a file that exists under several | |
| names \(i.e., has multiple hardlinks), break the hardlink | |
| associated with `buffer-file-name' and write to a new file, so | |
| that the other instances of the file are not affected by the | |
| save. | |
| If `buffer-file-name' refers to a symlink, do not break the symlink. | |
| Unlike `file-precious-flag', `break-hardlink-on-save' is not advisory. | |
| For example, if the directory in which a file is being saved is not | |
| itself writable, then error instead of saving in some | |
| hardlink-nonbreaking way. | |
| See also `backup-by-copying' and `backup-by-copying-when-linked'." | |
| :type 'boolean | |
| :group 'files | |
| :version "23.1") | |
| (defcustom version-control nil | |
| "Control use of version numbers for backup files. | |
| When t, make numeric backup versions unconditionally. | |
| When nil, make them for files that have some already. | |
| The value `never' means do not make them." | |
| :type '(choice (const :tag "Never" never) | |
| (const :tag "If existing" nil) | |
| (other :tag "Always" t)) | |
| :group 'backup) | |
| (defun version-control-safe-local-p (x) | |
| "Return whether X is safe as local value for `version-control'." | |
| (or (booleanp x) (equal x 'never))) | |
| (put 'version-control 'safe-local-variable | |
| #'version-control-safe-local-p) | |
| (defcustom dired-kept-versions 2 | |
| "When cleaning directory, number of versions to keep." | |
| :type 'integer | |
| :group 'backup | |
| :group 'dired) | |
| (defcustom delete-old-versions nil | |
| "If t, delete excess backup versions silently. | |
| If nil, ask confirmation. Any other value prevents any trimming." | |
| :type '(choice (const :tag "Delete" t) | |
| (const :tag "Ask" nil) | |
| (other :tag "Leave" other)) | |
| :group 'backup) | |
| (defcustom kept-old-versions 2 | |
| "Number of oldest versions to keep when a new numbered backup is made." | |
| :type 'integer | |
| :group 'backup) | |
| (put 'kept-old-versions 'safe-local-variable 'integerp) | |
| (defcustom kept-new-versions 2 | |
| "Number of newest versions to keep when a new numbered backup is made. | |
| Includes the new backup. Must be greater than 0." | |
| :type 'integer | |
| :group 'backup) | |
| (put 'kept-new-versions 'safe-local-variable 'integerp) | |
| (defcustom require-final-newline nil | |
| "Whether to add a newline automatically at the end of the file. | |
| A value of t means do this only when the file is about to be saved. | |
| A value of `visit' means do this right after the file is visited. | |
| A value of `visit-save' means do it at both of those times. | |
| Any other non-nil value means ask user whether to add a newline, when saving. | |
| A value of nil means don't add newlines. | |
| Certain major modes set this locally to the value obtained | |
| from `mode-require-final-newline'. | |
| This variable is heeded only when visiting files (or saving | |
| buffers into files they visit). Writing data to the file system | |
| with `write-region' and the like is not influenced by this variable." | |
| :safe #'symbolp | |
| :type '(choice (const :tag "When visiting" visit) | |
| (const :tag "When saving" t) | |
| (const :tag "When visiting or saving" visit-save) | |
| (const :tag "Don't add newlines" nil) | |
| (other :tag "Ask each time" ask)) | |
| :group 'editing-basics) | |
| (defcustom mode-require-final-newline t | |
| "Whether to add a newline at end of file, in certain major modes. | |
| Those modes set `require-final-newline' to this value when you enable them. | |
| They do so because they are often used for files that are supposed | |
| to end in newlines, and the question is how to arrange that. | |
| A value of t means do this only when the file is about to be saved. | |
| A value of `visit' means do this right after the file is visited. | |
| A value of `visit-save' means do it at both of those times. | |
| Any other non-nil value means ask user whether to add a newline, when saving. | |
| A value of nil means do not add newlines. That is a risky choice in this | |
| variable since this value is used for modes for files that ought to have | |
| final newlines. So if you set this to nil, you must explicitly check and | |
| add a final newline, whenever you save a file that really needs one." | |
| :type '(choice (const :tag "When visiting" visit) | |
| (const :tag "When saving" t) | |
| (const :tag "When visiting or saving" visit-save) | |
| (const :tag "Don't add newlines" nil) | |
| (other :tag "Ask each time" ask)) | |
| :group 'editing-basics | |
| :version "22.1") | |
| (defcustom auto-save-default t | |
| "Non-nil says by default do auto-saving of every file-visiting buffer." | |
| :type 'boolean | |
| :group 'auto-save) | |
| (defcustom auto-save-file-name-transforms | |
| `(("\\`/[^/]*:\\([^/]*/\\)*\\([^/]*\\)\\'" | |
| ;; Don't put "\\2" inside expand-file-name, since it will be | |
| ;; transformed to "/2" on DOS/Windows. | |
| ,(concat temporary-file-directory "\\2") t)) | |
| "Transforms to apply to buffer file name before making auto-save file name. | |
| Each transform is a list (REGEXP REPLACEMENT UNIQUIFY): | |
| REGEXP is a regular expression to match against the file name. | |
| If it matches, `replace-match' is used to replace the | |
| matching part with REPLACEMENT. | |
| If the optional element UNIQUIFY is non-nil, the auto-save file name is | |
| constructed by taking the directory part of the replaced file-name, | |
| concatenated with the buffer file name with all directory separators | |
| changed to `!' to prevent clashes. This will not work | |
| correctly if your filesystem truncates the resulting name. | |
| All the transforms in the list are tried, in the order they are listed. | |
| When one transform applies, its result is final; | |
| no further transforms are tried. | |
| The default value is set up to put the auto-save file into the | |
| temporary directory (see the variable `temporary-file-directory') for | |
| editing a remote file. | |
| On MS-DOS filesystems without long names this variable is always | |
| ignored." | |
| :group 'auto-save | |
| :type '(repeat (list (regexp :tag "Regexp") (string :tag "Replacement") | |
| (boolean :tag "Uniquify"))) | |
| :initialize 'custom-initialize-delay | |
| :version "21.1") | |
| (defvar auto-save--timer nil "Timer for `auto-save-visited-mode'.") | |
| (defcustom auto-save-visited-interval 5 | |
| "Interval in seconds for `auto-save-visited-mode'. | |
| If `auto-save-visited-mode' is enabled, Emacs will save all | |
| buffers visiting a file to the visited file after it has been | |
| idle for `auto-save-visited-interval' seconds." | |
| :group 'auto-save | |
| :type 'number | |
| :version "26.1" | |
| :set (lambda (symbol value) | |
| (set-default symbol value) | |
| (when auto-save--timer | |
| (timer-set-idle-time auto-save--timer value :repeat)))) | |
| (define-minor-mode auto-save-visited-mode | |
| "Toggle automatic saving to file-visiting buffers on or off. | |
| Unlike `auto-save-mode', this mode will auto-save buffer contents | |
| to the visited files directly and will also run all save-related | |
| hooks. See Info node `Saving' for details of the save process." | |
| :group 'auto-save | |
| :global t | |
| (when auto-save--timer (cancel-timer auto-save--timer)) | |
| (setq auto-save--timer | |
| (when auto-save-visited-mode | |
| (run-with-idle-timer | |
| auto-save-visited-interval :repeat | |
| #'save-some-buffers :no-prompt | |
| (lambda () | |
| (and buffer-file-name | |
| (not (and buffer-auto-save-file-name | |
| auto-save-visited-file-name)))))))) | |
| ;; The 'set' part is so we don't get a warning for using this variable | |
| ;; above, while still catching code that _sets_ the variable to get | |
| ;; the same effect as the new auto-save-visited-mode. | |
| (make-obsolete-variable 'auto-save-visited-file-name 'auto-save-visited-mode | |
| "Emacs 26.1" 'set) | |
| (defcustom save-abbrevs t | |
| "Non-nil means save word abbrevs too when files are saved. | |
| If `silently', don't ask the user before saving." | |
| :type '(choice (const t) (const nil) (const silently)) | |
| :group 'abbrev) | |
| (defcustom find-file-run-dired t | |
| "Non-nil means allow `find-file' to visit directories. | |
| To visit the directory, `find-file' runs `find-directory-functions'." | |
| :type 'boolean | |
| :group 'find-file) | |
| (defcustom find-directory-functions '(cvs-dired-noselect dired-noselect) | |
| "List of functions to try in sequence to visit a directory. | |
| Each function is called with the directory name as the sole argument | |
| and should return either a buffer or nil." | |
| :type '(hook :options (cvs-dired-noselect dired-noselect)) | |
| :group 'find-file) | |
| ;; FIXME: also add a hook for `(thing-at-point 'filename)' | |
| (defcustom file-name-at-point-functions '(ffap-guess-file-name-at-point) | |
| "List of functions to try in sequence to get a file name at point. | |
| Each function should return either nil or a file name found at the | |
| location of point in the current buffer." | |
| :type '(hook :options (ffap-guess-file-name-at-point)) | |
| :group 'find-file) | |
| ;;;It is not useful to make this a local variable. | |
| ;;;(put 'find-file-not-found-functions 'permanent-local t) | |
| (define-obsolete-variable-alias 'find-file-not-found-hooks | |
| 'find-file-not-found-functions "22.1") | |
| (defvar find-file-not-found-functions nil | |
| "List of functions to be called for `find-file' on nonexistent file. | |
| These functions are called as soon as the error is detected. | |
| Variable `buffer-file-name' is already set up. | |
| The functions are called in the order given until one of them returns non-nil.") | |
| ;;;It is not useful to make this a local variable. | |
| ;;;(put 'find-file-hook 'permanent-local t) | |
| ;; I found some external files still using the obsolete form in 2018. | |
| (define-obsolete-variable-alias 'find-file-hooks 'find-file-hook "22.1") | |
| (defcustom find-file-hook nil | |
| "List of functions to be called after a buffer is loaded from a file. | |
| The buffer's local variables (if any) will have been processed before the | |
| functions are called. This includes directory-local variables, if any, | |
| for the file's directory." | |
| :group 'find-file | |
| :type 'hook | |
| :options '(auto-insert) | |
| :version "22.1") | |
| ;; I found some external files still using the obsolete form in 2018. | |
| (define-obsolete-variable-alias 'write-file-hooks 'write-file-functions "22.1") | |
| (defvar write-file-functions nil | |
| "List of functions to be called before saving a buffer to a file. | |
| Used only by `save-buffer'. | |
| If one of them returns non-nil, the file is considered already written | |
| and the rest are not called. | |
| These hooks are considered to pertain to the visited file. | |
| So any buffer-local binding of this variable is discarded if you change | |
| the visited file name with \\[set-visited-file-name], but not when you | |
| change the major mode. | |
| This hook is not run if any of the functions in | |
| `write-contents-functions' returns non-nil. Both hooks pertain | |
| to how to save a buffer to file, for instance, choosing a suitable | |
| coding system and setting mode bits. (See Info | |
| node `(elisp)Saving Buffers'.) To perform various checks or | |
| updates before the buffer is saved, use `before-save-hook'.") | |
| (put 'write-file-functions 'permanent-local t) | |
| ;; I found some files still using the obsolete form in 2018. | |
| (defvar local-write-file-hooks nil) | |
| (make-variable-buffer-local 'local-write-file-hooks) | |
| (put 'local-write-file-hooks 'permanent-local t) | |
| (make-obsolete-variable 'local-write-file-hooks 'write-file-functions "22.1") | |
| ;; I found some files still using the obsolete form in 2018. | |
| (define-obsolete-variable-alias 'write-contents-hooks | |
| 'write-contents-functions "22.1") | |
| (defvar write-contents-functions nil | |
| "List of functions to be called before writing out a buffer to a file. | |
| Used only by `save-buffer'. If one of them returns non-nil, the | |
| file is considered already written and the rest are not called | |
| and neither are the functions in `write-file-functions'. This | |
| hook can thus be used to create save behavior for buffers that | |
| are not visiting a file at all. | |
| This variable is meant to be used for hooks that pertain to the | |
| buffer's contents, not to the particular visited file; thus, | |
| `set-visited-file-name' does not clear this variable; but changing the | |
| major mode does clear it. | |
| For hooks that _do_ pertain to the particular visited file, use | |
| `write-file-functions'. Both this variable and | |
| `write-file-functions' relate to how a buffer is saved to file. | |
| To perform various checks or updates before the buffer is saved, | |
| use `before-save-hook'.") | |
| (make-variable-buffer-local 'write-contents-functions) | |
| (defcustom enable-local-variables t | |
| "Control use of local variables in files you visit. | |
| The value can be t, nil, :safe, :all, or something else. | |
| A value of t means file local variables specifications are obeyed | |
| if all the specified variable values are safe; if any values are | |
| not safe, Emacs queries you, once, whether to set them all. | |
| \(When you say yes to certain values, they are remembered as safe.) | |
| :safe means set the safe variables, and ignore the rest. | |
| :all means set all variables, whether safe or not. | |
| (Don't set it permanently to :all.) | |
| A value of nil means always ignore the file local variables. | |
| Any other value means always query you once whether to set them all. | |
| \(When you say yes to certain values, they are remembered as safe, but | |
| this has no effect when `enable-local-variables' is \"something else\".) | |
| This variable also controls use of major modes specified in | |
| a -*- line. | |
| The command \\[normal-mode], when used interactively, | |
| always obeys file local variable specifications and the -*- line, | |
| and ignores this variable." | |
| :risky t | |
| :type '(choice (const :tag "Query Unsafe" t) | |
| (const :tag "Safe Only" :safe) | |
| (const :tag "Do all" :all) | |
| (const :tag "Ignore" nil) | |
| (other :tag "Query" other)) | |
| :group 'find-file) | |
| (defvar enable-dir-local-variables t | |
| "Non-nil means enable use of directory-local variables. | |
| Some modes may wish to set this to nil to prevent directory-local | |
| settings being applied, but still respect file-local ones.") | |
| ;; This is an odd variable IMO. | |
| ;; You might wonder why it is needed, when we could just do: | |
| ;; (set (make-local-variable 'enable-local-variables) nil) | |
| ;; These two are not precisely the same. | |
| ;; Setting this variable does not cause -*- mode settings to be | |
| ;; ignored, whereas setting enable-local-variables does. | |
| ;; Only three places in Emacs use this variable: tar and arc modes, | |
| ;; and rmail. The first two don't need it. They already use | |
| ;; inhibit-local-variables-regexps, which is probably enough, and | |
| ;; could also just set enable-local-variables locally to nil. | |
| ;; Them setting it has the side-effect that dir-locals cannot apply to | |
| ;; eg tar files (?). FIXME Is this appropriate? | |
| ;; AFAICS, rmail is the only thing that needs this, and the only | |
| ;; reason it uses it is for BABYL files (which are obsolete). | |
| ;; These contain "-*- rmail -*-" in the first line, which rmail wants | |
| ;; to respect, so that find-file on a BABYL file will switch to | |
| ;; rmail-mode automatically (this is nice, but hardly essential, | |
| ;; since most people are used to explicitly running a command to | |
| ;; access their mail; M-x gnus etc). Rmail files may happen to | |
| ;; contain Local Variables sections in messages, which Rmail wants to | |
| ;; ignore. So AFAICS the only reason this variable exists is for a | |
| ;; minor convenience feature for handling of an obsolete Rmail file format. | |
| (defvar local-enable-local-variables t | |
| "Like `enable-local-variables', except for major mode in a -*- line. | |
| The meaningful values are nil and non-nil. The default is non-nil. | |
| It should be set in a buffer-local fashion. | |
| Setting this to nil has the same effect as setting `enable-local-variables' | |
| to nil, except that it does not ignore any mode: setting in a -*- line. | |
| Unless this difference matters to you, you should set `enable-local-variables' | |
| instead of this variable.") | |
| (defcustom enable-local-eval 'maybe | |
| "Control processing of the \"variable\" `eval' in a file's local variables. | |
| The value can be t, nil or something else. | |
| A value of t means obey `eval' variables. | |
| A value of nil means ignore them; anything else means query." | |
| :risky t | |
| :type '(choice (const :tag "Obey" t) | |
| (const :tag "Ignore" nil) | |
| (other :tag "Query" other)) | |
| :group 'find-file) | |
| (defcustom view-read-only nil | |
| "Non-nil means buffers visiting files read-only do so in view mode. | |
| In fact, this means that all read-only buffers normally have | |
| View mode enabled, including buffers that are read-only because | |
| you visit a file you cannot alter, and buffers you make read-only | |
| using \\[read-only-mode]." | |
| :type 'boolean | |
| :group 'view) | |
| (defvar file-name-history nil | |
| "History list of file names entered in the minibuffer. | |
| Maximum length of the history list is determined by the value | |
| of `history-length', which see.") | |
| (defvar save-silently nil | |
| "If non-nil, avoid messages when saving files. | |
| Error-related messages will still be printed, but all other | |
| messages will not.") | |
| (put 'ange-ftp-completion-hook-function 'safe-magic t) | |
| (defun ange-ftp-completion-hook-function (op &rest args) | |
| "Provides support for ange-ftp host name completion. | |
| Runs the usual ange-ftp hook, but only for completion operations." | |
| ;; Having this here avoids the need to load ange-ftp when it's not | |
| ;; really in use. | |
| (if (memq op '(file-name-completion file-name-all-completions)) | |
| (apply 'ange-ftp-hook-function op args) | |
| (let ((inhibit-file-name-handlers | |
| (cons 'ange-ftp-completion-hook-function | |
| (and (eq inhibit-file-name-operation op) | |
| inhibit-file-name-handlers))) | |
| (inhibit-file-name-operation op)) | |
| (apply op args)))) | |
| (declare-function dos-convert-standard-filename "dos-fns.el" (filename)) | |
| (declare-function w32-convert-standard-filename "w32-fns.el" (filename)) | |
| (defun convert-standard-filename (filename) | |
| "Convert a standard file's name to something suitable for the OS. | |
| This means to guarantee valid names and perhaps to canonicalize | |
| certain patterns. | |
| FILENAME should be an absolute file name since the conversion rules | |
| sometimes vary depending on the position in the file name. E.g. c:/foo | |
| is a valid DOS file name, but c:/bar/c:/foo is not. | |
| This function's standard definition is trivial; it just returns | |
| the argument. However, on Windows and DOS, replace invalid | |
| characters. On DOS, make sure to obey the 8.3 limitations. | |
| In the native Windows build, turn Cygwin names into native names. | |
| See Info node `(elisp)Standard File Names' for more details." | |
| (cond | |
| ((eq system-type 'cygwin) | |
| (let ((name (copy-sequence filename)) | |
| (start 0)) | |
| ;; Replace invalid filename characters with ! | |
| (while (string-match "[?*:<>|\"\000-\037]" name start) | |
| (aset name (match-beginning 0) ?!) | |
| (setq start (match-end 0))) | |
| name)) | |
| ((eq system-type 'windows-nt) | |
| (w32-convert-standard-filename filename)) | |
| ((eq system-type 'ms-dos) | |
| (dos-convert-standard-filename filename)) | |
| (t filename))) | |
| (defun read-directory-name (prompt &optional dir default-dirname mustmatch initial) | |
| "Read directory name, prompting with PROMPT and completing in directory DIR. | |
| Value is not expanded---you must call `expand-file-name' yourself. | |
| Default name to DEFAULT-DIRNAME if user exits with the same | |
| non-empty string that was inserted by this function. | |
| (If DEFAULT-DIRNAME is omitted, DIR combined with INITIAL is used, | |
| or just DIR if INITIAL is nil.) | |
| If the user exits with an empty minibuffer, this function returns | |
| an empty string. (This can happen only if the user erased the | |
| pre-inserted contents or if `insert-default-directory' is nil.) | |
| Fourth arg MUSTMATCH non-nil means require existing directory's name. | |
| Non-nil and non-t means also require confirmation after completion. | |
| Fifth arg INITIAL specifies text to start with. | |
| DIR should be an absolute directory name. It defaults to | |
| the value of `default-directory'." | |
| (unless dir | |
| (setq dir default-directory)) | |
| (read-file-name prompt dir (or default-dirname | |
| (if initial (expand-file-name initial dir) | |
| dir)) | |
| mustmatch initial | |
| 'file-directory-p)) | |
| (defun pwd (&optional insert) | |
| "Show the current default directory. | |
| With prefix argument INSERT, insert the current default directory | |
| at point instead." | |
| (interactive "P") | |
| (if insert | |
| (insert default-directory) | |
| (message "Directory %s" default-directory))) | |
| (defvar cd-path nil | |
| "Value of the CDPATH environment variable, as a list. | |
| Not actually set up until the first time you use it.") | |
| (defun parse-colon-path (search-path) | |
| "Explode a search path into a list of directory names. | |
| Directories are separated by `path-separator' (which is colon in | |
| GNU and Unix systems). Substitute environment variables into the | |
| resulting list of directory names. For an empty path element (i.e., | |
| a leading or trailing separator, or two adjacent separators), return | |
| nil (meaning `default-directory') as the associated list element." | |
| (when (stringp search-path) | |
| (mapcar (lambda (f) | |
| (if (equal "" f) nil | |
| (substitute-in-file-name (file-name-as-directory f)))) | |
| (split-string search-path path-separator)))) | |
| (defun cd-absolute (dir) | |
| "Change current directory to given absolute file name DIR." | |
| ;; Put the name into directory syntax now, | |
| ;; because otherwise expand-file-name may give some bad results. | |
| (setq dir (file-name-as-directory dir)) | |
| ;; We used to additionally call abbreviate-file-name here, for an | |
| ;; unknown reason. Problem is that most buffers are setup | |
| ;; without going through cd-absolute and don't call | |
| ;; abbreviate-file-name on their default-directory, so the few that | |
| ;; do end up using a superficially different directory. | |
| (setq dir (expand-file-name dir)) | |
| (if (not (file-directory-p dir)) | |
| (error (if (file-exists-p dir) | |
| "%s is not a directory" | |
| "%s: no such directory") | |
| dir) | |
| (unless (file-accessible-directory-p dir) | |
| (error "Cannot cd to %s: Permission denied" dir)) | |
| (setq default-directory dir) | |
| (setq list-buffers-directory dir))) | |
| (defun cd (dir) | |
| "Make DIR become the current buffer's default directory. | |
| If your environment includes a `CDPATH' variable, try each one of | |
| that list of directories (separated by occurrences of | |
| `path-separator') when resolving a relative directory name. | |
| The path separator is colon in GNU and GNU-like systems." | |
| (interactive | |
| (list | |
| ;; FIXME: There's a subtle bug in the completion below. Seems linked | |
| ;; to a fundamental difficulty of implementing `predicate' correctly. | |
| ;; The manifestation is that TAB may list non-directories in the case where | |
| ;; those files also correspond to valid directories (if your cd-path is (A/ | |
| ;; B/) and you have A/a a file and B/a a directory, then both `a' and `a/' | |
| ;; will be listed as valid completions). | |
| ;; This is because `a' (listed because of A/a) is indeed a valid choice | |
| ;; (which will lead to the use of B/a). | |
| (minibuffer-with-setup-hook | |
| (lambda () | |
| (setq-local minibuffer-completion-table | |
| (apply-partially #'locate-file-completion-table | |
| cd-path nil)) | |
| (setq-local minibuffer-completion-predicate | |
| (lambda (dir) | |
| (locate-file dir cd-path nil | |
| (lambda (f) (and (file-directory-p f) 'dir-ok)))))) | |
| (unless cd-path | |
| (setq cd-path (or (parse-colon-path (getenv "CDPATH")) | |
| (list "./")))) | |
| (read-directory-name "Change default directory: " | |
| default-directory default-directory | |
| t)))) | |
| (unless cd-path | |
| (setq cd-path (or (parse-colon-path (getenv "CDPATH")) | |
| (list "./")))) | |
| (cd-absolute | |
| (or | |
| ;; locate-file doesn't support remote file names, so detect them | |
| ;; and support them here by hand. | |
| (and (file-remote-p (expand-file-name dir)) | |
| (file-accessible-directory-p (expand-file-name dir)) | |
| (expand-file-name dir)) | |
| (locate-file dir cd-path nil | |
| (lambda (f) (and (file-directory-p f) 'dir-ok))) | |
| (error "No such directory found via CDPATH environment variable")))) | |
| (defun directory-files-recursively (dir regexp | |
| &optional include-directories predicate | |
| follow-symlinks) | |
| "Return list of all files under DIR that have file names matching REGEXP. | |
| This function works recursively. Files are returned in \"depth | |
| first\" order, and files from each directory are sorted in | |
| alphabetical order. Each file name appears in the returned list | |
| in its absolute form. | |
| Optional argument INCLUDE-DIRECTORIES non-nil means also include | |
| in the output directories whose names match REGEXP. | |
| PREDICATE can be either nil (which means that all subdirectories | |
| are descended into), t (which means that subdirectories that | |
| can't be read are ignored), or a function (which is called with | |
| the name of the subdirectory and should return non-nil if the | |
| subdirectory is to be descended into). | |
| If FOLLOW-SYMLINKS, symbolic links that point to directories are | |
| followed. Note that this can lead to infinite recursion." | |
| (let* ((result nil) | |
| (files nil) | |
| (dir (directory-file-name dir)) | |
| ;; When DIR is "/", remote file names like "/method:" could | |
| ;; also be offered. We shall suppress them. | |
| (tramp-mode (and tramp-mode (file-remote-p (expand-file-name dir))))) | |
| (dolist (file (sort (file-name-all-completions "" dir) | |
| 'string<)) | |
| (unless (member file '("./" "../")) | |
| (if (directory-name-p file) | |
| (let* ((leaf (substring file 0 (1- (length file)))) | |
| (full-file (concat dir "/" leaf))) | |
| ;; Don't follow symlinks to other directories. | |
| (when (and (or (not (file-symlink-p full-file)) | |
| (and (file-symlink-p full-file) | |
| follow-symlinks)) | |
| ;; Allow filtering subdirectories. | |
| (or (eq predicate nil) | |
| (eq predicate t) | |
| (funcall predicate full-file))) | |
| (let ((sub-files | |
| (if (eq predicate t) | |
| (ignore-error file-error | |
| (directory-files-recursively | |
| full-file regexp include-directories | |
| predicate follow-symlinks)) | |
| (directory-files-recursively | |
| full-file regexp include-directories | |
| predicate follow-symlinks)))) | |
| (setq result (nconc result sub-files)))) | |
| (when (and include-directories | |
| (string-match regexp leaf)) | |
| (setq result (nconc result (list full-file))))) | |
| (when (string-match regexp file) | |
| (push (concat dir "/" file) files))))) | |
| (nconc result (nreverse files)))) | |
| (defvar module-file-suffix) | |
| (defun load-file (file) | |
| "Load the Lisp file named FILE." | |
| ;; This is a case where .elc and .so/.dll make a lot of sense. | |
| (interactive (list (let ((completion-ignored-extensions | |
| (remove module-file-suffix | |
| (remove ".elc" | |
| completion-ignored-extensions)))) | |
| (read-file-name "Load file: " nil nil 'lambda)))) | |
| (load (expand-file-name file) nil nil t)) | |
| (defun locate-file (filename path &optional suffixes predicate) | |
| "Search for FILENAME through PATH. | |
| If found, return the absolute file name of FILENAME; otherwise | |
| return nil. | |
| PATH should be a list of directories to look in, like the lists in | |
| `exec-path' or `load-path'. | |
| If SUFFIXES is non-nil, it should be a list of suffixes to append to | |
| file name when searching. If SUFFIXES is nil, it is equivalent to (\"\"). | |
| Use (\"/\") to disable PATH search, but still try the suffixes in SUFFIXES. | |
| If non-nil, PREDICATE is used instead of `file-readable-p'. | |
| This function will normally skip directories, so if you want it to find | |
| directories, make sure the PREDICATE function returns `dir-ok' for them. | |
| PREDICATE can also be an integer to pass to the `access' system call, | |
| in which case file name handlers are ignored. This usage is deprecated. | |
| For compatibility, PREDICATE can also be one of the symbols | |
| `executable', `readable', `writable', or `exists', or a list of | |
| one or more of those symbols." | |
| (if (and predicate (symbolp predicate) (not (functionp predicate))) | |
| (setq predicate (list predicate))) | |
| (when (and (consp predicate) (not (functionp predicate))) | |
| (setq predicate | |
| (logior (if (memq 'executable predicate) 1 0) | |
| (if (memq 'writable predicate) 2 0) | |
| (if (memq 'readable predicate) 4 0)))) | |
| (locate-file-internal filename path suffixes predicate)) | |
| (defun locate-file-completion-table (dirs suffixes string pred action) | |
| "Do completion for file names passed to `locate-file'." | |
| (cond | |
| ((file-name-absolute-p string) | |
| ;; FIXME: maybe we should use completion-file-name-table instead, | |
| ;; tho at least for `load', the arg is passed through | |
| ;; substitute-in-file-name for historical reasons. | |
| (read-file-name-internal string pred action)) | |
| ((eq (car-safe action) 'boundaries) | |
| (let ((suffix (cdr action))) | |
| `(boundaries | |
| ,(length (file-name-directory string)) | |
| ,@(let ((x (file-name-directory suffix))) | |
| (if x (1- (length x)) (length suffix)))))) | |
| (t | |
| (let ((names '()) | |
| ;; If we have files like "foo.el" and "foo.elc", we could load one of | |
| ;; them with "foo.el", "foo.elc", or "foo", where just "foo" is the | |
| ;; preferred way. So if we list all 3, that gives a lot of redundant | |
| ;; entries for the poor soul looking just for "foo". OTOH, sometimes | |
| ;; the user does want to pay attention to the extension. We try to | |
| ;; diffuse this tension by stripping the suffix, except when the | |
| ;; result is a single element (i.e. usually we list only "foo" unless | |
| ;; it's the only remaining element in the list, in which case we do | |
| ;; list "foo", "foo.elc" and "foo.el"). | |
| (fullnames '()) | |
| (suffix (concat (regexp-opt suffixes t) "\\'")) | |
| (string-dir (file-name-directory string)) | |
| (string-file (file-name-nondirectory string))) | |
| (dolist (dir dirs) | |
| (unless dir | |
| (setq dir default-directory)) | |
| (if string-dir (setq dir (expand-file-name string-dir dir))) | |
| (when (file-directory-p dir) | |
| (dolist (file (file-name-all-completions | |
| string-file dir)) | |
| (if (not (string-match suffix file)) | |
| (push file names) | |
| (push file fullnames) | |
| (push (substring file 0 (match-beginning 0)) names))))) | |
| ;; Switching from names to names+fullnames creates a non-monotonicity | |
| ;; which can cause problems with things like partial-completion. | |
| ;; To minimize the problem, filter out completion-regexp-list, so that | |
| ;; M-x load-library RET t/x.e TAB finds some files. Also remove elements | |
| ;; from `names' that matched `string' only when they still had | |
| ;; their suffix. | |
| (setq names (all-completions string-file names)) | |
| ;; Remove duplicates of the first element, so that we can easily check | |
| ;; if `names' really contains only a single element. | |
| (when (cdr names) (setcdr names (delete (car names) (cdr names)))) | |
| (unless (cdr names) | |
| ;; There's no more than one matching non-suffixed element, so expand | |
| ;; the list by adding the suffixed elements as well. | |
| (setq names (nconc names fullnames))) | |
| (completion-table-with-context | |
| string-dir names string-file pred action))))) | |
| (defun locate-file-completion (string path-and-suffixes action) | |
| "Do completion for file names passed to `locate-file'. | |
| PATH-AND-SUFFIXES is a pair of lists, (DIRECTORIES . SUFFIXES)." | |
| (declare (obsolete locate-file-completion-table "23.1")) | |
| (locate-file-completion-table (car path-and-suffixes) | |
| (cdr path-and-suffixes) | |
| string nil action)) | |
| (defvar locate-dominating-stop-dir-regexp | |
| (purecopy "\\`\\(?:[\\/][\\/][^\\/]+[\\/]\\|/\\(?:net\\|afs\\|\\.\\.\\.\\)/\\)\\'") | |
| "Regexp of directory names that stop the search in `locate-dominating-file'. | |
| Any directory whose name matches this regexp will be treated like | |
| a kind of root directory by `locate-dominating-file', which will stop its | |
| search when it bumps into it. | |
| The default regexp prevents fruitless and time-consuming attempts to find | |
| special files in directories in which filenames are interpreted as hostnames, | |
| or mount points potentially requiring authentication as a different user.") | |
| (defun locate-dominating-file (file name) | |
| "Starting at FILE, look up directory hierarchy for directory containing NAME. | |
| FILE can be a file or a directory. If it's a file, its directory will | |
| serve as the starting point for searching the hierarchy of directories. | |
| Stop at the first parent directory containing a file NAME, | |
| and return the directory. Return nil if not found. | |
| Instead of a string, NAME can also be a predicate taking one argument | |
| \(a directory) and returning a non-nil value if that directory is the one for | |
| which we're looking. The predicate will be called with every file/directory | |
| the function needs to examine, starting with FILE." | |
| ;; Represent /home/luser/foo as ~/foo so that we don't try to look for | |
| ;; `name' in /home or in /. | |
| (setq file (abbreviate-file-name (expand-file-name file))) | |
| (let ((root nil) | |
| try) | |
| (while (not (or root | |
| (null file) | |
| (string-match locate-dominating-stop-dir-regexp file))) | |
| (setq try (if (stringp name) | |
| (and (file-directory-p file) | |
| (file-exists-p (expand-file-name name file))) | |
| (funcall name file))) | |
| (cond (try (setq root file)) | |
| ((equal file (setq file (file-name-directory | |
| (directory-file-name file)))) | |
| (setq file nil)))) | |
| (if root (file-name-as-directory root)))) | |
| (defcustom user-emacs-directory-warning t | |
| "Non-nil means warn if cannot access `user-emacs-directory'. | |
| Set this to nil at your own risk..." | |
| :type 'boolean | |
| :group 'initialization | |
| :version "24.4") | |
| (defun locate-user-emacs-file (new-name &optional old-name) | |
| "Return an absolute per-user Emacs-specific file name. | |
| If NEW-NAME exists in `user-emacs-directory', return it. | |
| Else if OLD-NAME is non-nil and ~/OLD-NAME exists, return ~/OLD-NAME. | |
| Else return NEW-NAME in `user-emacs-directory', creating the | |
| directory if it does not exist." | |
| (convert-standard-filename | |
| (let* ((home (concat "~" (or init-file-user ""))) | |
| (at-home (and old-name (expand-file-name old-name home))) | |
| (bestname (abbreviate-file-name | |
| (expand-file-name new-name user-emacs-directory)))) | |
| (if (and at-home (not (file-readable-p bestname)) | |
| (file-readable-p at-home)) | |
| at-home | |
| ;; Make sure `user-emacs-directory' exists, | |
| ;; unless we're in batch mode or dumping Emacs. | |
| (or noninteractive | |
| dump-mode | |
| (let (errtype) | |
| (if (file-directory-p user-emacs-directory) | |
| (or (file-accessible-directory-p user-emacs-directory) | |
| (setq errtype "access")) | |
| (with-file-modes ?\700 | |
| (condition-case nil | |
| (make-directory user-emacs-directory t) | |
| (error (setq errtype "create"))))) | |
| (when (and errtype | |
| user-emacs-directory-warning | |
| (not (get 'user-emacs-directory-warning 'this-session))) | |
| ;; Warn only once per Emacs session. | |
| (put 'user-emacs-directory-warning 'this-session t) | |
| (display-warning 'initialization | |
| (format "\ | |
| Unable to %s `user-emacs-directory' (%s). | |
| Any data that would normally be written there may be lost! | |
| If you never want to see this message again, | |
| customize the variable `user-emacs-directory-warning'." | |
| errtype user-emacs-directory))))) | |
| bestname)))) | |
| (defun exec-path () | |
| "Return list of directories to search programs to run in remote subprocesses. | |
| The remote host is identified by `default-directory'. For remote | |
| hosts that do not support subprocesses, this returns `nil'. | |
| If `default-directory' is a local directory, this function returns | |
| the value of the variable `exec-path'." | |
| (let ((handler (find-file-name-handler default-directory 'exec-path))) | |
| (if handler | |
| (funcall handler 'exec-path) | |
| exec-path))) | |
| (defun executable-find (command &optional remote) | |
| "Search for COMMAND in `exec-path' and return the absolute file name. | |
| Return nil if COMMAND is not found anywhere in `exec-path'. If | |
| REMOTE is non-nil, search on the remote host indicated by | |
| `default-directory' instead." | |
| (if (and remote (file-remote-p default-directory)) | |
| (let ((res (locate-file | |
| command | |
| (mapcar | |
| (lambda (x) (concat (file-remote-p default-directory) x)) | |
| (exec-path)) | |
| exec-suffixes 'file-executable-p))) | |
| (when (stringp res) (file-local-name res))) | |
| ;; Use 1 rather than file-executable-p to better match the | |
| ;; behavior of call-process. | |
| (let ((default-directory (file-name-quote default-directory 'top))) | |
| (locate-file command exec-path exec-suffixes 1)))) | |
| (defun load-library (library) | |
| "Load the Emacs Lisp library named LIBRARY. | |
| LIBRARY should be a string. | |
| This is an interface to the function `load'. LIBRARY is searched | |
| for in `load-path', both with and without `load-suffixes' (as | |
| well as `load-file-rep-suffixes'). | |
| See Info node `(emacs)Lisp Libraries' for more details. | |
| See `load-file' for a different interface to `load'." | |
| (interactive | |
| (let (completion-ignored-extensions) | |
| (list (completing-read "Load library: " | |
| (apply-partially 'locate-file-completion-table | |
| load-path | |
| (get-load-suffixes)))))) | |
| (load library)) | |
| (defun file-remote-p (file &optional identification connected) | |
| "Test whether FILE specifies a location on a remote system. | |
| A file is considered remote if accessing it is likely to | |
| be slower or less reliable than accessing local files. | |
| `file-remote-p' never opens a new remote connection. It can | |
| reuse only a connection that is already open. | |
| Return nil or a string identifying the remote connection | |
| \(ideally a prefix of FILE). Return nil if FILE is a relative | |
| file name. | |
| When IDENTIFICATION is nil, the returned string is a complete | |
| remote identifier: with components method, user, and host. The | |
| components are those present in FILE, with defaults filled in for | |
| any that are missing. | |
| IDENTIFICATION can specify which part of the identification to | |
| return. IDENTIFICATION can be the symbol `method', `user', | |
| `host', or `localname'. Any other value is handled like nil and | |
| means to return the complete identification. The string returned | |
| for IDENTIFICATION `localname' can differ depending on whether | |
| there is an existing connection. | |
| If CONNECTED is non-nil, return an identification only if FILE is | |
| located on a remote system and a connection is established to | |
| that remote system. | |
| Tip: You can use this expansion of remote identifier components | |
| to derive a new remote file name from an existing one. For | |
| example, if FILE is \"/sudo::/path/to/file\" then | |
| (concat (file-remote-p FILE) \"/bin/sh\") | |
| returns a remote file name for file \"/bin/sh\" that has the | |
| same remote identifier as FILE but expanded; a name such as | |
| \"/sudo:root@myhost:/bin/sh\"." | |
| (let ((handler (find-file-name-handler file 'file-remote-p))) | |
| (if handler | |
| (funcall handler 'file-remote-p file identification connected) | |
| nil))) | |
| ;; Probably this entire variable should be obsolete now, in favor of | |
| ;; something Tramp-related (?). It is not used in many places. | |
| ;; It's not clear what the best file for this to be in is, but given | |
| ;; it uses custom-initialize-delay, it is easier if it is preloaded | |
| ;; rather than autoloaded. | |
| (defcustom remote-shell-program | |
| ;; This used to try various hard-coded places for remsh, rsh, and | |
| ;; rcmd, trying to guess based on location whether "rsh" was | |
| ;; "restricted shell" or "remote shell", but I don't see the point | |
| ;; in this day and age. Almost everyone will use ssh, and have | |
| ;; whatever command they want to use in PATH. | |
| (purecopy | |
| (let ((list '("ssh" "remsh" "rcmd" "rsh"))) | |
| (while (and list | |
| (not (executable-find (car list))) | |
| (setq list (cdr list)))) | |
| (or (car list) "ssh"))) | |
| "Program to use to execute commands on a remote host (e.g. ssh or rsh)." | |
| :version "24.3" ; ssh rather than rsh, etc | |
| :initialize 'custom-initialize-delay | |
| :group 'environment | |
| :type 'file) | |
| (defcustom remote-file-name-inhibit-cache 10 | |
| "Whether to use the remote file-name cache for read access. | |
| When nil, never expire cached values (caution) | |
| When t, never use the cache (safe, but may be slow) | |
| A number means use cached values for that amount of seconds since caching. | |
| The attributes of remote files are cached for better performance. | |
| If they are changed outside of Emacs's control, the cached values | |
| become invalid, and must be reread. If you are sure that nothing | |
| other than Emacs changes the files, you can set this variable to nil. | |
| If a remote file is checked regularly, it might be a good idea to | |
| let-bind this variable to a value less than the interval between | |
| consecutive checks. For example: | |
| (defun display-time-file-nonempty-p (file) | |
| (let ((remote-file-name-inhibit-cache (- display-time-interval 5))) | |
| (and (file-exists-p file) | |
| (< 0 (file-attribute-size | |
| (file-attributes (file-chase-links file)))))))" | |
| :group 'files | |
| :version "24.1" | |
| :type '(choice | |
| (const :tag "Do not inhibit file name cache" nil) | |
| (const :tag "Do not use file name cache" t) | |
| (integer :tag "Do not use file name cache" | |
| :format "Do not use file name cache older then %v seconds" | |
| :value 10))) | |
| (defun file-local-name (file) | |
| "Return the local name component of FILE. | |
| This function removes from FILE the specification of the remote host | |
| and the method of accessing the host, leaving only the part that | |
| identifies FILE locally on the remote system. | |
| The returned file name can be used directly as argument of | |
| `process-file', `start-file-process', or `shell-command'." | |
| (or (file-remote-p file 'localname) file)) | |
| (defun file-local-copy (file) | |
| "Copy the file FILE into a temporary file on this machine. | |
| Returns the name of the local copy, or nil, if FILE is directly | |
| accessible." | |
| ;; This formerly had an optional BUFFER argument that wasn't used by | |
| ;; anything. | |
| (let ((handler (find-file-name-handler file 'file-local-copy))) | |
| (if handler | |
| (funcall handler 'file-local-copy file) | |
| nil))) | |
| (defun files--name-absolute-system-p (file) | |
| "Return non-nil if FILE is an absolute name to the operating system. | |
| This is like `file-name-absolute-p', except that it returns nil for | |
| names beginning with `~'." | |
| (and (file-name-absolute-p file) | |
| (not (eq (aref file 0) ?~)))) | |
| (defun files--splice-dirname-file (dirname file) | |
| "Splice DIRNAME to FILE like the operating system would. | |
| If FILE is relative, return DIRNAME concatenated to FILE. | |
| Otherwise return FILE, quoted as needed if DIRNAME and FILE have | |
| different file name handlers; although this quoting is dubious if | |
| DIRNAME is magic, it is not clear what would be better. This | |
| function differs from `expand-file-name' in that DIRNAME must be | |
| a directory name and leading `~' and `/:' are not special in | |
| FILE." | |
| (let ((unquoted (if (files--name-absolute-system-p file) | |
| file | |
| (concat dirname file)))) | |
| (if (eq (find-file-name-handler dirname 'file-symlink-p) | |
| (find-file-name-handler unquoted 'file-symlink-p)) | |
| unquoted | |
| (let (file-name-handler-alist) (file-name-quote unquoted))))) | |
| (defun file-truename (filename &optional counter prev-dirs) | |
| "Return the truename of FILENAME. | |
| If FILENAME is not absolute, first expands it against `default-directory'. | |
| The truename of a file name is found by chasing symbolic links | |
| both at the level of the file and at the level of the directories | |
| containing it, until no links are left at any level. | |
| \(fn FILENAME)" ;; Don't document the optional arguments. | |
| ;; COUNTER and PREV-DIRS are used only in recursive calls. | |
| ;; COUNTER can be a cons cell whose car is the count of how many | |
| ;; more links to chase before getting an error. | |
| ;; PREV-DIRS can be a cons cell whose car is an alist | |
| ;; of truenames we've just recently computed. | |
| (cond ((or (string= filename "") (string= filename "~")) | |
| (setq filename (expand-file-name filename)) | |
| (if (string= filename "") | |
| (setq filename "/"))) | |
| ((and (string= (substring filename 0 1) "~") | |
| (string-match "~[^/]*/?" filename)) | |
| (let ((first-part | |
| (substring filename 0 (match-end 0))) | |
| (rest (substring filename (match-end 0)))) | |
| (setq filename (concat (expand-file-name first-part) rest))))) | |
| (or counter (setq counter (list 100))) | |
| (let (done | |
| ;; For speed, remove the ange-ftp completion handler from the list. | |
| ;; We know it's not needed here. | |
| ;; For even more speed, do this only on the outermost call. | |
| (file-name-handler-alist | |
| (if prev-dirs file-name-handler-alist | |
| (let ((tem (copy-sequence file-name-handler-alist))) | |
| (delq (rassq 'ange-ftp-completion-hook-function tem) tem))))) | |
| (or prev-dirs (setq prev-dirs (list nil))) | |
| ;; [email protected] - on Windows, there is an issue with | |
| ;; case differences being ignored by the OS, and short "8.3 DOS" | |
| ;; name aliases existing for all files. (The short names are not | |
| ;; reported by directory-files, but can be used to refer to files.) | |
| ;; It seems appropriate for file-truename to resolve these issues in | |
| ;; the most natural way, which on Windows is to call the function | |
| ;; `w32-long-file-name' - this returns the exact name of a file as | |
| ;; it is stored on disk (expanding short name aliases with the full | |
| ;; name in the process). | |
| (if (eq system-type 'windows-nt) | |
| (unless (string-match "[[*?]" filename) | |
| ;; If filename exists, use its long name. If it doesn't | |
| ;; exist, the recursion below on the directory of filename | |
| ;; will drill down until we find a directory that exists, | |
| ;; and use the long name of that, with the extra | |
| ;; non-existent path components concatenated. | |
| (let ((longname (w32-long-file-name filename))) | |
| (if longname | |
| (setq filename longname))))) | |
| ;; If this file directly leads to a link, process that iteratively | |
| ;; so that we don't use lots of stack. | |
| (while (not done) | |
| (setcar counter (1- (car counter))) | |
| (if (< (car counter) 0) | |
| (error "Apparent cycle of symbolic links for %s" filename)) | |
| (let ((handler (find-file-name-handler filename 'file-truename))) | |
| ;; For file name that has a special handler, call handler. | |
| ;; This is so that ange-ftp can save time by doing a no-op. | |
| (if handler | |
| (setq filename (funcall handler 'file-truename filename) | |
| done t) | |
| (let ((dir (or (file-name-directory filename) default-directory)) | |
| target dirfile) | |
| ;; Get the truename of the directory. | |
| (setq dirfile (directory-file-name dir)) | |
| ;; If these are equal, we have the (or a) root directory. | |
| (or (string= dir dirfile) | |
| (and (file-name-case-insensitive-p dir) | |
| (eq (compare-strings dir 0 nil dirfile 0 nil t) t)) | |
| ;; If this is the same dir we last got the truename for, | |
| ;; save time--don't recalculate. | |
| (if (assoc dir (car prev-dirs)) | |
| (setq dir (cdr (assoc dir (car prev-dirs)))) | |
| (let ((old dir) | |
| (new (file-name-as-directory (file-truename dirfile counter prev-dirs)))) | |
| (setcar prev-dirs (cons (cons old new) (car prev-dirs))) | |
| (setq dir new)))) | |
| (if (equal ".." (file-name-nondirectory filename)) | |
| (setq filename | |
| (directory-file-name (file-name-directory (directory-file-name dir))) | |
| done t) | |
| (if (equal "." (file-name-nondirectory filename)) | |
| (setq filename (directory-file-name dir) | |
| done t) | |
| ;; Put it back on the file name. | |
| (setq filename (concat dir (file-name-nondirectory filename))) | |
| ;; Is the file name the name of a link? | |
| (setq target (file-symlink-p filename)) | |
| (if target | |
| ;; Yes => chase that link, then start all over | |
| ;; since the link may point to a directory name that uses links. | |
| ;; We can't safely use expand-file-name here | |
| ;; since target might look like foo/../bar where foo | |
| ;; is itself a link. Instead, we handle . and .. above. | |
| (setq filename (files--splice-dirname-file dir target) | |
| done nil) | |
| ;; No, we are done! | |
| (setq done t)))))))) | |
| filename)) | |
| (defun file-chase-links (filename &optional limit) | |
| "Chase links in FILENAME until a name that is not a link. | |
| Unlike `file-truename', this does not check whether a parent | |
| directory name is a symbolic link. | |
| If the optional argument LIMIT is a number, | |
| it means chase no more than that many links and then stop." | |
| (let (tem (newname filename) | |
| (count 0)) | |
| (while (and (or (null limit) (< count limit)) | |
| (setq tem (file-symlink-p newname))) | |
| (save-match-data | |
| (if (and (null limit) (= count 100)) | |
| (error "Apparent cycle of symbolic links for %s" filename)) | |
| ;; In the context of a link, `//' doesn't mean what Emacs thinks. | |
| (while (string-match "//+" tem) | |
| (setq tem (replace-match "/" nil nil tem))) | |
| ;; Handle `..' by hand, since it needs to work in the | |
| ;; target of any directory symlink. | |
| ;; This code is not quite complete; it does not handle | |
| ;; embedded .. in some cases such as ./../foo and foo/bar/../../../lose. | |
| (while (string-match "\\`\\.\\./" tem) | |
| (setq tem (substring tem 3)) | |
| (setq newname (expand-file-name newname)) | |
| ;; Chase links in the default dir of the symlink. | |
| (setq newname | |
| (file-chase-links | |
| (directory-file-name (file-name-directory newname)))) | |
| ;; Now find the parent of that dir. | |
| (setq newname (file-name-directory newname))) | |
| (setq newname (files--splice-dirname-file (file-name-directory newname) | |
| tem)) | |
| (setq count (1+ count)))) | |
| newname)) | |
| ;; A handy function to display file sizes in human-readable form. | |
| ;; See http://en.wikipedia.org/wiki/Kibibyte for the reference. | |
| (defun file-size-human-readable (file-size &optional flavor space unit) | |
| "Produce a string showing FILE-SIZE in human-readable form. | |
| Optional second argument FLAVOR controls the units and the display format: | |
| If FLAVOR is nil or omitted, each kilobyte is 1024 bytes and the produced | |
| suffixes are \"k\", \"M\", \"G\", \"T\", etc. | |
| If FLAVOR is `si', each kilobyte is 1000 bytes and the produced suffixes | |
| are \"k\", \"M\", \"G\", \"T\", etc. | |
| If FLAVOR is `iec', each kilobyte is 1024 bytes and the produced suffixes | |
| are \"KiB\", \"MiB\", \"GiB\", \"TiB\", etc. | |
| Optional third argument SPACE is a string put between the number and unit. | |
| It defaults to the empty string. We recommend a single space or | |
| non-breaking space, unless other constraints prohibit a space in that | |
| position. | |
| Optional fourth argument UNIT is the unit to use. It defaults to \"B\" | |
| when FLAVOR is `iec' and the empty string otherwise. We recommend \"B\" | |
| in all cases, since that is the standard symbol for byte." | |
| (let ((power (if (or (null flavor) (eq flavor 'iec)) | |
| 1024.0 | |
| 1000.0)) | |
| (prefixes '("" "k" "M" "G" "T" "P" "E" "Z" "Y"))) | |
| (while (and (>= file-size power) (cdr prefixes)) | |
| (setq file-size (/ file-size power) | |
| prefixes (cdr prefixes))) | |
| (let* ((prefix (car prefixes)) | |
| (prefixed-unit (if (eq flavor 'iec) | |
| (concat | |
| (if (string= prefix "k") "K" prefix) | |
| (if (string= prefix "") "" "i") | |
| (or unit "B")) | |
| (concat prefix unit)))) | |
| (format (if (and (>= (mod file-size 1.0) 0.05) | |
| (< (mod file-size 1.0) 0.95)) | |
| "%.1f%s%s" | |
| "%.0f%s%s") | |
| file-size | |
| (if (string= prefixed-unit "") "" (or space "")) | |
| prefixed-unit)))) | |
| (defun file-size-human-readable-iec (size) | |
| "Human-readable string for SIZE bytes, using IEC prefixes." | |
| (file-size-human-readable size 'iec " ")) | |
| (defcustom byte-count-to-string-function #'file-size-human-readable-iec | |
| "Function that turns a number of bytes into a human-readable string. | |
| It is for use when displaying file sizes and disk space where other | |
| constraints do not force a specific format." | |
| :type '(radio | |
| (function-item file-size-human-readable-iec) | |
| (function-item file-size-human-readable) | |
| (function :tag "Custom function" :value number-to-string)) | |
| :group 'files | |
| :version "27.1") | |
| (defcustom mounted-file-systems | |
| (if (memq system-type '(windows-nt cygwin)) | |
| "^//[^/]+/" | |
| ;; regexp-opt.el is not dumped into emacs binary. | |
| ;;(concat | |
| ;; "^" (regexp-opt '("/afs/" "/media/" "/mnt" "/net/" "/tmp_mnt/")))) | |
| "^\\(?:/\\(?:afs/\\|m\\(?:edia/\\|nt\\)\\|\\(?:ne\\|tmp_mn\\)t/\\)\\)") | |
| "File systems that ought to be mounted." | |
| :group 'files | |
| :version "26.1" | |
| :require 'regexp-opt | |
| :type 'regexp) | |
| (defun temporary-file-directory () | |
| "The directory for writing temporary files. | |
| In case of a remote `default-directory', this is a directory for | |
| temporary files on that remote host. If such a directory does | |
| not exist, or `default-directory' ought to be located on a | |
| mounted file system (see `mounted-file-systems'), the function | |
| returns `default-directory'. | |
| For a non-remote and non-mounted `default-directory', the value of | |
| the variable `temporary-file-directory' is returned." | |
| (let ((handler (find-file-name-handler | |
| default-directory 'temporary-file-directory))) | |
| (if handler | |
| (funcall handler 'temporary-file-directory) | |
| (if (string-match mounted-file-systems default-directory) | |
| default-directory | |
| temporary-file-directory)))) | |
| (defun make-temp-file (prefix &optional dir-flag suffix text) | |
| "Create a temporary file. | |
| The returned file name (created by appending some random characters at the end | |
| of PREFIX, and expanding against `temporary-file-directory' if necessary), | |
| is guaranteed to point to a newly created file. | |
| You can then use `write-region' to write new data into the file. | |
| If DIR-FLAG is non-nil, create a new empty directory instead of a file. | |
| If SUFFIX is non-nil, add that at the end of the file name. | |
| If TEXT is a string, insert it into the new file; DIR-FLAG should be nil. | |
| Otherwise the file will be empty." | |
| (let ((absolute-prefix | |
| (if (or (zerop (length prefix)) (member prefix '("." ".."))) | |
| (concat (file-name-as-directory temporary-file-directory) prefix) | |
| (expand-file-name prefix temporary-file-directory)))) | |
| (if (find-file-name-handler absolute-prefix 'write-region) | |
| (files--make-magic-temp-file absolute-prefix dir-flag suffix text) | |
| (make-temp-file-internal absolute-prefix | |
| (if dir-flag t) (or suffix "") text)))) | |
| (defun files--make-magic-temp-file (absolute-prefix | |
| &optional dir-flag suffix text) | |
| "Implement (make-temp-file ABSOLUTE-PREFIX DIR-FLAG SUFFIX TEXT). | |
| This implementation works on magic file names." | |
| ;; Create temp files with strict access rights. It's easy to | |
| ;; loosen them later, whereas it's impossible to close the | |
| ;; time-window of loose permissions otherwise. | |
| (with-file-modes ?\700 | |
| (let ((contents (if (stringp text) text "")) | |
| file) | |
| (while (condition-case () | |
| (progn | |
| (setq file (make-temp-name absolute-prefix)) | |
| (if suffix | |
| (setq file (concat file suffix))) | |
| (if dir-flag | |
| (make-directory file) | |
| (write-region contents nil file nil 'silent nil 'excl)) | |
| nil) | |
| (file-already-exists t)) | |
| ;; the file was somehow created by someone else between | |
| ;; `make-temp-name' and `write-region', let's try again. | |
| nil) | |
| file))) | |
| (defun make-nearby-temp-file (prefix &optional dir-flag suffix) | |
| "Create a temporary file as close as possible to `default-directory'. | |
| If PREFIX is a relative file name, and `default-directory' is a | |
| remote file name or located on a mounted file systems, the | |
| temporary file is created in the directory returned by the | |
| function `temporary-file-directory'. Otherwise, the function | |
| `make-temp-file' is used. PREFIX, DIR-FLAG and SUFFIX have the | |
| same meaning as in `make-temp-file'." | |
| (let ((handler (find-file-name-handler | |
| default-directory 'make-nearby-temp-file))) | |
| (if (and handler (not (file-name-absolute-p default-directory))) | |
| (funcall handler 'make-nearby-temp-file prefix dir-flag suffix) | |
| (let ((temporary-file-directory (temporary-file-directory))) | |
| (make-temp-file prefix dir-flag suffix))))) | |
| (defun recode-file-name (file coding new-coding &optional ok-if-already-exists) | |
| "Change the encoding of FILE's name from CODING to NEW-CODING. | |
| The value is a new name of FILE. | |
| Signals a `file-already-exists' error if a file of the new name | |
| already exists unless optional fourth argument OK-IF-ALREADY-EXISTS | |
| is non-nil. A number as fourth arg means request confirmation if | |
| the new name already exists. This is what happens in interactive | |
| use with M-x." | |
| (interactive | |
| (let ((default-coding (or file-name-coding-system | |
| default-file-name-coding-system)) | |
| (filename (read-file-name "Recode filename: " nil nil t)) | |
| from-coding to-coding) | |
| (if (and default-coding | |
| ;; We provide the default coding only when it seems that | |
| ;; the filename is correctly decoded by the default | |
| ;; coding. | |
| (let ((charsets (find-charset-string filename))) | |
| (and (not (memq 'eight-bit-control charsets)) | |
| (not (memq 'eight-bit-graphic charsets))))) | |
| (setq from-coding (read-coding-system | |
| (format "Recode filename %s from (default %s): " | |
| filename default-coding) | |
| default-coding)) | |
| (setq from-coding (read-coding-system | |
| (format "Recode filename %s from: " filename)))) | |
| ;; We provide the default coding only when a user is going to | |
| ;; change the encoding not from the default coding. | |
| (if (eq from-coding default-coding) | |
| (setq to-coding (read-coding-system | |
| (format "Recode filename %s from %s to: " | |
| filename from-coding))) | |
| (setq to-coding (read-coding-system | |
| (format "Recode filename %s from %s to (default %s): " | |
| filename from-coding default-coding) | |
| default-coding))) | |
| (list filename from-coding to-coding))) | |
| (let* ((default-coding (or file-name-coding-system | |
| default-file-name-coding-system)) | |
| ;; FILE should have been decoded by DEFAULT-CODING. | |
| (encoded (encode-coding-string file default-coding)) | |
| (newname (decode-coding-string encoded coding)) | |
| (new-encoded (encode-coding-string newname new-coding)) | |
| ;; Suppress further encoding. | |
| (file-name-coding-system nil) | |
| (default-file-name-coding-system nil) | |
| (locale-coding-system nil)) | |
| (rename-file encoded new-encoded ok-if-already-exists) | |
| newname)) | |
| (defcustom confirm-nonexistent-file-or-buffer 'after-completion | |
| "Whether confirmation is requested before visiting a new file or buffer. | |
| If nil, confirmation is not requested. | |
| If the value is `after-completion', confirmation is requested | |
| only if the user called `minibuffer-complete' right before | |
| `minibuffer-complete-and-exit'. | |
| Any other non-nil value means to request confirmation. | |
| This affects commands like `switch-to-buffer' and `find-file'." | |
| :group 'find-file | |
| :version "23.1" | |
| :type '(choice (const :tag "After completion" after-completion) | |
| (const :tag "Never" nil) | |
| (other :tag "Always" t))) | |
| (defun confirm-nonexistent-file-or-buffer () | |
| "Whether to request confirmation before visiting a new file or buffer. | |
| The variable `confirm-nonexistent-file-or-buffer' determines the | |
| return value, which may be passed as the REQUIRE-MATCH arg to | |
| `read-buffer' or `find-file-read-args'." | |
| (cond ((eq confirm-nonexistent-file-or-buffer 'after-completion) | |
| 'confirm-after-completion) | |
| (confirm-nonexistent-file-or-buffer | |
| 'confirm) | |
| (t nil))) | |
| (defmacro minibuffer-with-setup-hook (fun &rest body) | |
| "Temporarily add FUN to `minibuffer-setup-hook' while executing BODY. | |
| By default, FUN is prepended to `minibuffer-setup-hook'. But if FUN is of | |
| the form `(:append FUN1)', FUN1 will be appended to `minibuffer-setup-hook' | |
| instead of prepending it. | |
| BODY should use the minibuffer at most once. | |
| Recursive uses of the minibuffer are unaffected (FUN is not | |
| called additional times). | |
| This macro actually adds an auxiliary function that calls FUN, | |
| rather than FUN itself, to `minibuffer-setup-hook'." | |
| (declare (indent 1) (debug t)) | |
| (let ((hook (make-symbol "setup-hook")) | |
| (funsym (make-symbol "fun")) | |
| (append nil)) | |
| (when (eq (car-safe fun) :append) | |
| (setq append '(t) fun (cadr fun))) | |
| `(let ((,funsym ,fun) | |
| ,hook) | |
| (setq ,hook | |
| (lambda () | |
| ;; Clear out this hook so it does not interfere | |
| ;; with any recursive minibuffer usage. | |
| (remove-hook 'minibuffer-setup-hook ,hook) | |
| (funcall ,funsym))) | |
| (unwind-protect | |
| (progn | |
| (add-hook 'minibuffer-setup-hook ,hook ,@append) | |
| ,@body) | |
| (remove-hook 'minibuffer-setup-hook ,hook))))) | |
| (defun find-file-read-args (prompt mustmatch &optional wildcards) | |
| "Return the interactive spec (<filename> <async>). | |
| If WILDCARDS is non-nil, return the spec (<filename> t <async>)." | |
| (let ((filename (read-file-name prompt nil default-directory mustmatch)) | |
| (async (and (featurep 'threads) | |
| (xor universal-async-argument | |
| execute-file-commands-asynchronously)))) | |
| (when (stringp async) (setq async (string-match-p async filename))) | |
| (if wildcards `(,filename t ,async) `(,filename ,async)))) | |
| (defmacro find-file-with-threads (filename async &rest body) | |
| "Run BODY in an own thread, if ASYNC is non-nil." | |
| (declare (indent 2) (debug t)) | |
| `(if ,async | |
| (progn | |
| (make-thread (lambda () ,@body) (concat "find-file " ,filename)) | |
| (thread-yield)) | |
| ,@body)) | |
| (defun find-file (filename &optional wildcards async) | |
| "Edit file FILENAME. | |
| Switch to a buffer visiting file FILENAME, | |
| creating one if none already exists. | |
| Interactively, the default if you just type RET is the current directory, | |
| but the visited file name is available through the minibuffer history: | |
| type \\[next-history-element] to pull it into the minibuffer. | |
| The first time \\[next-history-element] is used after Emacs prompts for | |
| the file name, the result is affected by `file-name-at-point-functions', | |
| which by default try to guess the file name by looking at point in the | |
| current buffer. Customize the value of `file-name-at-point-functions' | |
| or set it to nil, if you want only the visited file name and the | |
| current directory to be available on first \\[next-history-element] | |
| request. | |
| You can visit files on remote machines by specifying something | |
| like /ssh:SOME_REMOTE_MACHINE:FILE for the file name. You can | |
| also visit local files as a different user by specifying | |
| /sudo::FILE for the file name. | |
| See the Info node `(tramp)File name Syntax' in the Tramp Info | |
| manual, for more about this. | |
| Interactively, or if WILDCARDS is non-nil in a call from Lisp, | |
| expand wildcards (if any) and visit multiple files. You can | |
| suppress wildcard expansion by setting `find-file-wildcards' to nil. | |
| If ASYNC is non-nil, the file will be loaded into the buffer | |
| asynchronously. Interactively, this is indicated by setting | |
| `execute-file-commands-asynchronously' to a proper non-nil value. | |
| This behavior can be toggled by \\[universal-async-argument] | |
| prior the command invocation. | |
| To visit a file without any kind of conversion and without | |
| automatically choosing a major mode, use \\[find-file-literally]." | |
| (interactive | |
| (find-file-read-args "Find file: " | |
| (confirm-nonexistent-file-or-buffer) t)) | |
| (find-file-with-threads filename async | |
| (let ((value (find-file-noselect filename nil nil wildcards async))) | |
| (if (listp value) | |
| (mapcar 'pop-to-buffer-same-window (nreverse value)) | |
| (pop-to-buffer-same-window value))))) | |
| (defun find-file-other-window (filename &optional wildcards async) | |
| "Edit file FILENAME, in another window. | |
| Like \\[find-file] (which see), but creates a new window or reuses | |
| an existing one. See the function `display-buffer'. | |
| Interactively, the default if you just type RET is the current directory, | |
| but the visited file name is available through the minibuffer history: | |
| type \\[next-history-element] to pull it into the minibuffer. | |
| The first time \\[next-history-element] is used after Emacs prompts for | |
| the file name, the result is affected by `file-name-at-point-functions', | |
| which by default try to guess the file name by looking at point in the | |
| current buffer. Customize the value of `file-name-at-point-functions' | |
| or set it to nil, if you want only the visited file name and the | |
| current directory to be available on first \\[next-history-element] | |
| request. | |
| Interactively, or if WILDCARDS is non-nil in a call from Lisp, | |
| expand wildcards (if any) and visit multiple files. | |
| If ASYNC is non-nil, the file will be loaded into the buffer | |
| asynchronously. Interactively, this is indicated by setting | |
| `execute-file-commands-asynchronously' to a proper non-nil value. | |
| This behavior can be toggled by \\[universal-async-argument] | |
| prior the command invocation." | |
| (interactive | |
| (find-file-read-args "Find file in other window: " | |
| (confirm-nonexistent-file-or-buffer) t)) | |
| (find-file-with-threads filename async | |
| (let ((value (find-file-noselect filename nil nil wildcards async))) | |
| (if (listp value) | |
| (progn | |
| (setq value (nreverse value)) | |
| (switch-to-buffer-other-window (car value)) | |
| (mapc 'switch-to-buffer (cdr value)) | |
| value) | |
| (switch-to-buffer-other-window value))))) | |
| (defun find-file-other-frame (filename &optional wildcards async) | |
| "Edit file FILENAME, in another frame. | |
| Like \\[find-file] (which see), but creates a new frame or reuses | |
| an existing one. See the function `display-buffer'. | |
| Interactively, the default if you just type RET is the current directory, | |
| but the visited file name is available through the minibuffer history: | |
| type \\[next-history-element] to pull it into the minibuffer. | |
| The first time \\[next-history-element] is used after Emacs prompts for | |
| the file name, the result is affected by `file-name-at-point-functions', | |
| which by default try to guess the file name by looking at point in the | |
| current buffer. Customize the value of `file-name-at-point-functions' | |
| or set it to nil, if you want only the visited file name and the | |
| current directory to be available on first \\[next-history-element] | |
| request. | |
| Interactively, or if WILDCARDS is non-nil in a call from Lisp, | |
| expand wildcards (if any) and visit multiple files. | |
| If ASYNC is non-nil, the file will be loaded into the buffer | |
| asynchronously. Interactively, this is indicated by setting | |
| `execute-file-commands-asynchronously' to a proper non-nil value. | |
| This behavior can be toggled by \\[universal-async-argument] | |
| prior the command invocation." | |
| (interactive | |
| (find-file-read-args "Find file in other frame: " | |
| (confirm-nonexistent-file-or-buffer) t)) | |
| (find-file-with-threads filename async | |
| (let ((value (find-file-noselect filename nil nil wildcards async))) | |
| (if (listp value) | |
| (progn | |
| (setq value (nreverse value)) | |
| (switch-to-buffer-other-frame (car value)) | |
| (mapc 'switch-to-buffer (cdr value)) | |
| value) | |
| (switch-to-buffer-other-frame value))))) | |
| (defun find-file-existing (filename &optional async) | |
| "Edit the existing file FILENAME. | |
| Like \\[find-file], but allow only a file that exists, and do not allow | |
| file names with wildcards. | |
| If ASYNC is non-nil, the file will be loaded into the buffer | |
| asynchronously. Interactively, this is indicated by setting | |
| `execute-file-commands-asynchronously' to a proper non-nil value. | |
| This behavior can be toggled by \\[universal-async-argument] | |
| prior the command invocation." | |
| (interactive | |
| (find-file-read-args "Find existing file: " t)) | |
| (if (and (not (called-interactively-p 'interactive)) | |
| (not (file-exists-p filename))) | |
| (error "%s does not exist" filename) | |
| (find-file-with-threads filename async | |
| (find-file filename) | |
| (current-buffer)))) | |
| (defun find-file--read-only (fun filename wildcards async) | |
| (unless (or (and wildcards find-file-wildcards | |
| (not (file-name-quoted-p filename)) | |
| (string-match "[[*?]" filename)) | |
| (file-exists-p filename)) | |
| (error "%s does not exist" filename)) | |
| (find-file-with-threads filename async | |
| (let ((value (funcall fun filename wildcards))) | |
| (mapc (lambda (b) (with-current-buffer b (read-only-mode 1))) | |
| (if (listp value) value (list value))) | |
| value))) | |
| (defun find-file-read-only (filename &optional wildcards async) | |
| "Edit file FILENAME but don't allow changes. | |
| Like \\[find-file], but marks buffer as read-only. | |
| Use \\[read-only-mode] to permit editing." | |
| (interactive | |
| (find-file-read-args "Find file read-only: " | |
| (confirm-nonexistent-file-or-buffer) t)) | |
| (find-file--read-only #'find-file filename wildcards async)) | |
| (defun find-file-read-only-other-window (filename &optional wildcards async) | |
| "Edit file FILENAME in another window but don't allow changes. | |
| Like \\[find-file-other-window], but marks buffer as read-only. | |
| Use \\[read-only-mode] to permit editing." | |
| (interactive | |
| (find-file-read-args "Find file read-only other window: " | |
| (confirm-nonexistent-file-or-buffer) t)) | |
| (find-file--read-only #'find-file-other-window filename wildcards async)) | |
| (defun find-file-read-only-other-frame (filename &optional wildcards async) | |
| "Edit file FILENAME in another frame but don't allow changes. | |
| Like \\[find-file-other-frame], but marks buffer as read-only. | |
| Use \\[read-only-mode] to permit editing." | |
| (interactive | |
| (find-file-read-args "Find file read-only other frame: " | |
| (confirm-nonexistent-file-or-buffer) t)) | |
| (find-file--read-only #'find-file-other-frame filename wildcards async)) | |
| (defun find-alternate-file-other-window (filename &optional wildcards async) | |
| "Find file FILENAME as a replacement for the file in the next window. | |
| This command does not select that window. | |
| See \\[find-file] for the possible forms of the FILENAME argument. | |
| Interactively, or if WILDCARDS is non-nil in a call from Lisp, | |
| expand wildcards (if any) and replace the file with multiple files. | |
| If ASYNC is non-nil, the file will be loaded into the buffer | |
| asynchronously. Interactively, this is indicated by setting | |
| `execute-file-commands-asynchronously' to a proper non-nil value. | |
| This behavior can be toggled by \\[universal-async-argument] | |
| prior the command invocation." | |
| (interactive | |
| (save-selected-window | |
| (other-window 1) | |
| (let ((file buffer-file-name) | |
| (file-name nil) | |
| (file-dir nil)) | |
| (and file | |
| (setq file-name (file-name-nondirectory file) | |
| file-dir (file-name-directory file))) | |
| (list (read-file-name | |
| "Find alternate file: " file-dir nil | |
| (confirm-nonexistent-file-or-buffer) file-name) | |
| t (and (featurep 'threads) | |
| (xor universal-async-argument | |
| execute-file-commands-asynchronously)))))) | |
| (when (stringp async) (setq async (string-match-p async filename))) | |
| (if (one-window-p) | |
| (find-file-other-window filename wildcards async) | |
| (save-selected-window | |
| (other-window 1) | |
| (find-alternate-file filename wildcards async)))) | |
| ;; Defined and used in buffer.c, but not as a DEFVAR_LISP. | |
| (defvar kill-buffer-hook nil | |
| "Hook run when a buffer is killed. | |
| The buffer being killed is current while the hook is running. | |
| See `kill-buffer'. | |
| Note: Be careful with let-binding this hook considering it is | |
| frequently used for cleanup.") | |
| (defun find-alternate-file (filename &optional wildcards async) | |
| "Find file FILENAME, select its buffer, kill previous buffer. | |
| If the current buffer now contains an empty file that you just visited | |
| \(presumably by mistake), use this command to visit the file you really want. | |
| See \\[find-file] for the possible forms of the FILENAME argument. | |
| Interactively, or if WILDCARDS is non-nil in a call from Lisp, | |
| expand wildcards (if any) and replace the file with multiple files. | |
| If ASYNC is non-nil, the file will be loaded into the buffer | |
| asynchronously. Interactively, this is indicated by setting | |
| `execute-file-commands-asynchronously' to a proper non-nil value. | |
| This behavior can be toggled by \\[universal-async-argument] | |
| prior the command invocation. | |
| If the current buffer is an indirect buffer, or the base buffer | |
| for one or more indirect buffers, the other buffer(s) are not | |
| killed." | |
| (interactive | |
| (let ((file buffer-file-name) | |
| (file-name nil) | |
| (file-dir nil)) | |
| (and file | |
| (setq file-name (file-name-nondirectory file) | |
| file-dir (file-name-directory file))) | |
| (list (read-file-name | |
| "Find alternate file: " file-dir nil | |
| (confirm-nonexistent-file-or-buffer) file-name) | |
| t (and (featurep 'threads) | |
| (xor universal-async-argument | |
| execute-file-commands-asynchronously))))) | |
| (when (stringp async) (setq async (string-match-p async filename))) | |
| (unless (run-hook-with-args-until-failure 'kill-buffer-query-functions) | |
| (user-error "Aborted")) | |
| (and (buffer-modified-p) buffer-file-name | |
| (not (yes-or-no-p | |
| (format-message "Kill and replace buffer `%s' without saving it? " | |
| (buffer-name)))) | |
| (user-error "Aborted")) | |
| (let ((obuf (current-buffer)) | |
| (ofile buffer-file-name) | |
| (onum buffer-file-number) | |
| (odir dired-directory) | |
| (otrue buffer-file-truename) | |
| (oname (buffer-name))) | |
| ;; Run `kill-buffer-hook' here. It needs to happen before | |
| ;; variables like `buffer-file-name' etc are set to nil below, | |
| ;; because some of the hooks that could be invoked | |
| ;; (e.g., `save-place-to-alist') depend on those variables. | |
| ;; | |
| ;; Note that `kill-buffer-hook' is not what queries whether to | |
| ;; save a modified buffer visiting a file. Rather, `kill-buffer' | |
| ;; asks that itself. Thus, there's no need to temporarily do | |
| ;; `(set-buffer-modified-p nil)' before running this hook. | |
| (run-hooks 'kill-buffer-hook) | |
| ;; Okay, now we can end-of-life the old buffer. | |
| (if (get-buffer " **lose**") | |
| (kill-buffer " **lose**")) | |
| (rename-buffer " **lose**") | |
| (unwind-protect | |
| (progn | |
| (unlock-buffer) | |
| ;; This prevents us from finding the same buffer | |
| ;; if we specified the same file again. | |
| (setq buffer-file-name nil) | |
| (setq buffer-file-number nil) | |
| (setq buffer-file-truename nil) | |
| ;; Likewise for dired buffers. | |
| (setq dired-directory nil) | |
| ;; Don't use `find-file' because it may end up using another window | |
| ;; in some corner cases, e.g. when the selected window is | |
| ;; softly-dedicated. | |
| (let ((newbuf (find-file-noselect filename nil nil wildcards async))) | |
| (switch-to-buffer (if (consp newbuf) (car newbuf) newbuf)))) | |
| (when (eq obuf (current-buffer)) | |
| ;; This executes if find-file gets an error | |
| ;; and does not really find anything. | |
| ;; We put things back as they were. | |
| ;; If find-file actually finds something, we kill obuf below. | |
| (setq buffer-file-name ofile) | |
| (setq buffer-file-number onum) | |
| (setq buffer-file-truename otrue) | |
| (setq dired-directory odir) | |
| (lock-buffer) | |
| (rename-buffer oname))) | |
| (unless (eq (current-buffer) obuf) | |
| (with-current-buffer obuf | |
| ;; We already ran these; don't run them again. | |
| (let (kill-buffer-query-functions kill-buffer-hook) | |
| (kill-buffer obuf)))))) | |
| ;; FIXME we really need to fold the uniquify stuff in here by default, | |
| ;; not using advice, and add it to the doc string. | |
| (defun create-file-buffer (filename) | |
| "Create a suitably named buffer for visiting FILENAME, and return it. | |
| FILENAME (sans directory) is used unchanged if that name is free; | |
| otherwise a string <2> or <3> or ... is appended to get an unused name. | |
| Emacs treats buffers whose names begin with a space as internal buffers. | |
| To avoid confusion when visiting a file whose name begins with a space, | |
| this function prepends a \"|\" to the final result if necessary." | |
| (let ((lastname (file-name-nondirectory filename))) | |
| (if (string= lastname "") | |
| (setq lastname filename)) | |
| (generate-new-buffer (if (string-match-p "\\` " lastname) | |
| (concat "|" lastname) | |
| lastname)))) | |
| (defcustom automount-dir-prefix (purecopy "^/tmp_mnt/") | |
| "Regexp to match the automounter prefix in a directory name." | |
| :group 'files | |
| :type 'regexp) | |
| (make-obsolete-variable 'automount-dir-prefix 'directory-abbrev-alist "24.3") | |
| (defvar abbreviated-home-dir nil | |
| "Regexp matching the user's homedir at the beginning of file name. | |
| The value includes abbreviation according to `directory-abbrev-alist'.") | |
| (defun abbreviate-file-name (filename) | |
| "Return a version of FILENAME shortened using `directory-abbrev-alist'. | |
| This also substitutes \"~\" for the user's home directory (unless the | |
| home directory is a root directory) and removes automounter prefixes | |
| \(see the variable `automount-dir-prefix'). | |
| When this function is first called, it caches the user's home | |
| directory as a regexp in `abbreviated-home-dir', and reuses it | |
| afterwards (so long as the home directory does not change; | |
| if you want to permanently change your home directory after having | |
| started Emacs, set `abbreviated-home-dir' to nil so it will be recalculated)." | |
| ;; Get rid of the prefixes added by the automounter. | |
| (save-match-data ;FIXME: Why? | |
| (if (and automount-dir-prefix | |
| (string-match automount-dir-prefix filename) | |
| (file-exists-p (file-name-directory | |
| (substring filename (1- (match-end 0)))))) | |
| (setq filename (substring filename (1- (match-end 0))))) | |
| ;; Avoid treating /home/foo as /home/Foo during `~' substitution. | |
| (let ((case-fold-search (file-name-case-insensitive-p filename))) | |
| ;; If any elt of directory-abbrev-alist matches this name, | |
| ;; abbreviate accordingly. | |
| (dolist (dir-abbrev directory-abbrev-alist) | |
| (if (string-match (car dir-abbrev) filename) | |
| (setq filename | |
| (concat (cdr dir-abbrev) | |
| (substring filename (match-end 0)))))) | |
| ;; Compute and save the abbreviated homedir name. | |
| ;; We defer computing this until the first time it's needed, to | |
| ;; give time for directory-abbrev-alist to be set properly. | |
| ;; We include a slash at the end, to avoid spurious matches | |
| ;; such as `/usr/foobar' when the home dir is `/usr/foo'. | |
| (unless abbreviated-home-dir | |
| (put 'abbreviated-home-dir 'home (expand-file-name "~")) | |
| (setq abbreviated-home-dir | |
| (let* ((abbreviated-home-dir "\\`\\'.") ;Impossible regexp. | |
| (regexp | |
| (concat "\\`" | |
| (regexp-quote | |
| (abbreviate-file-name | |
| (get 'abbreviated-home-dir 'home))) | |
| "\\(/\\|\\'\\)"))) | |
| ;; Depending on whether default-directory does or | |
| ;; doesn't include non-ASCII characters, the value | |
| ;; of abbreviated-home-dir could be multibyte or | |
| ;; unibyte. In the latter case, we need to decode | |
| ;; it. Note that this function is called for the | |
| ;; first time (from startup.el) when | |
| ;; locale-coding-system is already set up. | |
| (if (multibyte-string-p regexp) | |
| regexp | |
| (decode-coding-string regexp | |
| (if (eq system-type 'windows-nt) | |
| 'utf-8 | |
| locale-coding-system)))))) | |
| ;; If FILENAME starts with the abbreviated homedir, | |
| ;; and ~ hasn't changed since abbreviated-home-dir was set, | |
| ;; make it start with `~' instead. | |
| ;; If ~ has changed, we ignore abbreviated-home-dir rather than | |
| ;; invalidating it, on the assumption that a change in HOME | |
| ;; is likely temporary (eg for testing). | |
| ;; FIXME Is it even worth caching abbreviated-home-dir? | |
| ;; Ref: https://debbugs.gnu.org/19657#20 | |
| (let (mb1) | |
| (if (and (string-match abbreviated-home-dir filename) | |
| (setq mb1 (match-beginning 1)) | |
| ;; If the home dir is just /, don't change it. | |
| (not (and (= (match-end 0) 1) | |
| (= (aref filename 0) ?/))) | |
| ;; MS-DOS root directories can come with a drive letter; | |
| ;; Novell Netware allows drive letters beyond `Z:'. | |
| (not (and (memq system-type '(ms-dos windows-nt cygwin)) | |
| (string-match "\\`[a-zA-`]:/\\'" filename))) | |
| (equal (get 'abbreviated-home-dir 'home) | |
| (expand-file-name "~"))) | |
| (setq filename | |
| (concat "~" | |
| (substring filename mb1)))) | |
| filename)))) | |
| (defun find-buffer-visiting (filename &optional predicate) | |
| "Return the buffer visiting file FILENAME (a string). | |
| This is like `get-file-buffer', except that it checks for any buffer | |
| visiting the same file, possibly under a different name. | |
| If PREDICATE is non-nil, only buffers satisfying it are eligible, | |
| and others are ignored. | |
| If there is no such live buffer, return nil." | |
| (let ((predicate (or predicate #'identity)) | |
| (truename (abbreviate-file-name (file-truename filename)))) | |
| (or (let ((buf (get-file-buffer filename))) | |
| (when (and buf (funcall predicate buf)) buf)) | |
| (let ((list (buffer-list)) found) | |
| (while (and (not found) list) | |
| (with-current-buffer (car list) | |
| (if (and buffer-file-name | |
| (string= buffer-file-truename truename) | |
| (funcall predicate (current-buffer))) | |
| (setq found (car list)))) | |
| (setq list (cdr list))) | |
| found) | |
| (let* ((attributes (file-attributes truename)) | |
| (number (nthcdr 10 attributes)) | |
| (list (buffer-list)) found) | |
| (and buffer-file-numbers-unique | |
| (car-safe number) ;Make sure the inode is not just nil. | |
| (while (and (not found) list) | |
| (with-current-buffer (car list) | |
| (if (and buffer-file-name | |
| (equal buffer-file-number number) | |
| ;; Verify this buffer's file number | |
| ;; still belongs to its file. | |
| (file-exists-p buffer-file-name) | |
| (equal (file-attributes buffer-file-truename) | |
| attributes) | |
| (funcall predicate (current-buffer))) | |
| (setq found (car list)))) | |
| (setq list (cdr list)))) | |
| found)))) | |
| (defcustom find-file-wildcards t | |
| "Non-nil means file-visiting commands should handle wildcards. | |
| For example, if you specify `*.c', that would visit all the files | |
| whose names match the pattern." | |
| :group 'files | |
| :version "20.4" | |
| :type 'boolean) | |
| (defcustom find-file-suppress-same-file-warnings nil | |
| "Non-nil means suppress warning messages for symlinked files. | |
| When nil, Emacs prints a warning when visiting a file that is already | |
| visited, but with a different name. Setting this option to t | |
| suppresses this warning." | |
| :group 'files | |
| :version "21.1" | |
| :type 'boolean) | |
| (defcustom execute-file-commands-asynchronously nil | |
| "Non-nil means visit files asynchronously when called interactively. | |
| If it is a regular expression, it must match the file names to be | |
| visited. This behavior is toggled by \\[universal-async-argument] | |
| prior the command invocation." | |
| :group 'files | |
| :version "28.1" | |
| :type '(choice boolean regexp)) | |
| (defcustom large-file-warning-threshold 10000000 | |
| "Maximum size of file above which a confirmation is requested. | |
| When nil, never request confirmation." | |
| :group 'files | |
| :group 'find-file | |
| :version "22.1" | |
| :type '(choice integer (const :tag "Never request confirmation" nil))) | |
| (defcustom out-of-memory-warning-percentage nil | |
| "Warn if file size exceeds this percentage of available free memory. | |
| When nil, never issue warning. Beware: This probably doesn't do what you | |
| think it does, because \"free\" is pretty hard to define in practice." | |
| :group 'files | |
| :group 'find-file | |
| :version "25.1" | |
| :type '(choice integer (const :tag "Never issue warning" nil))) | |
| (declare-function x-popup-dialog "menu.c" (position contents &optional header)) | |
| (defun files--ask-user-about-large-file (size op-type filename offer-raw) | |
| (let ((prompt (format "File %s is large (%s), really %s?" | |
| (file-name-nondirectory filename) | |
| (funcall byte-count-to-string-function size) op-type))) | |
| (if (not offer-raw) | |
| (if (y-or-n-p prompt) nil 'abort) | |
| (let* ((use-dialog (and (display-popup-menus-p) | |
| last-input-event | |
| (listp last-nonmenu-event) | |
| use-dialog-box)) | |
| (choice | |
| (if use-dialog | |
| (x-popup-dialog t `(,prompt | |
| ("Yes" . ?y) | |
| ("No" . ?n) | |
| ("Open literally" . ?l))) | |
| (read-char-from-minibuffer | |
| (concat prompt " (y)es or (n)o or (l)iterally ") | |
| '(?y ?Y ?n ?N ?l ?L))))) | |
| (cond ((memq choice '(?y ?Y)) nil) | |
| ((memq choice '(?l ?L)) 'raw) | |
| (t 'abort)))))) | |
| (defun abort-if-file-too-large (size op-type filename &optional offer-raw) | |
| "If file SIZE larger than `large-file-warning-threshold', allow user to abort. | |
| OP-TYPE specifies the file operation being performed (for message | |
| to user). If OFFER-RAW is true, give user the additional option | |
| to open the file literally. If the user chooses this option, | |
| `abort-if-file-too-large' returns the symbol `raw'. Otherwise, | |
| it returns nil or exits non-locally." | |
| (let ((choice (and large-file-warning-threshold size | |
| (> size large-file-warning-threshold) | |
| ;; No point in warning if we can't read it. | |
| (file-readable-p filename) | |
| (files--ask-user-about-large-file | |
| size op-type filename offer-raw)))) | |
| (when (eq choice 'abort) | |
| (user-error "Aborted")) | |
| choice)) | |
| (defun warn-maybe-out-of-memory (size) | |
| "Warn if an attempt to open file of SIZE bytes may run out of memory." | |
| (when (and (numberp size) (not (zerop size)) | |
| (integerp out-of-memory-warning-percentage)) | |
| (let ((meminfo (memory-info))) | |
| (when (consp meminfo) | |
| (let ((total-free-memory (float (+ (nth 1 meminfo) (nth 3 meminfo))))) | |
| (when (> (/ size 1024) | |
| (/ (* total-free-memory out-of-memory-warning-percentage) | |
| 100.0)) | |
| (warn | |
| "You are trying to open a file whose size (%s) | |
| exceeds the %S%% of currently available free memory (%s). | |
| If that fails, try to open it with `find-file-literally' | |
| \(but note that some characters might be displayed incorrectly)." | |
| (funcall byte-count-to-string-function size) | |
| out-of-memory-warning-percentage | |
| (funcall byte-count-to-string-function | |
| (* total-free-memory 1024))))))))) | |
| (defun files--message (format &rest args) | |
| "Like `message', except sometimes don't show the message text. | |
| If the variable `save-silently' is non-nil, the message will not | |
| be visible in the echo area." | |
| (apply #'message format args) | |
| (when save-silently (message nil))) | |
| (defun find-file-noselect (filename &optional nowarn rawfile wildcards async) | |
| "Read file FILENAME into a buffer and return the buffer. | |
| If a buffer exists visiting FILENAME, return that one, but | |
| verify that the file has not changed since visited or saved. | |
| The buffer is not selected, just returned to the caller. | |
| Optional second arg NOWARN non-nil means suppress any warning messages. | |
| Optional third arg RAWFILE non-nil means the file is read literally. | |
| Optional fourth arg WILDCARDS non-nil means do wildcard processing | |
| and visit all the matching files. When wildcards are actually | |
| used and expanded, return a list of buffers that are visiting | |
| the various files. | |
| If ASYNC is non-nil, the file will be loaded into the buffer | |
| asynchronously. When several files are loaded due to WILDCARDS, | |
| every file will be loaded in an own thread." | |
| (setq filename | |
| (abbreviate-file-name | |
| (expand-file-name filename))) | |
| (if (file-directory-p filename) | |
| (or (and find-file-run-dired | |
| (run-hook-with-args-until-success | |
| 'find-directory-functions | |
| (if find-file-visit-truename | |
| (abbreviate-file-name (file-truename filename)) | |
| filename))) | |
| (error "%s is a directory" filename)) | |
| (if (and wildcards | |
| find-file-wildcards | |
| (not (file-name-quoted-p filename)) | |
| (string-match "[[*?]" filename)) | |
| (let ((files (condition-case nil | |
| (file-expand-wildcards filename t) | |
| (error (list filename)))) | |
| (find-file-wildcards nil) | |
| threads) | |
| (if (null files) | |
| (find-file-noselect filename) | |
| (if async | |
| (let (result) | |
| ;; Create one thread per file. | |
| (setq threads | |
| (mapcar | |
| (lambda (file) | |
| (make-thread | |
| (lambda () (find-file-noselect file)) | |
| (concat "find-file-noselect " file))) | |
| files)) | |
| ;; Collect the results. We use `vc-mutex' here in | |
| ;; order to let all `vc-refresh-state' threads run | |
| ;; after the file visiting operations. | |
| (with-mutex vc-mutex | |
| (thread-yield) | |
| (dolist (thread threads result) | |
| (setq result (with-demoted-errors | |
| (cons (thread-join thread) result)))))) | |
| (mapcar #'find-file-noselect files)))) | |
| (let* ((buf (get-file-buffer filename)) | |
| (truename (abbreviate-file-name (file-truename filename))) | |
| (attributes (file-attributes truename)) | |
| (number (nthcdr 10 attributes)) | |
| ;; Find any buffer for a file that has same truename. | |
| (other (and (not buf) (find-buffer-visiting filename)))) | |
| ;; Let user know if there is a buffer with the same truename. | |
| (if other | |
| (progn | |
| (or nowarn | |
| find-file-suppress-same-file-warnings | |
| (string-equal filename (buffer-file-name other)) | |
| (files--message "%s and %s are the same file" | |
| filename (buffer-file-name other))) | |
| ;; Optionally also find that buffer. | |
| (if (or find-file-existing-other-name find-file-visit-truename) | |
| (setq buf other)))) | |
| ;; Check to see if the file looks uncommonly large. | |
| (when (not (or buf nowarn)) | |
| (when (eq (abort-if-file-too-large | |
| (file-attribute-size attributes) "open" filename t) | |
| 'raw) | |
| (setf rawfile t)) | |
| (warn-maybe-out-of-memory (file-attribute-size attributes))) | |
| (if buf | |
| ;; We are using an existing buffer. | |
| (let (nonexistent) | |
| (or nowarn | |
| (verify-visited-file-modtime buf) | |
| (cond ((not (file-exists-p filename)) | |
| (setq nonexistent t) | |
| (message "File %s no longer exists!" filename)) | |
| ;; Certain files should be reverted automatically | |
| ;; if they have changed on disk and not in the buffer. | |
| ((and (not (buffer-modified-p buf)) | |
| (let ((tail revert-without-query) | |
| (found nil)) | |
| (while tail | |
| (if (string-match (car tail) filename) | |
| (setq found t)) | |
| (setq tail (cdr tail))) | |
| found)) | |
| (with-current-buffer buf | |
| (message "Reverting file %s..." filename) | |
| (revert-buffer t t) | |
| (message "Reverting file %s...done" filename))) | |
| ((yes-or-no-p | |
| (if (string= (file-name-nondirectory filename) | |
| (buffer-name buf)) | |
| (format | |
| (if (buffer-modified-p buf) | |
| "File %s changed on disk. Discard your edits? " | |
| "File %s changed on disk. Reread from disk? ") | |
| (file-name-nondirectory filename)) | |
| (format | |
| (if (buffer-modified-p buf) | |
| "File %s changed on disk. Discard your edits in %s? " | |
| "File %s changed on disk. Reread from disk into %s? ") | |
| (file-name-nondirectory filename) | |
| (buffer-name buf)))) | |
| (with-current-buffer buf | |
| (revert-buffer t t))))) | |
| (with-current-buffer buf | |
| ;; Check if a formerly read-only file has become | |
| ;; writable and vice versa, but if the buffer agrees | |
| ;; with the new state of the file, that is ok too. | |
| (let ((read-only (not (file-writable-p buffer-file-name)))) | |
| (unless (or nonexistent | |
| (eq read-only buffer-file-read-only) | |
| (eq read-only buffer-read-only)) | |
| (when (or nowarn | |
| (let* ((new-status | |
| (if read-only "read-only" "writable")) | |
| (question | |
| (format "File %s is %s on disk. Make buffer %s, too? " | |
| buffer-file-name | |
| new-status new-status))) | |
| (y-or-n-p question))) | |
| (setq buffer-read-only read-only))) | |
| (setq buffer-file-read-only read-only)) | |
| (unless (or (eq (null rawfile) (null find-file-literally)) | |
| nonexistent | |
| ;; It is confusing to ask whether to visit | |
| ;; non-literally if they have the file in | |
| ;; hexl-mode or image-mode. | |
| (memq major-mode '(hexl-mode image-mode))) | |
| (if (buffer-modified-p) | |
| (if (y-or-n-p | |
| (format | |
| (if rawfile | |
| "The file %s is already visited normally, | |
| and you have edited the buffer. Now you have asked to visit it literally, | |
| meaning no coding system handling, format conversion, or local variables. | |
| Emacs can visit a file in only one way at a time. | |
| Do you want to save the file, and visit it literally instead? " | |
| "The file %s is already visited literally, | |
| meaning no coding system handling, format conversion, or local variables. | |
| You have edited the buffer. Now you have asked to visit the file normally, | |
| but Emacs can visit a file in only one way at a time. | |
| Do you want to save the file, and visit it normally instead? ") | |
| (file-name-nondirectory filename))) | |
| (progn | |
| (save-buffer) | |
| (find-file-noselect-1 buf filename nowarn | |
| rawfile truename number)) | |
| (if (y-or-n-p | |
| (format | |
| (if rawfile | |
| "\ | |
| Do you want to discard your changes, and visit the file literally now? " | |
| "\ | |
| Do you want to discard your changes, and visit the file normally now? "))) | |
| (find-file-noselect-1 buf filename nowarn | |
| rawfile truename number) | |
| (error (if rawfile "File already visited non-literally" | |
| "File already visited literally")))) | |
| (if (y-or-n-p | |
| (format | |
| (if rawfile | |
| "The file %s is already visited normally. | |
| You have asked to visit it literally, | |
| meaning no coding system decoding, format conversion, or local variables. | |
| But Emacs can visit a file in only one way at a time. | |
| Do you want to revisit the file literally now? " | |
| "The file %s is already visited literally, | |
| meaning no coding system decoding, format conversion, or local variables. | |
| You have asked to visit it normally, | |
| but Emacs can visit a file in only one way at a time. | |
| Do you want to revisit the file normally now? ") | |
| (file-name-nondirectory filename))) | |
| (find-file-noselect-1 buf filename nowarn | |
| rawfile truename number) | |
| (error (if rawfile "File already visited non-literally" | |
| "File already visited literally")))))) | |
| ;; Return the buffer we are using. | |
| buf) | |
| ;; Create a new buffer. | |
| (setq buf (create-file-buffer filename)) | |
| ;; find-file-noselect-1 may use a different buffer. | |
| (find-file-noselect-1 buf filename nowarn | |
| rawfile truename number)))))) | |
| (defun find-file-noselect-1 (buf filename nowarn rawfile truename number) | |
| (let (error) | |
| (with-current-buffer buf | |
| (kill-local-variable 'find-file-literally) | |
| ;; Needed in case we are re-visiting the file with a different | |
| ;; text representation. | |
| (kill-local-variable 'buffer-file-coding-system) | |
| (kill-local-variable 'cursor-type) | |
| (let ((inhibit-read-only t)) | |
| (erase-buffer)) | |
| (and (not rawfile) | |
| (set-buffer-multibyte t)) | |
| (if rawfile | |
| (condition-case () | |
| (let ((inhibit-read-only t)) | |
| (insert-file-contents-literally filename t)) | |
| (file-error | |
| (when (and (file-exists-p filename) | |
| (not (file-readable-p filename))) | |
| (kill-buffer buf) | |
| (signal 'file-error (list "File is not readable" | |
| filename))) | |
| ;; Unconditionally set error | |
| (setq error t))) | |
| (condition-case () | |
| (let ((inhibit-read-only t)) | |
| (insert-file-contents filename t)) | |
| (file-error | |
| (when (and (file-exists-p filename) | |
| (not (file-readable-p filename))) | |
| (kill-buffer buf) | |
| (signal 'file-error (list "File is not readable" | |
| filename))) | |
| ;; Run find-file-not-found-functions until one returns non-nil. | |
| (or (run-hook-with-args-until-success 'find-file-not-found-functions) | |
| ;; If they fail too, set error. | |
| (setq error t))))) | |
| ;; Record the file's truename, and maybe use that as visited name. | |
| (setq buffer-file-truename | |
| (if (equal filename buffer-file-name) | |
| truename | |
| (abbreviate-file-name (file-truename buffer-file-name)))) | |
| (setq buffer-file-number number) | |
| (if find-file-visit-truename | |
| (setq buffer-file-name (expand-file-name buffer-file-truename))) | |
| ;; Set buffer's default directory to that of the file. | |
| (setq default-directory (file-name-directory buffer-file-name)) | |
| ;; Turn off backup files for certain file names. Since | |
| ;; this is a permanent local, the major mode won't eliminate it. | |
| (and backup-enable-predicate | |
| (not (funcall backup-enable-predicate buffer-file-name)) | |
| (progn | |
| (make-local-variable 'backup-inhibited) | |
| (setq backup-inhibited t))) | |
| (if rawfile | |
| (progn | |
| (set-buffer-multibyte nil) | |
| (setq buffer-file-coding-system 'no-conversion) | |
| (set-buffer-major-mode buf) | |
| (setq-local find-file-literally t)) | |
| (after-find-file error (not nowarn))) | |
| (current-buffer)))) | |
| (defun insert-file-contents-literally (filename &optional visit beg end replace) | |
| "Like `insert-file-contents', but only reads in the file literally. | |
| See `insert-file-contents' for an explanation of the parameters. | |
| A buffer may be modified in several ways after reading into the buffer, | |
| due to Emacs features such as format decoding, character code | |
| conversion, `find-file-hook', automatic uncompression, etc. | |
| This function ensures that none of these modifications will take place." | |
| (let ((format-alist nil) | |
| (after-insert-file-functions nil) | |
| (coding-system-for-read 'no-conversion) | |
| (coding-system-for-write 'no-conversion) | |
| (inhibit-file-name-handlers | |
| ;; FIXME: Yuck!! We should turn insert-file-contents-literally | |
| ;; into a file operation instead! | |
| (append '(jka-compr-handler image-file-handler epa-file-handler) | |
| (and (eq inhibit-file-name-operation 'insert-file-contents) | |
| inhibit-file-name-handlers))) | |
| (inhibit-file-name-operation 'insert-file-contents)) | |
| (insert-file-contents filename visit beg end replace))) | |
| (defun insert-file-1 (filename insert-func) | |
| (if (file-directory-p filename) | |
| (signal 'file-error (list "Opening input file" "Is a directory" | |
| filename))) | |
| ;; Check whether the file is uncommonly large | |
| (abort-if-file-too-large (file-attribute-size (file-attributes filename)) | |
| "insert" filename) | |
| (let* ((buffer (find-buffer-visiting (abbreviate-file-name (file-truename filename)) | |
| #'buffer-modified-p)) | |
| (tem (funcall insert-func filename))) | |
| (push-mark (+ (point) (car (cdr tem)))) | |
| (when buffer | |
| (message "File %s already visited and modified in buffer %s" | |
| filename (buffer-name buffer))))) | |
| (defun insert-file-literally (filename) | |
| "Insert contents of file FILENAME into buffer after point with no conversion. | |
| This function is meant for the user to run interactively. | |
| Don't call it from programs! Use `insert-file-contents-literally' instead. | |
| \(Its calling sequence is different; see its documentation)." | |
| (declare (interactive-only insert-file-contents-literally)) | |
| (interactive "*fInsert file literally: ") | |
| (insert-file-1 filename #'insert-file-contents-literally)) | |
| (defvar find-file-literally nil | |
| "Non-nil if this buffer was made by `find-file-literally' or equivalent. | |
| This has the `permanent-local' property, which takes effect if you | |
| make the variable buffer-local.") | |
| (put 'find-file-literally 'permanent-local t) | |
| (defun find-file-literally (filename &optional async) | |
| "Visit file FILENAME with no conversion of any kind. | |
| Format conversion and character code conversion are both disabled, | |
| and multibyte characters are disabled in the resulting buffer. | |
| The major mode used is Fundamental mode regardless of the file name, | |
| and local variable specifications in the file are ignored. | |
| Automatic uncompression and adding a newline at the end of the | |
| file due to `require-final-newline' is also disabled. | |
| If Emacs already has a buffer that is visiting the file, | |
| this command asks you whether to visit it literally instead. | |
| If ASYNC is non-nil, the file will be loaded into the buffer | |
| asynchronously. Interactively, this is indicated by setting | |
| `execute-file-commands-asynchronously' to a proper non-nil value. | |
| This behavior can be toggled by \\[universal-async-argument] | |
| prior the command invocation. | |
| In non-interactive use, the value is the buffer where the file is | |
| visited literally. If the file was visited in a buffer before | |
| this command was invoked, it will reuse the existing buffer, | |
| regardless of whether it was created literally or not; however, | |
| the contents of that buffer will be the literal text of the file | |
| without any conversions. | |
| In a Lisp program, if you want to be sure of accessing a file's | |
| contents literally, you should create a temporary buffer and then read | |
| the file contents into it using `insert-file-contents-literally'." | |
| (interactive | |
| (find-file-read-args "Find file literally: " | |
| (confirm-nonexistent-file-or-buffer))) | |
| (find-file-with-threads filename async | |
| (switch-to-buffer (find-file-noselect filename nil t nil async)))) | |
| (defun after-find-file (&optional error warn noauto | |
| _after-find-file-from-revert-buffer | |
| nomodes) | |
| "Called after finding a file and by the default revert function. | |
| Sets buffer mode, parses file-local and directory-local variables. | |
| Optional args ERROR, WARN, and NOAUTO: ERROR non-nil means there was an | |
| error in reading the file. WARN non-nil means warn if there | |
| exists an auto-save file more recent than the visited file. | |
| NOAUTO means don't mess with auto-save mode. | |
| Fourth arg AFTER-FIND-FILE-FROM-REVERT-BUFFER is ignored | |
| \(see `revert-buffer-in-progress-p' for similar functionality). | |
| Fifth arg NOMODES non-nil means don't alter the file's modes. | |
| Finishes by calling the functions in `find-file-hook' | |
| unless NOMODES is non-nil." | |
| (setq buffer-read-only (not (file-writable-p buffer-file-name))) | |
| (if noninteractive | |
| nil | |
| (let* (not-serious | |
| (msg | |
| (cond | |
| ((not warn) nil) | |
| ((and error (file-attributes buffer-file-name)) | |
| (setq buffer-read-only t) | |
| (if (and (file-symlink-p buffer-file-name) | |
| (not (file-exists-p | |
| (file-chase-links buffer-file-name)))) | |
| "Symbolic link that points to nonexistent file" | |
| "File exists, but cannot be read")) | |
| ((not buffer-read-only) | |
| (if (and warn | |
| ;; No need to warn if buffer is auto-saved | |
| ;; under the name of the visited file. | |
| (not (and buffer-file-name | |
| auto-save-visited-file-name)) | |
| (file-newer-than-file-p (or buffer-auto-save-file-name | |
| (make-auto-save-file-name)) | |
| buffer-file-name)) | |
| (format "%s has auto save data; consider M-x recover-this-file" | |
| (file-name-nondirectory buffer-file-name)) | |
| (setq not-serious t) | |
| (if error "(New file)" nil))) | |
| ((not error) | |
| (setq not-serious t) | |
| "Note: file is write protected") | |
| ((file-attributes (directory-file-name default-directory)) | |
| "File not found and directory write-protected") | |
| ((file-exists-p (file-name-directory buffer-file-name)) | |
| (setq buffer-read-only nil)) | |
| (t | |
| (setq buffer-read-only nil) | |
| "Use M-x make-directory RET RET to create the directory and its parents")))) | |
| (when msg | |
| (message "%s" msg) | |
| (or not-serious (sit-for 1 t)))) | |
| (when (and auto-save-default (not noauto)) | |
| (auto-save-mode 1))) | |
| ;; Make people do a little extra work (C-x C-q) | |
| ;; before altering a backup file. | |
| ;; When a file is marked read-only, | |
| ;; make the buffer read-only even if root is looking at it. | |
| (unless buffer-read-only | |
| (when (or (backup-file-name-p buffer-file-name) | |
| (let ((modes (file-modes (buffer-file-name)))) | |
| (and modes (zerop (logand modes #o222))))) | |
| (setq buffer-read-only t))) | |
| (unless nomodes | |
| (when (and view-read-only view-mode) | |
| (view-mode -1)) | |
| (normal-mode t) | |
| ;; If requested, add a newline at the end of the file. | |
| (and (memq require-final-newline '(visit visit-save)) | |
| (> (point-max) (point-min)) | |
| (/= (char-after (1- (point-max))) ?\n) | |
| (not (and (eq selective-display t) | |
| (= (char-after (1- (point-max))) ?\r))) | |
| (not buffer-read-only) | |
| (save-excursion | |
| (goto-char (point-max)) | |
| (ignore-errors (insert "\n")))) | |
| (when (and buffer-read-only | |
| view-read-only | |
| (not (eq (get major-mode 'mode-class) 'special))) | |
| (view-mode-enter)) | |
| (run-hooks 'find-file-hook))) | |
| (define-obsolete-function-alias 'report-errors 'with-demoted-errors "25.1") | |
| (defun normal-mode (&optional find-file) | |
| "Choose the major mode for this buffer automatically. | |
| Also sets up any specified local variables of the file or its directory. | |
| Uses the visited file name, the -*- line, and the local variables spec. | |
| This function is called automatically from `find-file'. In that case, | |
| we may set up the file-specified mode and local variables, | |
| depending on the value of `enable-local-variables'. | |
| In addition, if `local-enable-local-variables' is nil, we do | |
| not set local variables (though we do notice a mode specified with -*-.) | |
| `enable-local-variables' is ignored if you run `normal-mode' interactively, | |
| or from Lisp without specifying the optional argument FIND-FILE; | |
| in that case, this function acts as if `enable-local-variables' were t." | |
| (interactive) | |
| (kill-all-local-variables) | |
| (unless delay-mode-hooks | |
| (run-hooks 'change-major-mode-after-body-hook | |
| 'after-change-major-mode-hook)) | |
| (let ((enable-local-variables (or (not find-file) enable-local-variables))) | |
| ;; FIXME this is less efficient than it could be, since both | |
| ;; s-a-m and h-l-v may parse the same regions, looking for "mode:". | |
| (with-demoted-errors "File mode specification error: %s" | |
| (set-auto-mode)) | |
| ;; `delay-mode-hooks' being non-nil will have prevented the major | |
| ;; mode's call to `run-mode-hooks' from calling | |
| ;; `hack-local-variables'. In that case, call it now. | |
| (when delay-mode-hooks | |
| (with-demoted-errors "File local-variables error: %s" | |
| (hack-local-variables 'no-mode)))) | |
| ;; Turn font lock off and on, to make sure it takes account of | |
| ;; whatever file local variables are relevant to it. | |
| (when (and font-lock-mode | |
| ;; Font-lock-mode (now in font-core.el) can be ON when | |
| ;; font-lock.el still hasn't been loaded. | |
| (boundp 'font-lock-keywords) | |
| (eq (car font-lock-keywords) t)) | |
| (setq font-lock-keywords (cadr font-lock-keywords)) | |
| (font-lock-mode 1))) | |
| (defcustom auto-mode-case-fold t | |
| "Non-nil means to try second pass through `auto-mode-alist'. | |
| This means that if the first case-sensitive search through the alist fails | |
| to find a matching major mode, a second case-insensitive search is made. | |
| On systems with case-insensitive file names, this variable is ignored, | |
| since only a single case-insensitive search through the alist is made." | |
| :group 'files | |
| :version "22.1" | |
| :type 'boolean) | |
| (defvar auto-mode-alist | |
| ;; Note: The entries for the modes defined in cc-mode.el (c-mode, | |
| ;; c++-mode, java-mode and more) are added through autoload | |
| ;; directives in that file. That way is discouraged since it | |
| ;; spreads out the definition of the initial value. | |
| (mapcar | |
| (lambda (elt) | |
| (cons (purecopy (car elt)) (cdr elt))) | |
| `(;; do this first, so that .html.pl is Polish html, not Perl | |
| ("\\.[sx]?html?\\(\\.[a-zA-Z_]+\\)?\\'" . mhtml-mode) | |
| ("\\.svgz?\\'" . image-mode) | |
| ("\\.svgz?\\'" . xml-mode) | |
| ("\\.x[bp]m\\'" . image-mode) | |
| ("\\.x[bp]m\\'" . c-mode) | |
| ("\\.p[bpgn]m\\'" . image-mode) | |
| ("\\.tiff?\\'" . image-mode) | |
| ("\\.gif\\'" . image-mode) | |
| ("\\.png\\'" . image-mode) | |
| ("\\.jpe?g\\'" . image-mode) | |
| ("\\.te?xt\\'" . text-mode) | |
| ("\\.[tT]e[xX]\\'" . tex-mode) | |
| ("\\.ins\\'" . tex-mode) ;Installation files for TeX packages. | |
| ("\\.ltx\\'" . latex-mode) | |
| ("\\.dtx\\'" . doctex-mode) | |
| ("\\.org\\'" . org-mode) | |
| ("\\.el\\'" . emacs-lisp-mode) | |
| ("Project\\.ede\\'" . emacs-lisp-mode) | |
| ("\\.\\(scm\\|stk\\|ss\\|sch\\)\\'" . scheme-mode) | |
| ("\\.l\\'" . lisp-mode) | |
| ("\\.li?sp\\'" . lisp-mode) | |
| ("\\.[fF]\\'" . fortran-mode) | |
| ("\\.for\\'" . fortran-mode) | |
| ("\\.p\\'" . pascal-mode) | |
| ("\\.pas\\'" . pascal-mode) | |
| ("\\.\\(dpr\\|DPR\\)\\'" . delphi-mode) | |
| ("\\.ad[abs]\\'" . ada-mode) | |
| ("\\.ad[bs].dg\\'" . ada-mode) | |
| ("\\.\\([pP]\\([Llm]\\|erl\\|od\\)\\|al\\)\\'" . perl-mode) | |
| ("Imakefile\\'" . makefile-imake-mode) | |
| ("Makeppfile\\(?:\\.mk\\)?\\'" . makefile-makepp-mode) ; Put this before .mk | |
| ("\\.makepp\\'" . makefile-makepp-mode) | |
| ,@(if (memq system-type '(berkeley-unix darwin)) | |
| '(("\\.mk\\'" . makefile-bsdmake-mode) | |
| ("\\.make\\'" . makefile-bsdmake-mode) | |
| ("GNUmakefile\\'" . makefile-gmake-mode) | |
| ("[Mm]akefile\\'" . makefile-bsdmake-mode)) | |
| '(("\\.mk\\'" . makefile-gmake-mode) ; Might be any make, give GNU the host advantage | |
| ("\\.make\\'" . makefile-gmake-mode) | |
| ("[Mm]akefile\\'" . makefile-gmake-mode))) | |
| ("\\.am\\'" . makefile-automake-mode) | |
| ;; Less common extensions come here | |
| ;; so more common ones above are found faster. | |
| ("\\.texinfo\\'" . texinfo-mode) | |
| ("\\.te?xi\\'" . texinfo-mode) | |
| ("\\.[sS]\\'" . asm-mode) | |
| ("\\.asm\\'" . asm-mode) | |
| ("\\.css\\'" . css-mode) | |
| ("\\.mixal\\'" . mixal-mode) | |
| ("\\.gcov\\'" . compilation-mode) | |
| ;; Besides .gdbinit, gdb documents other names to be usable for init | |
| ;; files, cross-debuggers can use something like | |
| ;; .PROCESSORNAME-gdbinit so that the host and target gdbinit files | |
| ;; don't interfere with each other. | |
| ("/\\.[a-z0-9-]*gdbinit" . gdb-script-mode) | |
| ;; GDB 7.5 introduced OBJFILE-gdb.gdb script files; e.g. a file | |
| ;; named 'emacs-gdb.gdb', if it exists, will be automatically | |
| ;; loaded when GDB reads an objfile called 'emacs'. | |
| ("-gdb\\.gdb" . gdb-script-mode) | |
| ("[cC]hange\\.?[lL]og?\\'" . change-log-mode) | |
| ("[cC]hange[lL]og[-.][0-9]+\\'" . change-log-mode) | |
| ("\\$CHANGE_LOG\\$\\.TXT" . change-log-mode) | |
| ("\\.scm\\.[0-9]*\\'" . scheme-mode) | |
| ("\\.[ckz]?sh\\'\\|\\.shar\\'\\|/\\.z?profile\\'" . sh-mode) | |
| ("\\.bash\\'" . sh-mode) | |
| ("\\(/\\|\\`\\)\\.\\(bash_\\(profile\\|history\\|log\\(in\\|out\\)\\)\\|z?log\\(in\\|out\\)\\)\\'" . sh-mode) | |
| ("\\(/\\|\\`\\)\\.\\(shrc\\|zshrc\\|m?kshrc\\|bashrc\\|t?cshrc\\|esrc\\)\\'" . sh-mode) | |
| ("\\(/\\|\\`\\)\\.\\([kz]shenv\\|xinitrc\\|startxrc\\|xsession\\)\\'" . sh-mode) | |
| ("\\.m?spec\\'" . sh-mode) | |
| ("\\.m[mes]\\'" . nroff-mode) | |
| ("\\.man\\'" . nroff-mode) | |
| ("\\.sty\\'" . latex-mode) | |
| ("\\.cl[so]\\'" . latex-mode) ;LaTeX 2e class option | |
| ("\\.bbl\\'" . latex-mode) | |
| ("\\.bib\\'" . bibtex-mode) | |
| ("\\.bst\\'" . bibtex-style-mode) | |
| ("\\.sql\\'" . sql-mode) | |
| ;; These .m4 files are Autoconf files. | |
| ("\\(acinclude\\|aclocal\\|acsite\\)\\.m4\\'" . autoconf-mode) | |
| ("\\.m[4c]\\'" . m4-mode) | |
| ("\\.mf\\'" . metafont-mode) | |
| ("\\.mp\\'" . metapost-mode) | |
| ("\\.vhdl?\\'" . vhdl-mode) | |
| ("\\.article\\'" . text-mode) | |
| ("\\.letter\\'" . text-mode) | |
| ("\\.i?tcl\\'" . tcl-mode) | |
| ("\\.exp\\'" . tcl-mode) | |
| ("\\.itk\\'" . tcl-mode) | |
| ("\\.icn\\'" . icon-mode) | |
| ("\\.sim\\'" . simula-mode) | |
| ("\\.mss\\'" . scribe-mode) | |
| ;; The Fortran standard does not say anything about file extensions. | |
| ;; .f90 was widely used for F90, now we seem to be trapped into | |
| ;; using a different extension for each language revision. | |
| ;; Anyway, the following extensions are supported by gfortran. | |
| ("\\.f9[05]\\'" . f90-mode) | |
| ("\\.f0[38]\\'" . f90-mode) | |
| ("\\.indent\\.pro\\'" . fundamental-mode) ; to avoid idlwave-mode | |
| ("\\.\\(pro\\|PRO\\)\\'" . idlwave-mode) | |
| ("\\.srt\\'" . srecode-template-mode) | |
| ("\\.prolog\\'" . prolog-mode) | |
| ("\\.tar\\'" . tar-mode) | |
| ;; The list of archive file extensions should be in sync with | |
| ;; `auto-coding-alist' with `no-conversion' coding system. | |
| ("\\.\\(\ | |
| arc\\|zip\\|lzh\\|lha\\|zoo\\|[jew]ar\\|xpi\\|rar\\|cbr\\|7z\\|\ | |
| ARC\\|ZIP\\|LZH\\|LHA\\|ZOO\\|[JEW]AR\\|XPI\\|RAR\\|CBR\\|7Z\\)\\'" . archive-mode) | |
| ("\\.oxt\\'" . archive-mode) ;(Open|Libre)Office extensions. | |
| ("\\.\\(deb\\|[oi]pk\\)\\'" . archive-mode) ; Debian/Opkg packages. | |
| ;; Mailer puts message to be edited in | |
| ;; /tmp/Re.... or Message | |
| ("\\`/tmp/Re" . text-mode) | |
| ("/Message[0-9]*\\'" . text-mode) | |
| ;; some news reader is reported to use this | |
| ("\\`/tmp/fol/" . text-mode) | |
| ("\\.oak\\'" . scheme-mode) | |
| ("\\.sgml?\\'" . sgml-mode) | |
| ("\\.x[ms]l\\'" . xml-mode) | |
| ("\\.dbk\\'" . xml-mode) | |
| ("\\.dtd\\'" . sgml-mode) | |
| ("\\.ds\\(ss\\)?l\\'" . dsssl-mode) | |
| ("\\.js[mx]?\\'" . javascript-mode) | |
| ;; https://en.wikipedia.org/wiki/.har | |
| ("\\.har\\'" . javascript-mode) | |
| ("\\.json\\'" . javascript-mode) | |
| ("\\.[ds]?va?h?\\'" . verilog-mode) | |
| ("\\.by\\'" . bovine-grammar-mode) | |
| ("\\.wy\\'" . wisent-grammar-mode) | |
| ;; .emacs or .gnus or .viper following a directory delimiter in | |
| ;; Unix or MS-DOS syntax. | |
| ("[:/\\]\\..*\\(emacs\\|gnus\\|viper\\)\\'" . emacs-lisp-mode) | |
| ("\\`\\..*emacs\\'" . emacs-lisp-mode) | |
| ;; _emacs following a directory delimiter in MS-DOS syntax | |
| ("[:/]_emacs\\'" . emacs-lisp-mode) | |
| ("/crontab\\.X*[0-9]+\\'" . shell-script-mode) | |
| ("\\.ml\\'" . lisp-mode) | |
| ;; Linux-2.6.9 uses some different suffix for linker scripts: | |
| ;; "ld", "lds", "lds.S", "lds.in", "ld.script", and "ld.script.balo". | |
| ;; eCos uses "ld" and "ldi". Netbsd uses "ldscript.*". | |
| ("\\.ld[si]?\\'" . ld-script-mode) | |
| ("ld\\.?script\\'" . ld-script-mode) | |
| ;; .xs is also used for ld scripts, but seems to be more commonly | |
| ;; associated with Perl .xs files (C with Perl bindings). (Bug#7071) | |
| ("\\.xs\\'" . c-mode) | |
| ;; Explained in binutils ld/genscripts.sh. Eg: | |
| ;; A .x script file is the default script. | |
| ;; A .xr script is for linking without relocation (-r flag). Etc. | |
| ("\\.x[abdsru]?[cnw]?\\'" . ld-script-mode) | |
| ("\\.zone\\'" . dns-mode) | |
| ("\\.soa\\'" . dns-mode) | |
| ;; Common Lisp ASDF package system. | |
| ("\\.asd\\'" . lisp-mode) | |
| ("\\.\\(asn\\|mib\\|smi\\)\\'" . snmp-mode) | |
| ("\\.\\(as\\|mi\\|sm\\)2\\'" . snmpv2-mode) | |
| ("\\.\\(diffs?\\|patch\\|rej\\)\\'" . diff-mode) | |
| ("\\.\\(dif\\|pat\\)\\'" . diff-mode) ; for MS-DOS | |
| ("\\.[eE]?[pP][sS]\\'" . ps-mode) | |
| ("\\.\\(?:PDF\\|DVI\\|OD[FGPST]\\|DOCX\\|XLSX?\\|PPTX?\\|pdf\\|djvu\\|dvi\\|od[fgpst]\\|docx\\|xlsx?\\|pptx?\\)\\'" . doc-view-mode-maybe) | |
| ("configure\\.\\(ac\\|in\\)\\'" . autoconf-mode) | |
| ("\\.s\\(v\\|iv\\|ieve\\)\\'" . sieve-mode) | |
| ("BROWSE\\'" . ebrowse-tree-mode) | |
| ("\\.ebrowse\\'" . ebrowse-tree-mode) | |
| ("#\\*mail\\*" . mail-mode) | |
| ("\\.g\\'" . antlr-mode) | |
| ("\\.mod\\'" . m2-mode) | |
| ("\\.ses\\'" . ses-mode) | |
| ("\\.docbook\\'" . sgml-mode) | |
| ("\\.com\\'" . dcl-mode) | |
| ("/config\\.\\(?:bat\\|log\\)\\'" . fundamental-mode) | |
| ("/\\.\\(authinfo\\|netrc\\)\\'" . authinfo-mode) | |
| ;; Windows candidates may be opened case sensitively on Unix | |
| ("\\.\\(?:[iI][nN][iI]\\|[lL][sS][tT]\\|[rR][eE][gG]\\|[sS][yY][sS]\\)\\'" . conf-mode) | |
| ("\\.la\\'" . conf-unix-mode) | |
| ("\\.ppd\\'" . conf-ppd-mode) | |
| ("java.+\\.conf\\'" . conf-javaprop-mode) | |
| ("\\.properties\\(?:\\.[a-zA-Z0-9._-]+\\)?\\'" . conf-javaprop-mode) | |
| ("\\.toml\\'" . conf-toml-mode) | |
| ("\\.desktop\\'" . conf-desktop-mode) | |
| ("/\\.redshift.conf\\'" . conf-windows-mode) | |
| ("\\`/etc/\\(?:DIR_COLORS\\|ethers\\|.?fstab\\|.*hosts\\|lesskey\\|login\\.?de\\(?:fs\\|vperm\\)\\|magic\\|mtab\\|pam\\.d/.*\\|permissions\\(?:\\.d/.+\\)?\\|protocols\\|rpc\\|services\\)\\'" . conf-space-mode) | |
| ("\\`/etc/\\(?:acpid?/.+\\|aliases\\(?:\\.d/.+\\)?\\|default/.+\\|group-?\\|hosts\\..+\\|inittab\\|ksysguarddrc\\|opera6rc\\|passwd-?\\|shadow-?\\|sysconfig/.+\\)\\'" . conf-mode) | |
| ;; ChangeLog.old etc. Other change-log-mode entries are above; | |
| ;; this has lower priority to avoid matching changelog.sgml etc. | |
| ("[cC]hange[lL]og[-.][-0-9a-z]+\\'" . change-log-mode) | |
| ;; either user's dot-files or under /etc or some such | |
| ("/\\.?\\(?:gitconfig\\|gnokiirc\\|hgrc\\|kde.*rc\\|mime\\.types\\|wgetrc\\)\\'" . conf-mode) | |
| ;; alas not all ~/.*rc files are like this | |
| ("/\\.\\(?:asound\\|enigma\\|fetchmail\\|gltron\\|gtk\\|hxplayer\\|mairix\\|mbsync\\|msmtp\\|net\\|neverball\\|nvidia-settings-\\|offlineimap\\|qt/.+\\|realplayer\\|reportbug\\|rtorrent\\.\\|screen\\|scummvm\\|sversion\\|sylpheed/.+\\|xmp\\)rc\\'" . conf-mode) | |
| ("/\\.\\(?:gdbtkinit\\|grip\\|mpdconf\\|notmuch-config\\|orbital/.+txt\\|rhosts\\|tuxracer/options\\)\\'" . conf-mode) | |
| ("/\\.?X\\(?:default\\|resource\\|re\\)s\\>" . conf-xdefaults-mode) | |
| ("/X11.+app-defaults/\\|\\.ad\\'" . conf-xdefaults-mode) | |
| ("/X11.+locale/.+/Compose\\'" . conf-colon-mode) | |
| ;; this contains everything twice, with space and with colon :-( | |
| ("/X11.+locale/compose\\.dir\\'" . conf-javaprop-mode) | |
| ;; Get rid of any trailing .n.m and try again. | |
| ;; This is for files saved by cvs-merge that look like .#<file>.<rev> | |
| ;; or .#<file>.<rev>-<rev> or VC's <file>.~<rev>~. | |
| ;; Using mode nil rather than `ignore' would let the search continue | |
| ;; through this list (with the shortened name) rather than start over. | |
| ("\\.~?[0-9]+\\.[0-9][-.0-9]*~?\\'" nil t) | |
| ("\\.\\(?:orig\\|in\\|[bB][aA][kK]\\)\\'" nil t) | |
| ;; This should come after "in" stripping (e.g. config.h.in). | |
| ;; *.cf, *.cfg, *.conf, *.config[.local|.de_DE.UTF8|...], */config | |
| ("[/.]c\\(?:on\\)?f\\(?:i?g\\)?\\(?:\\.[a-zA-Z0-9._-]+\\)?\\'" . conf-mode-maybe) | |
| ;; The following should come after the ChangeLog pattern | |
| ;; for the sake of ChangeLog.1, etc. | |
| ;; and after the .scm.[0-9] and CVS' <file>.<rev> patterns too. | |
| ("\\.[1-9]\\'" . nroff-mode) | |
| ;; Image file types probably supported by `image-convert'. | |
| ("\\.art\\'" . image-mode) | |
| ("\\.avs\\'" . image-mode) | |
| ("\\.bmp\\'" . image-mode) | |
| ("\\.cmyk\\'" . image-mode) | |
| ("\\.cmyka\\'" . image-mode) | |
| ("\\.crw\\'" . image-mode) | |
| ("\\.dcr\\'" . image-mode) | |
| ("\\.dcx\\'" . image-mode) | |
| ("\\.dng\\'" . image-mode) | |
| ("\\.dpx\\'" . image-mode) | |
| ("\\.fax\\'" . image-mode) | |
| ("\\.hrz\\'" . image-mode) | |
| ("\\.icb\\'" . image-mode) | |
| ("\\.icc\\'" . image-mode) | |
| ("\\.icm\\'" . image-mode) | |
| ("\\.ico\\'" . image-mode) | |
| ("\\.icon\\'" . image-mode) | |
| ("\\.jbg\\'" . image-mode) | |
| ("\\.jbig\\'" . image-mode) | |
| ("\\.jng\\'" . image-mode) | |
| ("\\.jnx\\'" . image-mode) | |
| ("\\.miff\\'" . image-mode) | |
| ("\\.mng\\'" . image-mode) | |
| ("\\.mvg\\'" . image-mode) | |
| ("\\.otb\\'" . image-mode) | |
| ("\\.p7\\'" . image-mode) | |
| ("\\.pcx\\'" . image-mode) | |
| ("\\.pdb\\'" . image-mode) | |
| ("\\.pfa\\'" . image-mode) | |
| ("\\.pfb\\'" . image-mode) | |
| ("\\.picon\\'" . image-mode) | |
| ("\\.pict\\'" . image-mode) | |
| ("\\.rgb\\'" . image-mode) | |
| ("\\.rgba\\'" . image-mode) | |
| ("\\.tga\\'" . image-mode) | |
| ("\\.wbmp\\'" . image-mode) | |
| ("\\.webp\\'" . image-mode) | |
| ("\\.wmf\\'" . image-mode) | |
| ("\\.wpg\\'" . image-mode) | |
| ("\\.xcf\\'" . image-mode) | |
| ("\\.xmp\\'" . image-mode) | |
| ("\\.xwd\\'" . image-mode) | |
| ("\\.yuv\\'" . image-mode))) | |
| "Alist of filename patterns vs corresponding major mode functions. | |
| Each element looks like (REGEXP . FUNCTION) or (REGEXP FUNCTION NON-NIL). | |
| \(NON-NIL stands for anything that is not nil; the value does not matter.) | |
| Visiting a file whose name matches REGEXP specifies FUNCTION as the | |
| mode function to use. FUNCTION will be called, unless it is nil. | |
| If the element has the form (REGEXP FUNCTION NON-NIL), then after | |
| calling FUNCTION (if it's not nil), we delete the suffix that matched | |
| REGEXP and search the list again for another match. | |
| The extensions whose FUNCTION is `archive-mode' should also | |
| appear in `auto-coding-alist' with `no-conversion' coding system. | |
| See also `interpreter-mode-alist', which detects executable script modes | |
| based on the interpreters they specify to run, | |
| and `magic-mode-alist', which determines modes based on file contents.") | |
| (put 'auto-mode-alist 'risky-local-variable t) | |
| (defun conf-mode-maybe () | |
| "Select Conf mode or XML mode according to start of file." | |
| (if (save-excursion | |
| (save-restriction | |
| (widen) | |
| (goto-char (point-min)) | |
| (looking-at "<\\?xml \\|<!-- \\|<!DOCTYPE "))) | |
| (xml-mode) | |
| (conf-mode))) | |
| (defvar interpreter-mode-alist | |
| ;; Note: The entries for the modes defined in cc-mode.el (awk-mode | |
| ;; and pike-mode) are added through autoload directives in that | |
| ;; file. That way is discouraged since it spreads out the | |
| ;; definition of the initial value. | |
| (mapcar | |
| (lambda (l) | |
| (cons (purecopy (car l)) (cdr l))) | |
| '(("\\(mini\\)?perl5?" . perl-mode) | |
| ("wishx?" . tcl-mode) | |
| ("tcl\\(sh\\)?" . tcl-mode) | |
| ("expect" . tcl-mode) | |
| ("octave" . octave-mode) | |
| ("scm" . scheme-mode) | |
| ("[acjkwz]sh" . sh-mode) | |
| ("r?bash2?" . sh-mode) | |
| ("dash" . sh-mode) | |
| ("mksh" . sh-mode) | |
| ("\\(dt\\|pd\\|w\\)ksh" . sh-mode) | |
| ("es" . sh-mode) | |
| ("i?tcsh" . sh-mode) | |
| ("oash" . sh-mode) | |
| ("rc" . sh-mode) | |
| ("rpm" . sh-mode) | |
| ("sh5?" . sh-mode) | |
| ("tail" . text-mode) | |
| ("more" . text-mode) | |
| ("less" . text-mode) | |
| ("pg" . text-mode) | |
| ("make" . makefile-gmake-mode) ; Debian uses this | |
| ("guile" . scheme-mode) | |
| ("clisp" . lisp-mode) | |
| ("emacs" . emacs-lisp-mode))) | |
| "Alist mapping interpreter names to major modes. | |
| This is used for files whose first lines match `auto-mode-interpreter-regexp'. | |
| Each element looks like (REGEXP . MODE). | |
| If REGEXP matches the entire name (minus any directory part) of | |
| the interpreter specified in the first line of a script, enable | |
| major mode MODE. | |
| See also `auto-mode-alist'.") | |
| (define-obsolete-variable-alias 'inhibit-first-line-modes-regexps | |
| 'inhibit-file-local-variables-regexps "24.1") | |
| ;; TODO really this should be a list of modes (eg tar-mode), not regexps, | |
| ;; because we are duplicating info from auto-mode-alist. | |
| ;; TODO many elements of this list are also in auto-coding-alist. | |
| (defvar inhibit-local-variables-regexps | |
| (mapcar 'purecopy '("\\.tar\\'" "\\.t[bg]z\\'" | |
| "\\.arc\\'" "\\.zip\\'" "\\.lzh\\'" "\\.lha\\'" | |
| "\\.zoo\\'" "\\.[jew]ar\\'" "\\.xpi\\'" "\\.rar\\'" | |
| "\\.7z\\'" | |
| "\\.sx[dmicw]\\'" "\\.odt\\'" | |
| "\\.diff\\'" "\\.patch\\'" | |
| "\\.tiff?\\'" "\\.gif\\'" "\\.png\\'" "\\.jpe?g\\'")) | |
| "List of regexps matching file names in which to ignore local variables. | |
| This includes `-*-' lines as well as trailing \"Local Variables\" sections. | |
| Files matching this list are typically binary file formats. | |
| They may happen to contain sequences that look like local variable | |
| specifications, but are not really, or they may be containers for | |
| member files with their own local variable sections, which are | |
| not appropriate for the containing file. | |
| The function `inhibit-local-variables-p' uses this.") | |
| (define-obsolete-variable-alias 'inhibit-first-line-modes-suffixes | |
| 'inhibit-local-variables-suffixes "24.1") | |
| (defvar inhibit-local-variables-suffixes nil | |
| "List of regexps matching suffixes to remove from file names. | |
| The function `inhibit-local-variables-p' uses this: when checking | |
| a file name, it first discards from the end of the name anything that | |
| matches one of these regexps.") | |
| ;; Can't think of any situation in which you'd want this to be nil... | |
| (defvar inhibit-local-variables-ignore-case t | |
| "Non-nil means `inhibit-local-variables-p' ignores case.") | |
| (defun inhibit-local-variables-p () | |
| "Return non-nil if file local variables should be ignored. | |
| This checks the file (or buffer) name against `inhibit-local-variables-regexps' | |
| and `inhibit-local-variables-suffixes'. If | |
| `inhibit-local-variables-ignore-case' is non-nil, this ignores case." | |
| (let ((temp inhibit-local-variables-regexps) | |
| (name (if buffer-file-name | |
| (file-name-sans-versions buffer-file-name) | |
| (buffer-name))) | |
| (case-fold-search inhibit-local-variables-ignore-case)) | |
| (while (let ((sufs inhibit-local-variables-suffixes)) | |
| (while (and sufs (not (string-match (car sufs) name))) | |
| (setq sufs (cdr sufs))) | |
| sufs) | |
| (setq name (substring name 0 (match-beginning 0)))) | |
| (while (and temp | |
| (not (string-match (car temp) name))) | |
| (setq temp (cdr temp))) | |
| temp)) | |
| (defvar auto-mode-interpreter-regexp | |
| (purecopy "#![ \t]?\\([^ \t\n]*\ | |
| /bin/env[ \t]\\)?\\([^ \t\n]+\\)") | |
| "Regexp matching interpreters, for file mode determination. | |
| This regular expression is matched against the first line of a file | |
| to determine the file's mode in `set-auto-mode'. If it matches, the file | |
| is assumed to be interpreted by the interpreter matched by the second group | |
| of the regular expression. The mode is then determined as the mode | |
| associated with that interpreter in `interpreter-mode-alist'.") | |
| (defvar magic-mode-alist nil | |
| "Alist of buffer beginnings vs. corresponding major mode functions. | |
| Each element looks like (REGEXP . FUNCTION) or (MATCH-FUNCTION . FUNCTION). | |
| After visiting a file, if REGEXP matches the text at the beginning of the | |
| buffer (case-sensitively), or calling MATCH-FUNCTION returns non-nil, | |
| `normal-mode' will call FUNCTION rather than allowing `auto-mode-alist' to | |
| decide the buffer's major mode. | |
| If FUNCTION is nil, then it is not called. (That is a way of saying | |
| \"allow `auto-mode-alist' to decide for these files.\")") | |
| (put 'magic-mode-alist 'risky-local-variable t) | |
| (defvar magic-fallback-mode-alist | |
| (purecopy | |
| `((image-type-auto-detected-p . image-mode) | |
| ("\\(PK00\\)?[P]K\003\004" . archive-mode) ; zip | |
| ;; The < comes before the groups (but the first) to reduce backtracking. | |
| ;; TODO: UTF-16 <?xml may be preceded by a BOM 0xff 0xfe or 0xfe 0xff. | |
| ;; We use [ \t\r\n] instead of `\\s ' to make regex overflow less likely. | |
| (,(let* ((incomment-re "\\(?:[^-]\\|-[^-]\\)") | |
| (comment-re (concat "\\(?:!--" incomment-re "*-->[ \t\r\n]*<\\)"))) | |
| (concat "\\(?:<\\?xml[ \t\r\n]+[^>]*>\\)?[ \t\r\n]*<" | |
| comment-re "*" | |
| "\\(?:!DOCTYPE[ \t\r\n]+[^>]*>[ \t\r\n]*<[ \t\r\n]*" comment-re "*\\)?" | |
| "[Hh][Tt][Mm][Ll]")) | |
| . mhtml-mode) | |
| ("<!DOCTYPE[ \t\r\n]+[Hh][Tt][Mm][Ll]" . mhtml-mode) | |
| ;; These two must come after html, because they are more general: | |
| ("<\\?xml " . xml-mode) | |
| (,(let* ((incomment-re "\\(?:[^-]\\|-[^-]\\)") | |
| (comment-re (concat "\\(?:!--" incomment-re "*-->[ \t\r\n]*<\\)"))) | |
| (concat "[ \t\r\n]*<" comment-re "*!DOCTYPE ")) | |
| . sgml-mode) | |
| ("\320\317\021\340\241\261\032\341" . doc-view-mode-maybe) ; Word documents 1997-2004 | |
| ("%!PS" . ps-mode) | |
| ("# xmcd " . conf-unix-mode))) | |
| "Like `magic-mode-alist' but has lower priority than `auto-mode-alist'. | |
| Each element looks like (REGEXP . FUNCTION) or (MATCH-FUNCTION . FUNCTION). | |
| After visiting a file, if REGEXP matches the text at the beginning of the | |
| buffer (case-sensitively), or calling MATCH-FUNCTION returns non-nil, | |
| `normal-mode' will call FUNCTION, provided that `magic-mode-alist' and | |
| `auto-mode-alist' have not specified a mode for this file. | |
| If FUNCTION is nil, then it is not called.") | |
| (put 'magic-fallback-mode-alist 'risky-local-variable t) | |
| (defvar magic-mode-regexp-match-limit 4000 | |
| "Upper limit on `magic-mode-alist' regexp matches. | |
| Also applies to `magic-fallback-mode-alist'.") | |
| (defun set-auto-mode (&optional keep-mode-if-same) | |
| "Select major mode appropriate for current buffer. | |
| To find the right major mode, this function checks for a -*- mode tag | |
| checks for a `mode:' entry in the Local Variables section of the file, | |
| checks if it uses an interpreter listed in `interpreter-mode-alist', | |
| matches the buffer beginning against `magic-mode-alist', | |
| compares the filename against the entries in `auto-mode-alist', | |
| then matches the buffer beginning against `magic-fallback-mode-alist'. | |
| If `enable-local-variables' is nil, or if the file name matches | |
| `inhibit-local-variables-regexps', this function does not check | |
| for any mode: tag anywhere in the file. If `local-enable-local-variables' | |
| is nil, then the only mode: tag that can be relevant is a -*- one. | |
| If the optional argument KEEP-MODE-IF-SAME is non-nil, then we | |
| set the major mode only if that would change it. In other words | |
| we don't actually set it to the same mode the buffer already has." | |
| ;; Look for -*-MODENAME-*- or -*- ... mode: MODENAME; ... -*- | |
| (let ((try-locals (not (inhibit-local-variables-p))) | |
| end done mode modes) | |
| ;; Once we drop the deprecated feature where mode: is also allowed to | |
| ;; specify minor-modes (ie, there can be more than one "mode:"), we can | |
| ;; remove this section and just let (hack-local-variables t) handle it. | |
| ;; Find a -*- mode tag. | |
| (save-excursion | |
| (goto-char (point-min)) | |
| (skip-chars-forward " \t\n") | |
| ;; Note by design local-enable-local-variables does not matter here. | |
| (and enable-local-variables | |
| try-locals | |
| (setq end (set-auto-mode-1)) | |
| (if (save-excursion (search-forward ":" end t)) | |
| ;; Find all specifications for the `mode:' variable | |
| ;; and execute them left to right. | |
| (while (let ((case-fold-search t)) | |
| (or (and (looking-at "mode:") | |
| (goto-char (match-end 0))) | |
| (re-search-forward "[ \t;]mode:" end t))) | |
| (skip-chars-forward " \t") | |
| (let ((beg (point))) | |
| (if (search-forward ";" end t) | |
| (forward-char -1) | |
| (goto-char end)) | |
| (skip-chars-backward " \t") | |
| (push (intern (concat (downcase (buffer-substring beg (point))) "-mode")) | |
| modes))) | |
| ;; Simple -*-MODE-*- case. | |
| (push (intern (concat (downcase (buffer-substring (point) end)) | |
| "-mode")) | |
| modes)))) | |
| ;; If we found modes to use, invoke them now, outside the save-excursion. | |
| (if modes | |
| (catch 'nop | |
| (dolist (mode (nreverse modes)) | |
| (if (not (functionp mode)) | |
| (message "Ignoring unknown mode `%s'" mode) | |
| (setq done t) | |
| (or (set-auto-mode-0 mode keep-mode-if-same) | |
| ;; continuing would call minor modes again, toggling them off | |
| (throw 'nop nil)))))) | |
| ;; hack-local-variables checks local-enable-local-variables etc, but | |
| ;; we might as well be explicit here for the sake of clarity. | |
| (and (not done) | |
| enable-local-variables | |
| local-enable-local-variables | |
| try-locals | |
| (setq mode (hack-local-variables t)) | |
| (not (memq mode modes)) ; already tried and failed | |
| (if (not (functionp mode)) | |
| (message "Ignoring unknown mode `%s'" mode) | |
| (setq done t) | |
| (set-auto-mode-0 mode keep-mode-if-same))) | |
| ;; If we didn't, look for an interpreter specified in the first line. | |
| ;; As a special case, allow for things like "#!/bin/env perl", which | |
| ;; finds the interpreter anywhere in $PATH. | |
| (and (not done) | |
| (setq mode (save-excursion | |
| (goto-char (point-min)) | |
| (if (looking-at auto-mode-interpreter-regexp) | |
| (match-string 2)))) | |
| ;; Map interpreter name to a mode, signaling we're done at the | |
| ;; same time. | |
| (setq done (assoc-default | |
| (file-name-nondirectory mode) | |
| (mapcar (lambda (e) | |
| (cons | |
| (format "\\`%s\\'" (car e)) | |
| (cdr e))) | |
| interpreter-mode-alist) | |
| #'string-match-p)) | |
| ;; If we found an interpreter mode to use, invoke it now. | |
| (set-auto-mode-0 done keep-mode-if-same)) | |
| ;; Next try matching the buffer beginning against magic-mode-alist. | |
| (unless done | |
| (if (setq done (save-excursion | |
| (goto-char (point-min)) | |
| (save-restriction | |
| (narrow-to-region (point-min) | |
| (min (point-max) | |
| (+ (point-min) magic-mode-regexp-match-limit))) | |
| (assoc-default | |
| nil magic-mode-alist | |
| (lambda (re _dummy) | |
| (cond | |
| ((functionp re) | |
| (funcall re)) | |
| ((stringp re) | |
| (let ((case-fold-search nil)) | |
| (looking-at re))) | |
| (t | |
| (error | |
| "Problem in magic-mode-alist with element %s" | |
| re)))))))) | |
| (set-auto-mode-0 done keep-mode-if-same))) | |
| ;; Next compare the filename against the entries in auto-mode-alist. | |
| (unless done | |
| (if buffer-file-name | |
| (let ((name buffer-file-name) | |
| (remote-id (file-remote-p buffer-file-name)) | |
| (case-insensitive-p (file-name-case-insensitive-p | |
| buffer-file-name))) | |
| ;; Remove backup-suffixes from file name. | |
| (setq name (file-name-sans-versions name)) | |
| ;; Remove remote file name identification. | |
| (when (and (stringp remote-id) | |
| (string-match (regexp-quote remote-id) name)) | |
| (setq name (substring name (match-end 0)))) | |
| (while name | |
| ;; Find first matching alist entry. | |
| (setq mode | |
| (if case-insensitive-p | |
| ;; Filesystem is case-insensitive. | |
| (let ((case-fold-search t)) | |
| (assoc-default name auto-mode-alist | |
| 'string-match)) | |
| ;; Filesystem is case-sensitive. | |
| (or | |
| ;; First match case-sensitively. | |
| (let ((case-fold-search nil)) | |
| (assoc-default name auto-mode-alist | |
| 'string-match)) | |
| ;; Fallback to case-insensitive match. | |
| (and auto-mode-case-fold | |
| (let ((case-fold-search t)) | |
| (assoc-default name auto-mode-alist | |
| 'string-match)))))) | |
| (if (and mode | |
| (consp mode) | |
| (cadr mode)) | |
| (setq mode (car mode) | |
| name (substring name 0 (match-beginning 0))) | |
| (setq name nil)) | |
| (when mode | |
| (set-auto-mode-0 mode keep-mode-if-same) | |
| (setq done t)))))) | |
| ;; Next try matching the buffer beginning against magic-fallback-mode-alist. | |
| (unless done | |
| (if (setq done (save-excursion | |
| (goto-char (point-min)) | |
| (save-restriction | |
| (narrow-to-region (point-min) | |
| (min (point-max) | |
| (+ (point-min) magic-mode-regexp-match-limit))) | |
| (assoc-default nil magic-fallback-mode-alist | |
| (lambda (re _dummy) | |
| (cond | |
| ((functionp re) | |
| (funcall re)) | |
| ((stringp re) | |
| (let ((case-fold-search nil)) | |
| (looking-at re))) | |
| (t | |
| (error | |
| "Problem with magic-fallback-mode-alist element: %s" | |
| re)))))))) | |
| (set-auto-mode-0 done keep-mode-if-same))) | |
| (unless done | |
| (set-buffer-major-mode (current-buffer))))) | |
| ;; When `keep-mode-if-same' is set, we are working on behalf of | |
| ;; set-visited-file-name. In that case, if the major mode specified is the | |
| ;; same one we already have, don't actually reset it. We don't want to lose | |
| ;; minor modes such as Font Lock. | |
| (defun set-auto-mode-0 (mode &optional keep-mode-if-same) | |
| "Apply MODE and return it. | |
| If optional arg KEEP-MODE-IF-SAME is non-nil, MODE is chased of | |
| any aliases and compared to current major mode. If they are the | |
| same, do nothing and return nil." | |
| (unless (and keep-mode-if-same | |
| (eq (indirect-function mode) | |
| (indirect-function major-mode))) | |
| (when mode | |
| (funcall mode) | |
| mode))) | |
| (defvar file-auto-mode-skip "^\\(#!\\|'\\\\\"\\)" | |
| "Regexp of lines to skip when looking for file-local settings. | |
| If the first line matches this regular expression, then the -*-...-*- file- | |
| local settings will be consulted on the second line instead of the first.") | |
| (defun set-auto-mode-1 () | |
| "Find the -*- spec in the buffer. | |
| Call with point at the place to start searching from. | |
| If one is found, set point to the beginning and return the position | |
| of the end. Otherwise, return nil; may change point. | |
| The variable `inhibit-local-variables-regexps' can cause a -*- spec to | |
| be ignored; but `enable-local-variables' and `local-enable-local-variables' | |
| have no effect." | |
| (let (beg end) | |
| (and | |
| ;; Don't look for -*- if this file name matches any | |
| ;; of the regexps in inhibit-local-variables-regexps. | |
| (not (inhibit-local-variables-p)) | |
| (search-forward "-*-" (line-end-position | |
| ;; If the file begins with "#!" (exec | |
| ;; interpreter magic), look for mode frobs | |
| ;; in the first two lines. You cannot | |
| ;; necessarily put them in the first line | |
| ;; of such a file without screwing up the | |
| ;; interpreter invocation. The same holds | |
| ;; for '\" in man pages (preprocessor | |
| ;; magic for the `man' program). | |
| (and (looking-at file-auto-mode-skip) 2)) t) | |
| (progn | |
| (skip-chars-forward " \t") | |
| (setq beg (point)) | |
| (search-forward "-*-" (line-end-position) t)) | |
| (progn | |
| (forward-char -3) | |
| (skip-chars-backward " \t") | |
| (setq end (point)) | |
| (goto-char beg) | |
| end)))) | |
| ;;; Handling file local variables | |
| (defvar ignored-local-variables | |
| '(ignored-local-variables safe-local-variable-values | |
| file-local-variables-alist dir-local-variables-alist) | |
| "Variables to be ignored in a file's local variable spec.") | |
| (put 'ignored-local-variables 'risky-local-variable t) | |
| (defvar hack-local-variables-hook nil | |
| "Normal hook run after processing a file's local variables specs. | |
| Major modes can use this to examine user-specified local variables | |
| in order to initialize other data structure based on them.") | |
| (defcustom safe-local-variable-values nil | |
| "List variable-value pairs that are considered safe. | |
| Each element is a cons cell (VAR . VAL), where VAR is a variable | |
| symbol and VAL is a value that is considered safe." | |
| :risky t | |
| :group 'find-file | |
| :type 'alist) | |
| (defcustom safe-local-eval-forms | |
| ;; This should be here at least as long as Emacs supports write-file-hooks. | |
| '((add-hook 'write-file-hooks 'time-stamp) | |
| (add-hook 'write-file-functions 'time-stamp) | |
| (add-hook 'before-save-hook 'time-stamp nil t) | |
| (add-hook 'before-save-hook 'delete-trailing-whitespace nil t)) | |
| "Expressions that are considered safe in an `eval:' local variable. | |
| Add expressions to this list if you want Emacs to evaluate them, when | |
| they appear in an `eval' local variable specification, without first | |
| asking you for confirmation." | |
| :risky t | |
| :group 'find-file | |
| :version "24.1" ; added write-file-hooks | |
| :type '(repeat sexp)) | |
| ;; Risky local variables: | |
| (mapc (lambda (var) (put var 'risky-local-variable t)) | |
| '(after-load-alist | |
| buffer-auto-save-file-name | |
| buffer-file-name | |
| buffer-file-truename | |
| buffer-undo-list | |
| debugger | |
| default-text-properties | |
| eval | |
| exec-directory | |
| exec-path | |
| file-name-handler-alist | |
| frame-title-format | |
| global-mode-string | |
| header-line-format | |
| icon-title-format | |
| inhibit-quit | |
| load-path | |
| max-lisp-eval-depth | |
| max-specpdl-size | |
| minor-mode-map-alist | |
| minor-mode-overriding-map-alist | |
| mode-line-format | |
| mode-name | |
| overriding-local-map | |
| overriding-terminal-local-map | |
| process-environment | |
| standard-input | |
| standard-output | |
| unread-command-events)) | |
| ;; Safe local variables: | |
| ;; | |
| ;; For variables defined by major modes, the safety declarations can go into | |
| ;; the major mode's file, since that will be loaded before file variables are | |
| ;; processed. | |
| ;; | |
| ;; For variables defined by minor modes, put the safety declarations in the | |
| ;; file defining the minor mode after the defcustom/defvar using an autoload | |
| ;; cookie, e.g.: | |
| ;; | |
| ;; ;;;###autoload(put 'variable 'safe-local-variable 'stringp) | |
| ;; | |
| ;; Otherwise, when Emacs visits a file specifying that local variable, the | |
| ;; minor mode file may not be loaded yet. | |
| ;; | |
| ;; For variables defined in the C source code the declaration should go here: | |
| (dolist (pair | |
| '((buffer-read-only . booleanp) ;; C source code | |
| (default-directory . stringp) ;; C source code | |
| (fill-column . integerp) ;; C source code | |
| (indent-tabs-mode . booleanp) ;; C source code | |
| (left-margin . integerp) ;; C source code | |
| (inhibit-compacting-font-caches . booleanp) ;; C source code | |
| (no-update-autoloads . booleanp) | |
| (lexical-binding . booleanp) ;; C source code | |
| (tab-width . integerp) ;; C source code | |
| (truncate-lines . booleanp) ;; C source code | |
| (word-wrap . booleanp) ;; C source code | |
| (bidi-display-reordering . booleanp))) ;; C source code | |
| (put (car pair) 'safe-local-variable (cdr pair))) | |
| (put 'bidi-paragraph-direction 'safe-local-variable | |
| (lambda (v) (memq v '(nil right-to-left left-to-right)))) | |
| (put 'c-set-style 'safe-local-eval-function t) | |
| (defvar file-local-variables-alist nil | |
| "Alist of file-local variable settings in the current buffer. | |
| Each element in this list has the form (VAR . VALUE), where VAR | |
| is a file-local variable (a symbol) and VALUE is the value | |
| specified. The actual value in the buffer may differ from VALUE, | |
| if it is changed by the major or minor modes, or by the user.") | |
| (make-variable-buffer-local 'file-local-variables-alist) | |
| (put 'file-local-variables-alist 'permanent-local t) | |
| (defvar dir-local-variables-alist nil | |
| "Alist of directory-local variable settings in the current buffer. | |
| Each element in this list has the form (VAR . VALUE), where VAR | |
| is a directory-local variable (a symbol) and VALUE is the value | |
| specified in .dir-locals.el. The actual value in the buffer | |
| may differ from VALUE, if it is changed by the major or minor modes, | |
| or by the user.") | |
| (make-variable-buffer-local 'dir-local-variables-alist) | |
| (defvar before-hack-local-variables-hook nil | |
| "Normal hook run before setting file-local variables. | |
| It is called after checking for unsafe/risky variables and | |
| setting `file-local-variables-alist', and before applying the | |
| variables stored in `file-local-variables-alist'. A hook | |
| function is allowed to change the contents of this alist. | |
| This hook is called only if there is at least one file-local | |
| variable to set.") | |
| (defun hack-local-variables-confirm (all-vars unsafe-vars risky-vars dir-name) | |
| "Get confirmation before setting up local variable values. | |
| ALL-VARS is the list of all variables to be set up. | |
| UNSAFE-VARS is the list of those that aren't marked as safe or risky. | |
| RISKY-VARS is the list of those that are marked as risky. | |
| If these settings come from directory-local variables, then | |
| DIR-NAME is the name of the associated directory. Otherwise it is nil." | |
| (unless noninteractive | |
| (let ((name (cond (dir-name) | |
| (buffer-file-name | |
| (file-name-nondirectory buffer-file-name)) | |
| ((concat "buffer " (buffer-name))))) | |
| (offer-save (and (eq enable-local-variables t) | |
| unsafe-vars)) | |
| (buf (get-buffer-create "*Local Variables*"))) | |
| ;; Set up the contents of the *Local Variables* buffer. | |
| (with-current-buffer buf | |
| (erase-buffer) | |
| (cond | |
| (unsafe-vars | |
| (insert "The local variables list in " name | |
| "\ncontains values that may not be safe (*)" | |
| (if risky-vars | |
| ", and variables that are risky (**)." | |
| "."))) | |
| (risky-vars | |
| (insert "The local variables list in " name | |
| "\ncontains variables that are risky (**).")) | |
| (t | |
| (insert "A local variables list is specified in " name "."))) | |
| (insert "\n\nDo you want to apply it? You can type | |
| y -- to apply the local variables list. | |
| n -- to ignore the local variables list.") | |
| (if offer-save | |
| (insert " | |
| ! -- to apply the local variables list, and permanently mark these | |
| values (*) as safe (in the future, they will be set automatically.)\n\n") | |
| (insert "\n\n")) | |
| (dolist (elt all-vars) | |
| (cond ((member elt unsafe-vars) | |
| (insert " * ")) | |
| ((member elt risky-vars) | |
| (insert " ** ")) | |
| (t | |
| (insert " "))) | |
| (princ (car elt) buf) | |
| (insert " : ") | |
| ;; Make strings with embedded whitespace easier to read. | |
| (let ((print-escape-newlines t)) | |
| (prin1 (cdr elt) buf)) | |
| (insert "\n")) | |
| (set (make-local-variable 'cursor-type) nil) | |
| (set-buffer-modified-p nil) | |
| (goto-char (point-min))) | |
| ;; Display the buffer and read a choice. | |
| (save-window-excursion | |
| (pop-to-buffer buf '(display-buffer--maybe-at-bottom)) | |
| (let* ((exit-chars '(?y ?n ?\s)) | |
| (prompt (format "Please type %s%s: " | |
| (if offer-save "y, n, or !" "y or n") | |
| (if (< (line-number-at-pos (point-max)) | |
| (window-body-height)) | |
| "" | |
| ", or C-v/M-v to scroll"))) | |
| char) | |
| (if offer-save (push ?! exit-chars)) | |
| (setq char (read-char-from-minibuffer prompt exit-chars)) | |
| (when (and offer-save (= char ?!) unsafe-vars) | |
| (customize-push-and-save 'safe-local-variable-values unsafe-vars)) | |
| (prog1 (memq char '(?! ?\s ?y)) | |
| (quit-window t))))))) | |
| (defconst hack-local-variable-regexp | |
| "[ \t]*\\([^][;\"'?()\\ \t\n]+\\)[ \t]*:[ \t]*") | |
| (defun hack-local-variables-prop-line (&optional handle-mode) | |
| "Return local variables specified in the -*- line. | |
| Usually returns an alist of elements (VAR . VAL), where VAR is a | |
| variable and VAL is the specified value. Ignores any | |
| specification for `coding:', and sometimes for `mode' (which | |
| should have already been handled by `set-auto-coding' and | |
| `set-auto-mode', respectively). Return nil if the -*- line is | |
| malformed. | |
| If HANDLE-MODE is nil, we return the alist of all the local | |
| variables in the line except `coding' as described above. If it | |
| is neither nil nor t, we do the same, except that any settings of | |
| `mode' and `coding' are ignored. If HANDLE-MODE is t, we ignore | |
| all settings in the line except for `mode', which \(if present) we | |
| return as the symbol specifying the mode." | |
| (catch 'malformed-line | |
| (save-excursion | |
| (goto-char (point-min)) | |
| (let ((end (set-auto-mode-1)) | |
| result) | |
| (cond ((not end) | |
| nil) | |
| ((looking-at "[ \t]*\\([^ \t\n\r:;]+\\)\\([ \t]*-\\*-\\)") | |
| ;; Simple form: "-*- MODENAME -*-". | |
| (if (eq handle-mode t) | |
| (intern (concat (match-string 1) "-mode")))) | |
| (t | |
| ;; Hairy form: '-*-' [ <variable> ':' <value> ';' ]* '-*-' | |
| ;; (last ";" is optional). | |
| ;; If HANDLE-MODE is t, just check for `mode'. | |
| ;; Otherwise, parse the -*- line into the RESULT alist. | |
| (while (not (or (and (eq handle-mode t) result) | |
| (>= (point) end))) | |
| (unless (looking-at hack-local-variable-regexp) | |
| (message "Malformed mode-line: %S" | |
| (buffer-substring-no-properties (point) end)) | |
| (throw 'malformed-line nil)) | |
| (goto-char (match-end 0)) | |
| ;; There used to be a downcase here, | |
| ;; but the manual didn't say so, | |
| ;; and people want to set var names that aren't all lc. | |
| (let* ((key (intern (match-string 1))) | |
| (val (save-restriction | |
| (narrow-to-region (point) end) | |
| ;; As a defensive measure, we do not allow | |
| ;; circular data in the file-local data. | |
| (let ((read-circle nil)) | |
| (read (current-buffer))))) | |
| ;; It is traditional to ignore | |
| ;; case when checking for `mode' in set-auto-mode, | |
| ;; so we must do that here as well. | |
| ;; That is inconsistent, but we're stuck with it. | |
| ;; The same can be said for `coding' in set-auto-coding. | |
| (keyname (downcase (symbol-name key)))) | |
| (cond | |
| ((eq handle-mode t) | |
| (and (equal keyname "mode") | |
| (setq result | |
| (intern (concat (downcase (symbol-name val)) | |
| "-mode"))))) | |
| ((equal keyname "coding")) | |
| (t | |
| (when (or (not handle-mode) | |
| (not (equal keyname "mode"))) | |
| (condition-case nil | |
| (push (cons (cond ((eq key 'eval) 'eval) | |
| ;; Downcase "Mode:". | |
| ((equal keyname "mode") 'mode) | |
| (t (indirect-variable key))) | |
| val) | |
| result) | |
| (error nil))))) | |
| (skip-chars-forward " \t;"))) | |
| result)))))) | |
| (defun hack-local-variables-filter (variables dir-name) | |
| "Filter local variable settings, querying the user if necessary. | |
| VARIABLES is the alist of variable-value settings. This alist is | |
| filtered based on the values of `ignored-local-variables', | |
| `enable-local-eval', `enable-local-variables', and (if necessary) | |
| user interaction. The results are added to | |
| `file-local-variables-alist', without applying them. | |
| If these settings come from directory-local variables, then | |
| DIR-NAME is the name of the associated directory. Otherwise it is nil." | |
| ;; Find those variables that we may want to save to | |
| ;; `safe-local-variable-values'. | |
| (let (all-vars risky-vars unsafe-vars) | |
| (dolist (elt variables) | |
| (let ((var (car elt)) | |
| (val (cdr elt))) | |
| (cond ((memq var ignored-local-variables) | |
| ;; Ignore any variable in `ignored-local-variables'. | |
| nil) | |
| ;; Obey `enable-local-eval'. | |
| ((eq var 'eval) | |
| (when enable-local-eval | |
| (let ((safe (or (hack-one-local-variable-eval-safep val) | |
| ;; In case previously marked safe (bug#5636). | |
| (safe-local-variable-p var val)))) | |
| ;; If not safe and e-l-v = :safe, ignore totally. | |
| (when (or safe (not (eq enable-local-variables :safe))) | |
| (push elt all-vars) | |
| (or (eq enable-local-eval t) | |
| safe | |
| (push elt unsafe-vars)))))) | |
| ;; Ignore duplicates (except `mode') in the present list. | |
| ((and (assq var all-vars) (not (eq var 'mode))) nil) | |
| ;; Accept known-safe variables. | |
| ((or (memq var '(mode unibyte coding)) | |
| (safe-local-variable-p var val)) | |
| (push elt all-vars)) | |
| ;; The variable is either risky or unsafe: | |
| ((not (eq enable-local-variables :safe)) | |
| (push elt all-vars) | |
| (if (risky-local-variable-p var val) | |
| (push elt risky-vars) | |
| (push elt unsafe-vars)))))) | |
| (and all-vars | |
| ;; Query, unless all vars are safe or user wants no querying. | |
| (or (and (eq enable-local-variables t) | |
| (null unsafe-vars) | |
| (null risky-vars)) | |
| (memq enable-local-variables '(:all :safe)) | |
| (hack-local-variables-confirm all-vars unsafe-vars | |
| risky-vars dir-name)) | |
| (dolist (elt all-vars) | |
| (unless (memq (car elt) '(eval mode)) | |
| (unless dir-name | |
| (setq dir-local-variables-alist | |
| (assq-delete-all (car elt) dir-local-variables-alist))) | |
| (setq file-local-variables-alist | |
| (assq-delete-all (car elt) file-local-variables-alist))) | |
| (push elt file-local-variables-alist))))) | |
| ;; TODO? Warn once per file rather than once per session? | |
| (defvar hack-local-variables--warned-lexical nil) | |
| (defun hack-local-variables (&optional handle-mode) | |
| "Parse and put into effect this buffer's local variables spec. | |
| For buffers visiting files, also puts into effect directory-local | |
| variables. | |
| Uses `hack-local-variables-apply' to apply the variables. | |
| If HANDLE-MODE is nil, we apply all the specified local | |
| variables. If HANDLE-MODE is neither nil nor t, we do the same, | |
| except that any settings of `mode' are ignored. | |
| If HANDLE-MODE is t, all we do is check whether a \"mode:\" | |
| is specified, and return the corresponding mode symbol, or nil. | |
| In this case, we try to ignore minor-modes, and return only a | |
| major-mode. | |
| If `enable-local-variables' or `local-enable-local-variables' is nil, | |
| this function does nothing. If `inhibit-local-variables-regexps' | |
| applies to the file in question, the file is not scanned for | |
| local variables, but directory-local variables may still be applied." | |
| ;; We don't let inhibit-local-variables-p influence the value of | |
| ;; enable-local-variables, because then it would affect dir-local | |
| ;; variables. We don't want to search eg tar files for file local | |
| ;; variable sections, but there is no reason dir-locals cannot apply | |
| ;; to them. The real meaning of inhibit-local-variables-p is "do | |
| ;; not scan this file for local variables". | |
| (let ((enable-local-variables | |
| (and local-enable-local-variables enable-local-variables)) | |
| result) | |
| (unless (eq handle-mode t) | |
| (setq file-local-variables-alist nil) | |
| (when (and (file-remote-p default-directory) | |
| (fboundp 'hack-connection-local-variables) | |
| (fboundp 'connection-local-criteria-for-default-directory)) | |
| (with-demoted-errors "Connection-local variables error: %s" | |
| ;; Note this is a no-op if enable-local-variables is nil. | |
| (hack-connection-local-variables | |
| (connection-local-criteria-for-default-directory)))) | |
| (with-demoted-errors "Directory-local variables error: %s" | |
| ;; Note this is a no-op if enable-local-variables is nil. | |
| (hack-dir-local-variables))) | |
| ;; This entire function is basically a no-op if enable-local-variables | |
| ;; is nil. All it does is set file-local-variables-alist to nil. | |
| (when enable-local-variables | |
| ;; This part used to ignore enable-local-variables when handle-mode | |
| ;; was t. That was inappropriate, eg consider the | |
| ;; (artificial) example of: | |
| ;; (setq local-enable-local-variables nil) | |
| ;; Open a file foo.txt that contains "mode: sh". | |
| ;; It correctly opens in text-mode. | |
| ;; M-x set-visited-file name foo.c, and it incorrectly stays in text-mode. | |
| (unless (or (inhibit-local-variables-p) | |
| ;; If HANDLE-MODE is t, and the prop line specifies a | |
| ;; mode, then we're done, and have no need to scan further. | |
| (and (setq result (hack-local-variables-prop-line | |
| handle-mode)) | |
| (eq handle-mode t))) | |
| ;; Look for "Local variables:" line in last page. | |
| (save-excursion | |
| (goto-char (point-max)) | |
| (search-backward "\n\^L" (max (- (point-max) 3000) (point-min)) | |
| 'move) | |
| (when (let ((case-fold-search t)) | |
| (search-forward "Local Variables:" nil t)) | |
| (skip-chars-forward " \t") | |
| ;; suffix is what comes after "local variables:" in its line. | |
| ;; prefix is what comes before "local variables:" in its line. | |
| (let ((suffix | |
| (concat | |
| (regexp-quote (buffer-substring (point) | |
| (line-end-position))) | |
| "$")) | |
| (prefix | |
| (concat "^" (regexp-quote | |
| (buffer-substring (line-beginning-position) | |
| (match-beginning 0)))))) | |
| (forward-line 1) | |
| (let ((startpos (point)) | |
| endpos | |
| (thisbuf (current-buffer))) | |
| (save-excursion | |
| (unless (let ((case-fold-search t)) | |
| (re-search-forward | |
| (concat prefix "[ \t]*End:[ \t]*" suffix) | |
| nil t)) | |
| ;; This used to be an error, but really all it means is | |
| ;; that this may simply not be a local-variables section, | |
| ;; so just ignore it. | |
| (message "Local variables list is not properly terminated")) | |
| (beginning-of-line) | |
| (setq endpos (point))) | |
| (with-temp-buffer | |
| (insert-buffer-substring thisbuf startpos endpos) | |
| (goto-char (point-min)) | |
| (subst-char-in-region (point) (point-max) ?\^m ?\n) | |
| (while (not (eobp)) | |
| ;; Discard the prefix. | |
| (if (looking-at prefix) | |
| (delete-region (point) (match-end 0)) | |
| (error "Local variables entry is missing the prefix")) | |
| (end-of-line) | |
| ;; Discard the suffix. | |
| (if (looking-back suffix (line-beginning-position)) | |
| (delete-region (match-beginning 0) (point)) | |
| (error "Local variables entry is missing the suffix")) | |
| (forward-line 1)) | |
| (goto-char (point-min)) | |
| (while (not (or (eobp) | |
| (and (eq handle-mode t) result))) | |
| ;; Find the variable name; | |
| (unless (looking-at hack-local-variable-regexp) | |
| (error "Malformed local variable line: %S" | |
| (buffer-substring-no-properties | |
| (point) (line-end-position)))) | |
| (goto-char (match-end 1)) | |
| (let* ((str (match-string 1)) | |
| (var (intern str)) | |
| val val2) | |
| (and (equal (downcase (symbol-name var)) "mode") | |
| (setq var 'mode)) | |
| ;; Read the variable value. | |
| (skip-chars-forward "^:") | |
| (forward-char 1) | |
| ;; As a defensive measure, we do not allow | |
| ;; circular data in the file-local data. | |
| (let ((read-circle nil)) | |
| (setq val (read (current-buffer)))) | |
| (if (eq handle-mode t) | |
| (and (eq var 'mode) | |
| ;; Specifying minor-modes via mode: is | |
| ;; deprecated, but try to reject them anyway. | |
| (not (string-match | |
| "-minor\\'" | |
| (setq val2 (downcase (symbol-name val))))) | |
| (setq result (intern (concat val2 "-mode")))) | |
| (cond ((eq var 'coding)) | |
| ((eq var 'lexical-binding) | |
| (unless hack-local-variables--warned-lexical | |
| (setq hack-local-variables--warned-lexical t) | |
| (display-warning | |
| 'files | |
| (format-message | |
| "%s: `lexical-binding' at end of file unreliable" | |
| (file-name-nondirectory | |
| ;; We are called from | |
| ;; 'with-temp-buffer', so we need | |
| ;; to use 'thisbuf's name in the | |
| ;; warning message. | |
| (or (buffer-file-name thisbuf) "")))))) | |
| ((and (eq var 'mode) handle-mode)) | |
| (t | |
| (ignore-errors | |
| (push (cons (if (eq var 'eval) | |
| 'eval | |
| (indirect-variable var)) | |
| val) | |
| result)))))) | |
| (forward-line 1)))))))) | |
| ;; Now we've read all the local variables. | |
| ;; If HANDLE-MODE is t, return whether the mode was specified. | |
| (if (eq handle-mode t) result | |
| ;; Otherwise, set the variables. | |
| (hack-local-variables-filter result nil) | |
| (hack-local-variables-apply))))) | |
| (defun hack-local-variables-apply () | |
| "Apply the elements of `file-local-variables-alist'. | |
| If there are any elements, runs `before-hack-local-variables-hook', | |
| then calls `hack-one-local-variable' to apply the alist elements one by one. | |
| Finishes by running `hack-local-variables-hook', regardless of whether | |
| the alist is empty or not. | |
| Note that this function ignores a `mode' entry if it specifies the same | |
| major mode as the buffer already has." | |
| (when file-local-variables-alist | |
| ;; Any 'evals must run in the Right sequence. | |
| (setq file-local-variables-alist | |
| (nreverse file-local-variables-alist)) | |
| (run-hooks 'before-hack-local-variables-hook) | |
| (dolist (elt file-local-variables-alist) | |
| (hack-one-local-variable (car elt) (cdr elt)))) | |
| (run-hooks 'hack-local-variables-hook)) | |
| (defun safe-local-variable-p (sym val) | |
| "Non-nil if SYM is safe as a file-local variable with value VAL. | |
| It is safe if any of these conditions are met: | |
| * There is a matching entry (SYM . VAL) in the | |
| `safe-local-variable-values' user option. | |
| * The `safe-local-variable' property of SYM is a function that | |
| evaluates to a non-nil value with VAL as an argument." | |
| (or (member (cons sym val) safe-local-variable-values) | |
| (let ((safep (get sym 'safe-local-variable))) | |
| (and (functionp safep) | |
| ;; If the function signals an error, that means it | |
| ;; can't assure us that the value is safe. | |
| (with-demoted-errors (funcall safep val)))))) | |
| (defun risky-local-variable-p (sym &optional _ignored) | |
| "Non-nil if SYM could be dangerous as a file-local variable. | |
| It is dangerous if either of these conditions are met: | |
| * Its `risky-local-variable' property is non-nil. | |
| * Its name ends with \"hook(s)\", \"function(s)\", \"form(s)\", \"map\", | |
| \"program\", \"command(s)\", \"predicate(s)\", \"frame-alist\", | |
| \"mode-alist\", \"font-lock-(syntactic-)keyword*\", | |
| \"map-alist\", or \"bindat-spec\"." | |
| ;; If this is an alias, check the base name. | |
| (condition-case nil | |
| (setq sym (indirect-variable sym)) | |
| (error nil)) | |
| (or (get sym 'risky-local-variable) | |
| (string-match "-hooks?$\\|-functions?$\\|-forms?$\\|-program$\\|\ | |
| -commands?$\\|-predicates?$\\|font-lock-keywords$\\|font-lock-keywords\ | |
| -[0-9]+$\\|font-lock-syntactic-keywords$\\|-frame-alist$\\|-mode-alist$\\|\ | |
| -map$\\|-map-alist$\\|-bindat-spec$" (symbol-name sym)))) | |
| (defun hack-one-local-variable-quotep (exp) | |
| (and (consp exp) (eq (car exp) 'quote) (consp (cdr exp)))) | |
| (defun hack-one-local-variable-constantp (exp) | |
| (or (and (not (symbolp exp)) (not (consp exp))) | |
| (memq exp '(t nil)) | |
| (keywordp exp) | |
| (hack-one-local-variable-quotep exp))) | |
| (defun hack-one-local-variable-eval-safep (exp) | |
| "Return non-nil if it is safe to eval EXP when it is found in a file." | |
| (or (not (consp exp)) | |
| ;; Detect certain `put' expressions. | |
| (and (eq (car exp) 'put) | |
| (hack-one-local-variable-quotep (nth 1 exp)) | |
| (hack-one-local-variable-quotep (nth 2 exp)) | |
| (let ((prop (nth 1 (nth 2 exp))) | |
| (val (nth 3 exp))) | |
| (cond ((memq prop '(lisp-indent-hook | |
| lisp-indent-function | |
| scheme-indent-function)) | |
| ;; Allow only safe values (not functions). | |
| (or (numberp val) | |
| (and (hack-one-local-variable-quotep val) | |
| (eq (nth 1 val) 'defun)))) | |
| ((eq prop 'edebug-form-spec) | |
| ;; Allow only indirect form specs. | |
| ;; During bootstrapping, edebug-basic-spec might not be | |
| ;; defined yet. | |
| (and (fboundp 'edebug-basic-spec) | |
| (hack-one-local-variable-quotep val) | |
| (edebug-basic-spec (nth 1 val))))))) | |
| ;; Allow expressions that the user requested. | |
| (member exp safe-local-eval-forms) | |
| ;; Certain functions can be allowed with safe arguments | |
| ;; or can specify verification functions to try. | |
| (and (symbolp (car exp)) | |
| ;; Allow (minor)-modes calls with no arguments. | |
| ;; This obsoletes the use of "mode:" for such things. (Bug#8613) | |
| (or (and (member (cdr exp) '(nil (1) (0) (-1))) | |
| (string-match "-mode\\'" (symbol-name (car exp)))) | |
| (let ((prop (get (car exp) 'safe-local-eval-function))) | |
| (cond ((eq prop t) | |
| (let ((ok t)) | |
| (dolist (arg (cdr exp)) | |
| (unless (hack-one-local-variable-constantp arg) | |
| (setq ok nil))) | |
| ok)) | |
| ((functionp prop) | |
| (funcall prop exp)) | |
| ((listp prop) | |
| (let ((ok nil)) | |
| (dolist (function prop) | |
| (if (funcall function exp) | |
| (setq ok t))) | |
| ok)))))))) | |
| (defun hack-one-local-variable--obsolete (var) | |
| (let ((o (get var 'byte-obsolete-variable))) | |
| (when o | |
| (let ((instead (nth 0 o)) | |
| (since (nth 2 o))) | |
| (message "%s is obsolete%s; %s" | |
| var (if since (format " (since %s)" since)) | |
| (if (stringp instead) | |
| (substitute-command-keys instead) | |
| (format-message "use `%s' instead" instead))))))) | |
| (defun hack-one-local-variable (var val) | |
| "Set local variable VAR with value VAL. | |
| If VAR is `mode', call `VAL-mode' as a function unless it's | |
| already the major mode." | |
| (pcase var | |
| ('mode | |
| (let ((mode (intern (concat (downcase (symbol-name val)) | |
| "-mode")))) | |
| (unless (eq (indirect-function mode) | |
| (indirect-function major-mode)) | |
| (funcall mode)))) | |
| ('eval | |
| (pcase val | |
| (`(add-hook ',hook . ,_) (hack-one-local-variable--obsolete hook))) | |
| (save-excursion (eval val))) | |
| (_ | |
| (hack-one-local-variable--obsolete var) | |
| ;; Make sure the string has no text properties. | |
| ;; Some text properties can get evaluated in various ways, | |
| ;; so it is risky to put them on with a local variable list. | |
| (if (stringp val) | |
| (set-text-properties 0 (length val) nil val)) | |
| (set (make-local-variable var) val)))) | |
| ;;; Handling directory-local variables, aka project settings. | |
| (defvar dir-locals-class-alist '() | |
| "Alist mapping directory-local variable classes (symbols) to variable lists.") | |
| (defvar dir-locals-directory-cache '() | |
| "List of cached directory roots for directory-local variable classes. | |
| Each element in this list has the form (DIR CLASS MTIME). | |
| DIR is the name of the directory. | |
| CLASS is the name of a variable class (a symbol). | |
| MTIME is the recorded modification time of the directory-local | |
| variables file associated with this entry. This time is a Lisp | |
| timestamp (the same format as `current-time'), and is | |
| used to test whether the cache entry is still valid. | |
| Alternatively, MTIME can be nil, which means the entry is always | |
| considered valid.") | |
| (defsubst dir-locals-get-class-variables (class) | |
| "Return the variable list for CLASS." | |
| (cdr (assq class dir-locals-class-alist))) | |
| (defun dir-locals-collect-mode-variables (mode-variables variables) | |
| "Collect directory-local variables from MODE-VARIABLES. | |
| VARIABLES is the initial list of variables. | |
| Returns the new list." | |
| (dolist (pair mode-variables variables) | |
| (let* ((variable (car pair)) | |
| (value (cdr pair)) | |
| (slot (assq variable variables))) | |
| ;; If variables are specified more than once, use only the last. (Why?) | |
| ;; The pseudo-variables mode and eval are different (bug#3430). | |
| (if (and slot (not (memq variable '(mode eval)))) | |
| (setcdr slot value) | |
| ;; Need a new cons in case we setcdr later. | |
| (push (cons variable value) variables))))) | |
| (defun dir-locals-collect-variables (class-variables root variables) | |
| "Collect entries from CLASS-VARIABLES into VARIABLES. | |
| ROOT is the root directory of the project. | |
| Return the new variables list." | |
| (let* ((file-name (or (buffer-file-name) | |
| ;; Handle non-file buffers, too. | |
| (expand-file-name default-directory))) | |
| (sub-file-name (if (and file-name | |
| (file-name-absolute-p file-name)) | |
| ;; FIXME: Why not use file-relative-name? | |
| (substring file-name (length root))))) | |
| (condition-case err | |
| (dolist (entry class-variables variables) | |
| (let ((key (car entry))) | |
| (cond | |
| ((stringp key) | |
| ;; Don't include this in the previous condition, because we | |
| ;; want to filter all strings before the next condition. | |
| (when (and sub-file-name | |
| (>= (length sub-file-name) (length key)) | |
| (string-prefix-p key sub-file-name)) | |
| (setq variables (dir-locals-collect-variables | |
| (cdr entry) root variables)))) | |
| ((or (not key) | |
| (derived-mode-p key)) | |
| (let* ((alist (cdr entry)) | |
| (subdirs (assq 'subdirs alist))) | |
| (if (or (not subdirs) | |
| (progn | |
| (setq alist (delq subdirs alist)) | |
| (cdr-safe subdirs)) | |
| ;; TODO someone might want to extend this to allow | |
| ;; integer values for subdir, where N means | |
| ;; variables apply to this directory and N levels | |
| ;; below it (0 == nil). | |
| (equal root default-directory)) | |
| (setq variables (dir-locals-collect-mode-variables | |
| alist variables)))))))) | |
| (error | |
| ;; The file's content might be invalid (e.g. have a merge conflict), but | |
| ;; that shouldn't prevent the user from opening the file. | |
| (message "%s error: %s" dir-locals-file (error-message-string err)) | |
| nil)))) | |
| (defun dir-locals-set-directory-class (directory class &optional mtime) | |
| "Declare that the DIRECTORY root is an instance of CLASS. | |
| DIRECTORY is the name of a directory, a string. | |
| CLASS is the name of a project class, a symbol. | |
| MTIME is either the modification time of the directory-local | |
| variables file that defined this class, or nil. | |
| When a file beneath DIRECTORY is visited, the mode-specific | |
| variables from CLASS are applied to the buffer. The variables | |
| for a class are defined using `dir-locals-set-class-variables'." | |
| (setq directory (file-name-as-directory (expand-file-name directory))) | |
| (unless (assq class dir-locals-class-alist) | |
| (error "No such class `%s'" (symbol-name class))) | |
| (push (list directory class mtime) dir-locals-directory-cache)) | |
| (defun dir-locals-set-class-variables (class variables) | |
| "Map the type CLASS to a list of variable settings. | |
| CLASS is the project class, a symbol. VARIABLES is a list | |
| that declares directory-local variables for the class. | |
| An element in VARIABLES is either of the form: | |
| (MAJOR-MODE . ALIST) | |
| or | |
| (DIRECTORY . LIST) | |
| In the first form, MAJOR-MODE is a symbol, and ALIST is an alist | |
| whose elements are of the form (VARIABLE . VALUE). | |
| In the second form, DIRECTORY is a directory name (a string), and | |
| LIST is a list of the form accepted by the function. | |
| When a file is visited, the file's class is found. A directory | |
| may be assigned a class using `dir-locals-set-directory-class'. | |
| Then variables are set in the file's buffer according to the | |
| VARIABLES list of the class. The list is processed in order. | |
| * If the element is of the form (MAJOR-MODE . ALIST), and the | |
| buffer's major mode is derived from MAJOR-MODE (as determined | |
| by `derived-mode-p'), then all the variables in ALIST are | |
| applied. A MAJOR-MODE of nil may be used to match any buffer. | |
| `make-local-variable' is called for each variable before it is | |
| set. | |
| * If the element is of the form (DIRECTORY . LIST), and DIRECTORY | |
| is an initial substring of the file's directory, then LIST is | |
| applied by recursively following these rules." | |
| (setf (alist-get class dir-locals-class-alist) variables)) | |
| (defconst dir-locals-file ".dir-locals.el" | |
| "File that contains directory-local variables. | |
| It has to be constant to enforce uniform values across different | |
| environments and users. | |
| A second dir-locals file can be used by a user to specify their | |
| personal dir-local variables even if the current directory | |
| already has a `dir-locals-file' that is shared with other | |
| users (such as in a git repository). The name of this second | |
| file is derived by appending \"-2\" to the base name of | |
| `dir-locals-file'. With the default value of `dir-locals-file', | |
| a \".dir-locals-2.el\" file in the same directory will override | |
| the \".dir-locals.el\". | |
| See Info node `(elisp)Directory Local Variables' for details.") | |
| (defun dir-locals--all-files (directory) | |
| "Return a list of all readable dir-locals files in DIRECTORY. | |
| The returned list is sorted by increasing priority. That is, | |
| values specified in the last file should take precedence over | |
| those in the first." | |
| (when (file-readable-p directory) | |
| (let* ((file-1 (expand-file-name (if (eq system-type 'ms-dos) | |
| (dosified-file-name dir-locals-file) | |
| dir-locals-file) | |
| directory)) | |
| (file-2 (when (string-match "\\.el\\'" file-1) | |
| (replace-match "-2.el" t nil file-1))) | |
| (out nil)) | |
| ;; The order here is important. | |
| (dolist (f (list file-2 file-1)) | |
| (when (and f | |
| (file-readable-p f) | |
| ;; FIXME: Aren't file-regular-p and | |
| ;; file-directory-p mutually exclusive? | |
| (file-regular-p f) | |
| (not (file-directory-p f))) | |
| (push f out))) | |
| out))) | |
| (defun dir-locals-find-file (file) | |
| "Find the directory-local variables for FILE. | |
| This searches upward in the directory tree from FILE. | |
| It stops at the first directory that has been registered in | |
| `dir-locals-directory-cache' or contains a `dir-locals-file'. | |
| If it finds an entry in the cache, it checks that it is valid. | |
| A cache entry with no modification time element (normally, one that | |
| has been assigned directly using `dir-locals-set-directory-class', not | |
| set from a file) is always valid. | |
| A cache entry based on a `dir-locals-file' is valid if the modification | |
| time stored in the cache matches the current file modification time. | |
| If not, the cache entry is cleared so that the file will be re-read. | |
| This function returns either: | |
| - nil (no directory local variables found), | |
| - the matching entry from `dir-locals-directory-cache' (a list), | |
| - or the full path to the directory (a string) containing at | |
| least one `dir-locals-file' in the case of no valid cache | |
| entry." | |
| (setq file (expand-file-name file)) | |
| (let* ((locals-dir (locate-dominating-file (file-name-directory file) | |
| #'dir-locals--all-files)) | |
| dir-elt) | |
| ;; `locate-dominating-file' may have abbreviated the name. | |
| (when locals-dir | |
| (setq locals-dir (expand-file-name locals-dir))) | |
| ;; Find the best cached value in `dir-locals-directory-cache'. | |
| (dolist (elt dir-locals-directory-cache) | |
| (when (and (string-prefix-p (car elt) file | |
| (memq system-type | |
| '(windows-nt cygwin ms-dos))) | |
| (> (length (car elt)) (length (car dir-elt)))) | |
| (setq dir-elt elt))) | |
| (if (and dir-elt | |
| (or (null locals-dir) | |
| (<= (length locals-dir) | |
| (length (car dir-elt))))) | |
| ;; Found a potential cache entry. Check validity. | |
| ;; A cache entry with no MTIME is assumed to always be valid | |
| ;; (ie, set directly, not from a dir-locals file). | |
| ;; Note, we don't bother to check that there is a matching class | |
| ;; element in dir-locals-class-alist, since that's done by | |
| ;; dir-locals-set-directory-class. | |
| (if (or (null (nth 2 dir-elt)) | |
| (let ((cached-files (dir-locals--all-files (car dir-elt)))) | |
| ;; The entry MTIME should match the most recent | |
| ;; MTIME among matching files. | |
| (and cached-files | |
| (equal (nth 2 dir-elt) | |
| (let ((latest 0)) | |
| (dolist (f cached-files latest) | |
| (let ((f-time | |
| (file-attribute-modification-time | |
| (file-attributes f)))) | |
| (if (time-less-p latest f-time) | |
| (setq latest f-time))))))))) | |
| ;; This cache entry is OK. | |
| dir-elt | |
| ;; This cache entry is invalid; clear it. | |
| (setq dir-locals-directory-cache | |
| (delq dir-elt dir-locals-directory-cache)) | |
| ;; Return the first existing dir-locals file. Might be the same | |
| ;; as dir-elt's, might not (eg latter might have been deleted). | |
| locals-dir) | |
| ;; No cache entry. | |
| locals-dir))) | |
| (declare-function map-merge-with "map" (type function &rest maps)) | |
| (declare-function map-merge "map" (type &rest maps)) | |
| (defun dir-locals--get-sort-score (node) | |
| "Return a number used for sorting the definitions of dir locals. | |
| NODE is assumed to be a cons cell where the car is either a | |
| string or a symbol representing a mode name. | |
| If it is a mode then the depth of the mode (ie, how many parents | |
| that mode has) will be returned. | |
| If it is a string then the length of the string plus 1000 will be | |
| returned. | |
| Otherwise it returns -1. | |
| That way the value can be used to sort the list such that deeper | |
| modes will be after the other modes. This will be followed by | |
| directory entries in order of length. If the entries are all | |
| applied in order then that means the more specific modes will | |
| override the values specified by the earlier modes and directory | |
| variables will override modes." | |
| (let ((key (car node))) | |
| (cond ((null key) -1) | |
| ((symbolp key) | |
| (let ((mode key) | |
| (depth 0)) | |
| (while (setq mode (get mode 'derived-mode-parent)) | |
| (setq depth (1+ depth))) | |
| depth)) | |
| ((stringp key) | |
| (+ 1000 (length key))) | |
| (t -2)))) | |
| (defun dir-locals--sort-variables (variables) | |
| "Sorts VARIABLES so that applying them in order has the right effect. | |
| The variables are compared by dir-locals--get-sort-score. | |
| Directory entries are then recursively sorted using the same | |
| criteria." | |
| (setq variables (sort variables | |
| (lambda (a b) | |
| (< (dir-locals--get-sort-score a) | |
| (dir-locals--get-sort-score b))))) | |
| (dolist (n variables) | |
| (when (stringp (car n)) | |
| (setcdr n (dir-locals--sort-variables (cdr n))))) | |
| variables) | |
| (defun dir-locals-read-from-dir (dir) | |
| "Load all variables files in DIR and register a new class and instance. | |
| DIR is the absolute name of a directory, which must contain at | |
| least one dir-local file (which is a file holding variables to | |
| apply). | |
| Return the new class name, which is a symbol named DIR." | |
| (let* ((class-name (intern dir)) | |
| (files (dir-locals--all-files dir)) | |
| ;; If there was a problem, use the values we could get but | |
| ;; don't let the cache prevent future reads. | |
| (latest 0) (success 0) | |
| (variables)) | |
| (with-demoted-errors "Error reading dir-locals: %S" | |
| (dolist (file files) | |
| (let ((file-time (file-attribute-modification-time | |
| (file-attributes file)))) | |
| (if (time-less-p latest file-time) | |
| (setq latest file-time))) | |
| (with-temp-buffer | |
| (insert-file-contents file) | |
| (let ((newvars | |
| (condition-case-unless-debug nil | |
| ;; As a defensive measure, we do not allow | |
| ;; circular data in the file/dir-local data. | |
| (let ((read-circle nil)) | |
| (read (current-buffer))) | |
| (end-of-file nil)))) | |
| (setq variables | |
| ;; Try and avoid loading `map' since that also loads cl-lib | |
| ;; which then might hamper bytecomp warnings (bug#30635). | |
| (if (not (and newvars variables)) | |
| (or newvars variables) | |
| (require 'map) | |
| (map-merge-with 'list (lambda (a b) (map-merge 'list a b)) | |
| variables | |
| newvars)))))) | |
| (setq success latest)) | |
| (setq variables (dir-locals--sort-variables variables)) | |
| (dir-locals-set-class-variables class-name variables) | |
| (dir-locals-set-directory-class dir class-name success) | |
| class-name)) | |
| (define-obsolete-function-alias 'dir-locals-read-from-file | |
| 'dir-locals-read-from-dir "25.1") | |
| (defcustom enable-remote-dir-locals nil | |
| "Non-nil means dir-local variables will be applied to remote files." | |
| :version "24.3" | |
| :type 'boolean | |
| :group 'find-file) | |
| (defvar hack-dir-local-variables--warned-coding nil) | |
| (defun hack-dir-local-variables () | |
| "Read per-directory local variables for the current buffer. | |
| Store the directory-local variables in `dir-local-variables-alist' | |
| and `file-local-variables-alist', without applying them. | |
| This does nothing if either `enable-local-variables' or | |
| `enable-dir-local-variables' are nil." | |
| (when (and enable-local-variables | |
| enable-dir-local-variables | |
| (or enable-remote-dir-locals | |
| (not (file-remote-p (or (buffer-file-name) | |
| default-directory))))) | |
| ;; Find the variables file. | |
| (let ((dir-or-cache (dir-locals-find-file | |
| (or (buffer-file-name) default-directory))) | |
| (class nil) | |
| (dir-name nil)) | |
| (cond | |
| ((stringp dir-or-cache) | |
| (setq dir-name dir-or-cache | |
| class (dir-locals-read-from-dir dir-or-cache))) | |
| ((consp dir-or-cache) | |
| (setq dir-name (nth 0 dir-or-cache)) | |
| (setq class (nth 1 dir-or-cache)))) | |
| (when class | |
| (let ((variables | |
| (dir-locals-collect-variables | |
| (dir-locals-get-class-variables class) dir-name nil))) | |
| (when variables | |
| (dolist (elt variables) | |
| (if (eq (car elt) 'coding) | |
| (unless hack-dir-local-variables--warned-coding | |
| (setq hack-dir-local-variables--warned-coding t) | |
| (display-warning 'files | |
| "Coding cannot be specified by dir-locals")) | |
| (unless (memq (car elt) '(eval mode)) | |
| (setq dir-local-variables-alist | |
| (assq-delete-all (car elt) dir-local-variables-alist))) | |
| (push elt dir-local-variables-alist))) | |
| (hack-local-variables-filter variables dir-name))))))) | |
| (defun hack-dir-local-variables-non-file-buffer () | |
| "Apply directory-local variables to a non-file buffer. | |
| For non-file buffers, such as Dired buffers, directory-local | |
| variables are looked for in `default-directory' and its parent | |
| directories." | |
| (hack-dir-local-variables) | |
| (hack-local-variables-apply)) | |
| (defcustom change-major-mode-with-file-name t | |
| "Non-nil means \\[write-file] should set the major mode from the file name. | |
| However, the mode will not be changed if | |
| \(1) a local variables list or the `-*-' line specifies a major mode, or | |
| \(2) the current major mode is a \"special\" mode, | |
| not suitable for ordinary files, or | |
| \(3) the new file name does not particularly specify any mode." | |
| :type 'boolean | |
| :group 'editing-basics) | |
| (defvar after-set-visited-file-name-hook nil | |
| "Normal hook run just after setting visited file name of current buffer.") | |
| (defun set-visited-file-name (filename &optional no-query along-with-file) | |
| "Change name of file visited in current buffer to FILENAME. | |
| This also renames the buffer to correspond to the new file. | |
| The next time the buffer is saved it will go in the newly specified file. | |
| FILENAME nil or an empty string means mark buffer as not visiting any file. | |
| Remember to delete the initial contents of the minibuffer | |
| if you wish to pass an empty string as the argument. | |
| The optional second argument NO-QUERY, if non-nil, inhibits asking for | |
| confirmation in the case where another buffer is already visiting FILENAME. | |
| The optional third argument ALONG-WITH-FILE, if non-nil, means that | |
| the old visited file has been renamed to the new name FILENAME." | |
| (interactive "FSet visited file name: ") | |
| (if (buffer-base-buffer) | |
| (error "An indirect buffer cannot visit a file")) | |
| (let (truename old-try-locals) | |
| (if filename | |
| (setq filename | |
| (if (string-equal filename "") | |
| nil | |
| (expand-file-name filename)))) | |
| (if filename | |
| (progn | |
| (setq truename (file-truename filename)) | |
| (if find-file-visit-truename | |
| (setq filename truename)))) | |
| (if filename | |
| (let ((new-name (file-name-nondirectory filename))) | |
| (if (string= new-name "") | |
| (error "Empty file name")))) | |
| (let ((buffer (and filename (find-buffer-visiting filename)))) | |
| (and buffer (not (eq buffer (current-buffer))) | |
| (not no-query) | |
| (not (y-or-n-p (format "A buffer is visiting %s; proceed? " | |
| filename))) | |
| (user-error "Aborted"))) | |
| (or (equal filename buffer-file-name) | |
| (progn | |
| (and filename (lock-buffer filename)) | |
| (unlock-buffer))) | |
| (setq old-try-locals (not (inhibit-local-variables-p)) | |
| buffer-file-name filename) | |
| (if filename ; make buffer name reflect filename. | |
| (let ((new-name (file-name-nondirectory buffer-file-name))) | |
| (setq default-directory (file-name-directory buffer-file-name)) | |
| ;; If new-name == old-name, renaming would add a spurious <2> | |
| ;; and it's considered as a feature in rename-buffer. | |
| (or (string= new-name (buffer-name)) | |
| (rename-buffer new-name t)))) | |
| (setq buffer-backed-up nil) | |
| (or along-with-file | |
| (clear-visited-file-modtime)) | |
| ;; Abbreviate the file names of the buffer. | |
| (if truename | |
| (progn | |
| (setq buffer-file-truename (abbreviate-file-name truename)) | |
| (if find-file-visit-truename | |
| (setq buffer-file-name truename)))) | |
| (setq buffer-file-number | |
| (if filename | |
| (nthcdr 10 (file-attributes buffer-file-name)) | |
| nil)) | |
| ;; write-file-functions is normally used for things like ftp-find-file | |
| ;; that visit things that are not local files as if they were files. | |
| ;; Changing to visit an ordinary local file instead should flush the hook. | |
| (kill-local-variable 'write-file-functions) | |
| (kill-local-variable 'local-write-file-hooks) | |
| (kill-local-variable 'revert-buffer-function) | |
| (kill-local-variable 'backup-inhibited) | |
| ;; If buffer was read-only because of version control, | |
| ;; that reason is gone now, so make it writable. | |
| (if vc-mode | |
| (setq buffer-read-only nil)) | |
| (kill-local-variable 'vc-mode) | |
| ;; Turn off backup files for certain file names. | |
| ;; Since this is a permanent local, the major mode won't eliminate it. | |
| (and buffer-file-name | |
| backup-enable-predicate | |
| (not (funcall backup-enable-predicate buffer-file-name)) | |
| (progn | |
| (make-local-variable 'backup-inhibited) | |
| (setq backup-inhibited t))) | |
| (let ((oauto buffer-auto-save-file-name)) | |
| (cond ((null filename) | |
| (setq buffer-auto-save-file-name nil)) | |
| ((not buffer-auto-save-file-name) | |
| ;; If auto-save was not already on, turn it on if appropriate. | |
| (and buffer-file-name auto-save-default (auto-save-mode t))) | |
| (t | |
| ;; If auto save is on, start using a new name. We | |
| ;; deliberately don't rename or delete the old auto save | |
| ;; for the old visited file name. This is because | |
| ;; perhaps the user wants to save the new state and then | |
| ;; compare with the previous state from the auto save | |
| ;; file. | |
| (setq buffer-auto-save-file-name (make-auto-save-file-name)))) | |
| ;; Rename the old auto save file if any. | |
| (and oauto buffer-auto-save-file-name | |
| (file-exists-p oauto) | |
| (rename-file oauto buffer-auto-save-file-name t))) | |
| (and buffer-file-name | |
| (not along-with-file) | |
| (set-buffer-modified-p t)) | |
| ;; Update the major mode, if the file name determines it. | |
| (condition-case nil | |
| ;; Don't change the mode if it is special. | |
| (or (not change-major-mode-with-file-name) | |
| (get major-mode 'mode-class) | |
| ;; Don't change the mode if the local variable list specifies it. | |
| ;; The file name can influence whether the local variables apply. | |
| (and old-try-locals | |
| ;; h-l-v also checks it, but might as well be explicit. | |
| (not (inhibit-local-variables-p)) | |
| (hack-local-variables t)) | |
| ;; TODO consider making normal-mode handle this case. | |
| (let ((old major-mode)) | |
| (set-auto-mode t) | |
| (or (eq old major-mode) | |
| (hack-local-variables)))) | |
| (error nil)) | |
| (run-hooks 'after-set-visited-file-name-hook))) | |
| (defun write-file (filename &optional confirm) | |
| "Write current buffer into file FILENAME. | |
| This makes the buffer visit that file, and marks it as not modified. | |
| Interactively, prompt for FILENAME. | |
| If you specify just a directory name as FILENAME, that means to write | |
| to a file in that directory. In this case, the base name of the file | |
| is the same as that of the file visited in the buffer, or the buffer | |
| name sans leading directories, if any, if the buffer is not already | |
| visiting a file. | |
| You can also yank the file name into the minibuffer to edit it, | |
| using \\<minibuffer-local-map>\\[next-history-element]. | |
| If optional second arg CONFIRM is non-nil, this function | |
| asks for confirmation before overwriting an existing file. | |
| Interactively, confirmation is required unless you supply a prefix argument." | |
| ;; (interactive "FWrite file: ") | |
| (interactive | |
| (list (if buffer-file-name | |
| (read-file-name "Write file: " | |
| nil nil nil nil) | |
| (read-file-name "Write file: " default-directory | |
| (expand-file-name | |
| (file-name-nondirectory (buffer-name)) | |
| default-directory) | |
| nil nil)) | |
| (not current-prefix-arg))) | |
| (or (null filename) (string-equal filename "") | |
| (progn | |
| ;; If arg is a directory name, | |
| ;; use the default file name, but in that directory. | |
| (if (directory-name-p filename) | |
| (setq filename (concat filename | |
| (file-name-nondirectory | |
| (or buffer-file-name (buffer-name)))))) | |
| (and confirm | |
| (file-exists-p filename) | |
| ;; NS does its own confirm dialog. | |
| (not (and (eq (framep-on-display) 'ns) | |
| (listp last-nonmenu-event) | |
| use-dialog-box)) | |
| (or (y-or-n-p (format-message | |
| "File `%s' exists; overwrite? " filename)) | |
| (user-error "Canceled"))) | |
| (set-visited-file-name filename (not confirm)))) | |
| (set-buffer-modified-p t) | |
| ;; Make buffer writable if file is writable. | |
| (and buffer-file-name | |
| (file-writable-p buffer-file-name) | |
| (setq buffer-read-only nil)) | |
| (save-buffer) | |
| ;; It's likely that the VC status at the new location is different from | |
| ;; the one at the old location. | |
| (vc-refresh-state)) | |
| (defun file-extended-attributes (filename) | |
| "Return an alist of extended attributes of file FILENAME. | |
| Extended attributes are platform-specific metadata about the file, | |
| such as SELinux context, list of ACL entries, etc." | |
| `((acl . ,(file-acl filename)) | |
| (selinux-context . ,(file-selinux-context filename)))) | |
| (defun set-file-extended-attributes (filename attributes) | |
| "Set extended attributes of file FILENAME to ATTRIBUTES. | |
| ATTRIBUTES must be an alist of file attributes as returned by | |
| `file-extended-attributes'. | |
| Value is t if the function succeeds in setting the attributes." | |
| (let (result rv) | |
| (dolist (elt attributes) | |
| (let ((attr (car elt)) | |
| (val (cdr elt))) | |
| (cond ((eq attr 'acl) | |
| (setq rv (set-file-acl filename val))) | |
| ((eq attr 'selinux-context) | |
| (setq rv (set-file-selinux-context filename val)))) | |
| (setq result (or result rv)))) | |
| result)) | |
| (defun backup-buffer () | |
| "Make a backup of the disk file visited by the current buffer, if appropriate. | |
| This is normally done before saving the buffer the first time. | |
| A backup may be done by renaming or by copying; see documentation of | |
| variable `make-backup-files'. If it's done by renaming, then the file is | |
| no longer accessible under its old name. | |
| The value is non-nil after a backup was made by renaming. | |
| It has the form (MODES EXTENDED-ATTRIBUTES BACKUPNAME). | |
| MODES is the result of `file-modes' on the original | |
| file; this means that the caller, after saving the buffer, should change | |
| the modes of the new file to agree with the old modes. | |
| EXTENDED-ATTRIBUTES is the result of `file-extended-attributes' | |
| on the original file; this means that the caller, after saving | |
| the buffer, should change the extended attributes of the new file | |
| to agree with the old attributes. | |
| BACKUPNAME is the backup file name, which is the old file renamed." | |
| (when (and make-backup-files (not backup-inhibited) (not buffer-backed-up)) | |
| (let ((attributes (file-attributes buffer-file-name))) | |
| (when (and attributes (memq (aref (elt attributes 8) 0) '(?- ?l))) | |
| ;; If specified name is a symbolic link, chase it to the target. | |
| ;; This makes backups in the directory where the real file is. | |
| (let* ((real-file-name (file-chase-links buffer-file-name)) | |
| (backup-info (find-backup-file-name real-file-name))) | |
| (when backup-info | |
| (let* ((backupname (car backup-info)) | |
| (targets (cdr backup-info)) | |
| (old-versions | |
| ;; If have old versions to maybe delete, | |
| ;; ask the user to confirm now, before doing anything. | |
| ;; But don't actually delete til later. | |
| (and targets | |
| (booleanp delete-old-versions) | |
| (or delete-old-versions | |
| (y-or-n-p | |
| (format "Delete excess backup versions of %s? " | |
| real-file-name))) | |
| targets)) | |
| (modes (file-modes buffer-file-name)) | |
| (extended-attributes | |
| (file-extended-attributes buffer-file-name)) | |
| (copy-when-priv-mismatch | |
| backup-by-copying-when-privileged-mismatch) | |
| (make-copy | |
| (or file-precious-flag backup-by-copying | |
| ;; Don't rename a suid or sgid file. | |
| (and modes (< 0 (logand modes #o6000))) | |
| (not (file-writable-p | |
| (file-name-directory real-file-name))) | |
| (and backup-by-copying-when-linked | |
| (< 1 (file-nlinks real-file-name))) | |
| (and (or backup-by-copying-when-mismatch | |
| (and (integerp copy-when-priv-mismatch) | |
| (let ((attr (file-attributes | |
| real-file-name | |
| 'integer))) | |
| (or (<= (file-attribute-user-id attr) | |
| copy-when-priv-mismatch) | |
| (<= (file-attribute-group-id attr) | |
| copy-when-priv-mismatch))))) | |
| (not (file-ownership-preserved-p real-file-name | |
| t))))) | |
| setmodes) | |
| (condition-case () | |
| (progn | |
| ;; Actually make the backup file. | |
| (if make-copy | |
| (backup-buffer-copy real-file-name backupname | |
| modes extended-attributes) | |
| ;; rename-file should delete old backup. | |
| (rename-file real-file-name backupname t) | |
| (setq setmodes (list modes extended-attributes | |
| backupname))) | |
| (setq buffer-backed-up t) | |
| ;; Now delete the old versions, if desired. | |
| (dolist (old-version old-versions) | |
| (delete-file old-version))) | |
| (file-error nil)) | |
| ;; If trouble writing the backup, write it in .emacs.d/%backup%. | |
| (when (not buffer-backed-up) | |
| (setq backupname (locate-user-emacs-file "%backup%~")) | |
| (message "Cannot write backup file; backing up in %s" | |
| backupname) | |
| (sleep-for 1) | |
| (backup-buffer-copy real-file-name backupname | |
| modes extended-attributes) | |
| (setq buffer-backed-up t)) | |
| setmodes))))))) | |
| (defun backup-buffer-copy (from-name to-name modes extended-attributes) | |
| ;; Create temp files with strict access rights. It's easy to | |
| ;; loosen them later, whereas it's impossible to close the | |
| ;; time-window of loose permissions otherwise. | |
| (let (nofollow-flag) | |
| (with-file-modes ?\700 | |
| (when (condition-case nil | |
| ;; Try to overwrite old backup first. | |
| (copy-file from-name to-name t t t) | |
| (error t)) | |
| (while (condition-case nil | |
| (progn | |
| (when (file-exists-p to-name) | |
| (delete-file to-name)) | |
| (copy-file from-name to-name nil t t) | |
| (setq nofollow-flag 'nofollow) | |
| nil) | |
| (file-already-exists t)) | |
| ;; The file was somehow created by someone else between | |
| ;; `delete-file' and `copy-file', so let's try again. | |
| ;; rms says "I think there is also a possible race | |
| ;; condition for making backup files" (emacs-devel 20070821). | |
| nil))) | |
| ;; If set-file-extended-attributes fails, fall back on set-file-modes. | |
| (unless (and extended-attributes | |
| (with-demoted-errors | |
| (set-file-extended-attributes to-name extended-attributes))) | |
| (and modes | |
| (set-file-modes to-name (logand modes #o1777) nofollow-flag))))) | |
| (defvar file-name-version-regexp | |
| "\\(?:~\\|\\.~[-[:alnum:]:#@^._]+\\(?:~[[:digit:]]+\\)?~\\)" | |
| ;; The last ~[[:digit]]+ matches relative versions in git, | |
| ;; e.g. `foo.js.~HEAD~1~'. | |
| "Regular expression matching the backup/version part of a file name. | |
| Used by `file-name-sans-versions'.") | |
| (defun file-name-sans-versions (name &optional keep-backup-version) | |
| "Return file NAME sans backup versions or strings. | |
| This is a separate procedure so your site-init or startup file can | |
| redefine it. | |
| If the optional argument KEEP-BACKUP-VERSION is non-nil, | |
| we do not remove backup version numbers, only true file version numbers. | |
| See also `file-name-version-regexp'." | |
| (let ((handler (find-file-name-handler name 'file-name-sans-versions))) | |
| (if handler | |
| (funcall handler 'file-name-sans-versions name keep-backup-version) | |
| (substring name 0 | |
| (unless keep-backup-version | |
| (string-match (concat file-name-version-regexp "\\'") | |
| name)))))) | |
| (defun file-ownership-preserved-p (file &optional group) | |
| "Return t if deleting FILE and rewriting it would preserve the owner. | |
| Return also t if FILE does not exist. If GROUP is non-nil, check whether | |
| the group would be preserved too." | |
| (let ((handler (find-file-name-handler file 'file-ownership-preserved-p))) | |
| (if handler | |
| (funcall handler 'file-ownership-preserved-p file group) | |
| (let ((attributes (file-attributes file 'integer))) | |
| ;; Return t if the file doesn't exist, since it's true that no | |
| ;; information would be lost by an (attempted) delete and create. | |
| (or (null attributes) | |
| (and (or (= (file-attribute-user-id attributes) (user-uid)) | |
| ;; Files created on Windows by Administrator (RID=500) | |
| ;; have the Administrators group (RID=544) recorded as | |
| ;; their owner. Rewriting them will still preserve the | |
| ;; owner. | |
| (and (eq system-type 'windows-nt) | |
| (= (user-uid) 500) | |
| (= (file-attribute-user-id attributes) 544))) | |
| (or (not group) | |
| ;; On BSD-derived systems files always inherit the parent | |
| ;; directory's group, so skip the group-gid test. | |
| (memq system-type '(berkeley-unix darwin gnu/kfreebsd)) | |
| (= (file-attribute-group-id attributes) (group-gid))) | |
| (let* ((parent (or (file-name-directory file) ".")) | |
| (parent-attributes (file-attributes parent 'integer))) | |
| (and parent-attributes | |
| ;; On some systems, a file created in a setuid directory | |
| ;; inherits that directory's owner. | |
| (or | |
| (= (file-attribute-user-id parent-attributes) | |
| (user-uid)) | |
| (string-match | |
| "^...[^sS]" | |
| (file-attribute-modes parent-attributes))) | |
| ;; On many systems, a file created in a setgid directory | |
| ;; inherits that directory's group. On some systems | |
| ;; this happens even if the setgid bit is not set. | |
| (or (not group) | |
| (= (file-attribute-group-id parent-attributes) | |
| (file-attribute-group-id attributes))))))))))) | |
| (defun file-name-sans-extension (filename) | |
| "Return FILENAME sans final \"extension\". | |
| The extension, in a file name, is the part that begins with the last `.', | |
| except that a leading `.' of the file name, if there is one, doesn't count." | |
| (save-match-data | |
| (let ((file (file-name-sans-versions (file-name-nondirectory filename))) | |
| directory) | |
| (if (and (string-match "\\.[^.]*\\'" file) | |
| (not (eq 0 (match-beginning 0)))) | |
| (if (setq directory (file-name-directory filename)) | |
| ;; Don't use expand-file-name here; if DIRECTORY is relative, | |
| ;; we don't want to expand it. | |
| (concat directory (substring file 0 (match-beginning 0))) | |
| (substring file 0 (match-beginning 0))) | |
| filename)))) | |
| (defun file-name-extension (filename &optional period) | |
| "Return FILENAME's final \"extension\". | |
| The extension, in a file name, is the part that begins with the last `.', | |
| excluding version numbers and backup suffixes, except that a leading `.' | |
| of the file name, if there is one, doesn't count. | |
| Return nil for extensionless file names such as `foo'. | |
| Return the empty string for file names such as `foo.'. | |
| By default, the returned value excludes the period that starts the | |
| extension, but if the optional argument PERIOD is non-nil, the period | |
| is included in the value, and in that case, if FILENAME has no | |
| extension, the value is \"\"." | |
| (save-match-data | |
| (let ((file (file-name-sans-versions (file-name-nondirectory filename)))) | |
| (if (and (string-match "\\.[^.]*\\'" file) | |
| (not (eq 0 (match-beginning 0)))) | |
| (substring file (+ (match-beginning 0) (if period 0 1))) | |
| (if period | |
| ""))))) | |
| (defun file-name-base (&optional filename) | |
| "Return the base name of the FILENAME: no directory, no extension." | |
| (declare (advertised-calling-convention (filename) "27.1")) | |
| (file-name-sans-extension | |
| (file-name-nondirectory (or filename (buffer-file-name))))) | |
| (defcustom make-backup-file-name-function | |
| #'make-backup-file-name--default-function | |
| "A function that `make-backup-file-name' uses to create backup file names. | |
| The function receives a single argument, the original file name. | |
| If you change this, you may need to change `backup-file-name-p' and | |
| `file-name-sans-versions' too. | |
| You could make this buffer-local to do something special for specific files. | |
| For historical reasons, a value of nil means to use the default function. | |
| This should not be relied upon. | |
| See also `backup-directory-alist'." | |
| :version "24.4" ; nil -> make-backup-file-name--default-function | |
| :group 'backup | |
| :type '(choice (const :tag "Deprecated way to get the default function" nil) | |
| (function :tag "Function"))) | |
| (defcustom backup-directory-alist nil | |
| "Alist of filename patterns and backup directory names. | |
| Each element looks like (REGEXP . DIRECTORY). Backups of files with | |
| names matching REGEXP will be made in DIRECTORY. DIRECTORY may be | |
| relative or absolute. If it is absolute, so that all matching files | |
| are backed up into the same directory, the file names in this | |
| directory will be the full name of the file backed up with all | |
| directory separators changed to `!' to prevent clashes. This will not | |
| work correctly if your filesystem truncates the resulting name. | |
| For the common case of all backups going into one directory, the alist | |
| should contain a single element pairing \".\" with the appropriate | |
| directory name. | |
| If this variable is nil, or it fails to match a filename, the backup | |
| is made in the original file's directory. | |
| On MS-DOS filesystems without long names this variable is always | |
| ignored." | |
| :group 'backup | |
| :type '(repeat (cons (regexp :tag "Regexp matching filename") | |
| (directory :tag "Backup directory name")))) | |
| (defun normal-backup-enable-predicate (name) | |
| "Default `backup-enable-predicate' function. | |
| Checks for files in `temporary-file-directory', | |
| `small-temporary-file-directory', and \"/tmp\"." | |
| (let ((temporary-file-directory temporary-file-directory) | |
| caseless) | |
| ;; On MS-Windows, file-truename will convert short 8+3 aliases to | |
| ;; their long file-name equivalents, so compare-strings does TRT. | |
| (if (memq system-type '(ms-dos windows-nt)) | |
| (setq temporary-file-directory (file-truename temporary-file-directory) | |
| name (file-truename name) | |
| caseless t)) | |
| (not (or (let ((comp (compare-strings temporary-file-directory 0 nil | |
| name 0 nil caseless))) | |
| ;; Directory is under temporary-file-directory. | |
| (and (not (eq comp t)) | |
| (< comp (- (length temporary-file-directory))))) | |
| (let ((comp (compare-strings "/tmp" 0 nil | |
| name 0 nil))) | |
| ;; Directory is under /tmp. | |
| (and (not (eq comp t)) | |
| (< comp (- (length "/tmp"))))) | |
| (if small-temporary-file-directory | |
| (let ((comp (compare-strings small-temporary-file-directory | |
| 0 nil | |
| name 0 nil caseless))) | |
| ;; Directory is under small-temporary-file-directory. | |
| (and (not (eq comp t)) | |
| (< comp (- (length small-temporary-file-directory)))))))))) | |
| (defun make-backup-file-name (file) | |
| "Create the non-numeric backup file name for FILE. | |
| This calls the function that `make-backup-file-name-function' specifies, | |
| with a single argument FILE." | |
| (funcall (or make-backup-file-name-function | |
| #'make-backup-file-name--default-function) | |
| file)) | |
| (defun make-backup-file-name--default-function (file) | |
| "Default function for `make-backup-file-name'. | |
| Normally this just returns FILE's name with `~' appended. | |
| It searches for a match for FILE in `backup-directory-alist'. | |
| If the directory for the backup doesn't exist, it is created." | |
| (if (and (eq system-type 'ms-dos) | |
| (not (msdos-long-file-names))) | |
| (let ((fn (file-name-nondirectory file))) | |
| (concat (file-name-directory file) | |
| (or (and (string-match "\\`[^.]+\\'" fn) | |
| (concat (match-string 0 fn) ".~")) | |
| (and (string-match "\\`[^.]+\\.\\(..?\\)?" fn) | |
| (concat (match-string 0 fn) "~"))))) | |
| (concat (make-backup-file-name-1 file) "~"))) | |
| (defun make-backup-file-name-1 (file) | |
| "Subroutine of `make-backup-file-name--default-function'. | |
| The function `find-backup-file-name' also uses this." | |
| (let ((alist backup-directory-alist) | |
| elt backup-directory abs-backup-directory) | |
| (while alist | |
| (setq elt (pop alist)) | |
| (if (string-match (car elt) file) | |
| (setq backup-directory (cdr elt) | |
| alist nil))) | |
| ;; If backup-directory is relative, it should be relative to the | |
| ;; file's directory. By expanding explicitly here, we avoid | |
| ;; depending on default-directory. | |
| (if backup-directory | |
| (setq abs-backup-directory | |
| (expand-file-name backup-directory | |
| (file-name-directory file)))) | |
| (if (and abs-backup-directory (not (file-exists-p abs-backup-directory))) | |
| (condition-case nil | |
| (make-directory abs-backup-directory 'parents) | |
| (file-error (setq backup-directory nil | |
| abs-backup-directory nil)))) | |
| (if (null backup-directory) | |
| file | |
| (if (file-name-absolute-p backup-directory) | |
| (progn | |
| (when (memq system-type '(windows-nt ms-dos cygwin)) | |
| ;; Normalize DOSish file names: downcase the drive | |
| ;; letter, if any, and replace the leading "x:" with | |
| ;; "/drive_x". | |
| (or (file-name-absolute-p file) | |
| (setq file (expand-file-name file))) ; make defaults explicit | |
| (cond | |
| ((file-remote-p file) | |
| ;; Remove the leading slash, if any, to prevent | |
| ;; convert-standard-filename from converting that to a | |
| ;; backslash. | |
| (and (memq (aref file 0) '(?/ ?\\)) | |
| (setq file (substring file 1))) | |
| ;; Replace any invalid file-name characters, then | |
| ;; prepend the leading slash back. | |
| (setq file (concat "/" (convert-standard-filename file)))) | |
| (t | |
| ;; Replace any invalid file-name characters. | |
| (setq file (expand-file-name (convert-standard-filename file))) | |
| (if (eq (aref file 1) ?:) | |
| (setq file (concat "/" | |
| "drive_" | |
| (char-to-string (downcase (aref file 0))) | |
| (if (eq (aref file 2) ?/) | |
| "" | |
| "/") | |
| (substring file 2))))))) | |
| ;; Make the name unique by substituting directory | |
| ;; separators. It may not really be worth bothering about | |
| ;; doubling `!'s in the original name... | |
| (expand-file-name | |
| (subst-char-in-string | |
| ?/ ?! | |
| (replace-regexp-in-string "!" "!!" file)) | |
| backup-directory)) | |
| (expand-file-name (file-name-nondirectory file) | |
| (file-name-as-directory abs-backup-directory)))))) | |
| (defun backup-file-name-p (file) | |
| "Return non-nil if FILE is a backup file name (numeric or not). | |
| This is a separate function so you can redefine it for customization. | |
| You may need to redefine `file-name-sans-versions' as well." | |
| (string-match "~\\'" file)) | |
| (defvar backup-extract-version-start) | |
| ;; This is used in various files. | |
| ;; The usage of backup-extract-version-start is not very clean, | |
| ;; but I can't see a good alternative, so as of now I am leaving it alone. | |
| (defun backup-extract-version (fn) | |
| "Given the name of a numeric backup file, FN, return the backup number. | |
| Uses the free variable `backup-extract-version-start', whose value should be | |
| the index in the name where the version number begins." | |
| (if (and (string-match "[0-9]+~/?$" fn backup-extract-version-start) | |
| (= (match-beginning 0) backup-extract-version-start)) | |
| (string-to-number (substring fn backup-extract-version-start -1)) | |
| 0)) | |
| (defun find-backup-file-name (fn) | |
| "Find a file name for a backup file FN, and suggestions for deletions. | |
| Value is a list whose car is the name for the backup file | |
| and whose cdr is a list of old versions to consider deleting now. | |
| If the value is nil, don't make a backup. | |
| Uses `backup-directory-alist' in the same way as | |
| `make-backup-file-name--default-function' does." | |
| (let ((handler (find-file-name-handler fn 'find-backup-file-name))) | |
| ;; Run a handler for this function so that ange-ftp can refuse to do it. | |
| (if handler | |
| (funcall handler 'find-backup-file-name fn) | |
| (if (or (eq version-control 'never) | |
| ;; We don't support numbered backups on plain MS-DOS | |
| ;; when long file names are unavailable. | |
| (and (eq system-type 'ms-dos) | |
| (not (msdos-long-file-names)))) | |
| (list (make-backup-file-name fn)) | |
| (let* ((basic-name (make-backup-file-name-1 fn)) | |
| (base-versions (concat (file-name-nondirectory basic-name) | |
| ".~")) | |
| (backup-extract-version-start (length base-versions)) | |
| (high-water-mark 0) | |
| (number-to-delete 0) | |
| possibilities deserve-versions-p versions) | |
| (condition-case () | |
| (setq possibilities (file-name-all-completions | |
| base-versions | |
| (file-name-directory basic-name)) | |
| versions (sort (mapcar #'backup-extract-version | |
| possibilities) | |
| #'<) | |
| high-water-mark (apply 'max 0 versions) | |
| deserve-versions-p (or version-control | |
| (> high-water-mark 0)) | |
| number-to-delete (- (length versions) | |
| kept-old-versions | |
| kept-new-versions | |
| -1)) | |
| (file-error (setq possibilities nil))) | |
| (if (not deserve-versions-p) | |
| (list (make-backup-file-name fn)) | |
| (cons (format "%s.~%d~" basic-name (1+ high-water-mark)) | |
| (if (and (> number-to-delete 0) | |
| ;; Delete nothing if kept-new-versions and | |
| ;; kept-old-versions combine to an outlandish value. | |
| (>= (+ kept-new-versions kept-old-versions -1) 0)) | |
| (mapcar (lambda (n) | |
| (format "%s.~%d~" basic-name n)) | |
| (let ((v (nthcdr kept-old-versions versions))) | |
| (rplacd (nthcdr (1- number-to-delete) v) ()) | |
| v)))))))))) | |
| (defun file-nlinks (filename) | |
| "Return number of names file FILENAME has." | |
| (car (cdr (file-attributes filename)))) | |
| (defun file-relative-name (filename &optional directory) | |
| "Convert FILENAME to be relative to DIRECTORY (default: `default-directory'). | |
| This function returns a relative file name that is equivalent to FILENAME | |
| when used with that default directory as the default. | |
| If FILENAME is a relative file name, it will be interpreted as existing in | |
| `default-directory'. | |
| If FILENAME and DIRECTORY lie on different machines or on different drives | |
| on a DOS/Windows machine, it returns FILENAME in expanded form." | |
| (save-match-data | |
| (setq directory | |
| (file-name-as-directory (expand-file-name (or directory | |
| default-directory)))) | |
| (setq filename (expand-file-name filename)) | |
| (let ((fremote (file-remote-p filename)) | |
| (dremote (file-remote-p directory)) | |
| (fold-case (or (file-name-case-insensitive-p filename) | |
| read-file-name-completion-ignore-case))) | |
| (if ;; Conditions for separate trees | |
| (or | |
| ;; Test for different filesystems on DOS/Windows | |
| (and | |
| ;; Should `cygwin' really be included here? --stef | |
| (memq system-type '(ms-dos cygwin windows-nt)) | |
| (or | |
| ;; Test for different drive letters | |
| (not (eq t (compare-strings filename 0 2 directory 0 2 fold-case))) | |
| ;; Test for UNCs on different servers | |
| (not (eq t (compare-strings | |
| (progn | |
| (if (string-match "\\`//\\([^:/]+\\)/" filename) | |
| (match-string 1 filename) | |
| ;; Windows file names cannot have ? in | |
| ;; them, so use that to detect when | |
| ;; neither FILENAME nor DIRECTORY is a | |
| ;; UNC. | |
| "?")) | |
| 0 nil | |
| (progn | |
| (if (string-match "\\`//\\([^:/]+\\)/" directory) | |
| (match-string 1 directory) | |
| "?")) | |
| 0 nil t))))) | |
| ;; Test for different remote file system identification | |
| (not (equal fremote dremote))) | |
| filename | |
| (let ((ancestor ".") | |
| (filename-dir (file-name-as-directory filename))) | |
| (while (not | |
| (or (string-prefix-p directory filename-dir fold-case) | |
| (string-prefix-p directory filename fold-case))) | |
| (setq directory (file-name-directory (substring directory 0 -1)) | |
| ancestor (if (equal ancestor ".") | |
| ".." | |
| (concat "../" ancestor)))) | |
| ;; Now ancestor is empty, or .., or ../.., etc. | |
| (if (string-prefix-p directory filename fold-case) | |
| ;; We matched within FILENAME's directory part. | |
| ;; Add the rest of FILENAME onto ANCESTOR. | |
| (let ((rest (substring filename (length directory)))) | |
| (if (and (equal ancestor ".") (not (equal rest ""))) | |
| ;; But don't bother with ANCESTOR if it would give us `./'. | |
| rest | |
| (concat (file-name-as-directory ancestor) rest))) | |
| ;; We matched FILENAME's directory equivalent. | |
| ancestor)))))) | |
| (defun save-buffer (&optional arg) | |
| "Save current buffer in visited file if modified. | |
| Variations are described below. | |
| By default, makes the previous version into a backup file | |
| if previously requested or if this is the first save. | |
| Prefixed with one \\[universal-argument], marks this version | |
| to become a backup when the next save is done. | |
| Prefixed with two \\[universal-argument]'s, | |
| makes the previous version into a backup file. | |
| Prefixed with three \\[universal-argument]'s, marks this version | |
| to become a backup when the next save is done, | |
| and makes the previous version into a backup file. | |
| With a numeric prefix argument of 0, never make the previous version | |
| into a backup file. | |
| Note that the various variables that control backups, such | |
| as `version-control', `backup-enable-predicate', `vc-make-backup-files', | |
| and `backup-inhibited', to name just the more popular ones, still | |
| control whether a backup will actually be produced, even when you | |
| invoke this command prefixed with two or three \\[universal-argument]'s. | |
| If a file's name is FOO, the names of its numbered backup versions are | |
| FOO.~i~ for various integers i. A non-numbered backup file is called FOO~. | |
| Numeric backups (rather than FOO~) will be made if value of | |
| `version-control' is not the atom `never' and either there are already | |
| numeric versions of the file being backed up, or `version-control' is | |
| non-nil. | |
| We don't want excessive versions piling up, so there are variables | |
| `kept-old-versions', which tells Emacs how many oldest versions to keep, | |
| and `kept-new-versions', which tells how many newest versions to keep. | |
| Defaults are 2 old versions and 2 new. | |
| `dired-kept-versions' controls dired's clean-directory (.) command. | |
| If `delete-old-versions' is nil, system will query user | |
| before trimming versions. Otherwise it does it silently. | |
| If `vc-make-backup-files' is nil, which is the default, | |
| no backup files are made for files managed by version control. | |
| (This is because the version control system itself records previous versions.) | |
| See the subroutine `basic-save-buffer' for more information." | |
| (interactive "p") | |
| (let ((modp (buffer-modified-p)) | |
| (make-backup-files (or (and make-backup-files (not (eq arg 0))) | |
| (memq arg '(16 64))))) | |
| (and modp (memq arg '(16 64)) (setq buffer-backed-up nil)) | |
| ;; We used to display the message below only for files > 50KB, but | |
| ;; then Rmail-mbox never displays it due to buffer swapping. If | |
| ;; the test is ever re-introduced, be sure to handle saving of | |
| ;; Rmail files. | |
| (if (and modp | |
| (buffer-file-name) | |
| (not noninteractive) | |
| (not save-silently)) | |
| (message "Saving file %s..." (buffer-file-name))) | |
| (basic-save-buffer (called-interactively-p 'any)) | |
| (and modp (memq arg '(4 64)) (setq buffer-backed-up nil)))) | |
| (defun delete-auto-save-file-if-necessary (&optional force) | |
| "Delete auto-save file for current buffer if `delete-auto-save-files' is t. | |
| Normally delete only if the file was written by this Emacs since | |
| the last real save, but optional arg FORCE non-nil means delete anyway." | |
| (and buffer-auto-save-file-name delete-auto-save-files | |
| (not (string= buffer-file-name buffer-auto-save-file-name)) | |
| (or force (recent-auto-save-p)) | |
| (progn | |
| (condition-case () | |
| (delete-file buffer-auto-save-file-name) | |
| (file-error nil)) | |
| (set-buffer-auto-saved)))) | |
| (defvar auto-save-hook nil | |
| "Normal hook run just before auto-saving.") | |
| (defcustom before-save-hook nil | |
| "Normal hook that is run before a buffer is saved to its file. | |
| Used only by `save-buffer'." | |
| :options '(copyright-update time-stamp) | |
| :type 'hook | |
| :group 'files) | |
| (defcustom after-save-hook nil | |
| "Normal hook that is run after a buffer is saved to its file. | |
| Used only by `save-buffer'." | |
| :options '(executable-make-buffer-file-executable-if-script-p) | |
| :type 'hook | |
| :group 'files) | |
| (defvar save-buffer-coding-system nil | |
| "If non-nil, use this coding system for saving the buffer. | |
| More precisely, use this coding system in place of the | |
| value of `buffer-file-coding-system', when saving the buffer. | |
| Calling `write-region' for any purpose other than saving the buffer | |
| will still use `buffer-file-coding-system'; this variable has no effect | |
| in such cases.") | |
| (make-variable-buffer-local 'save-buffer-coding-system) | |
| (put 'save-buffer-coding-system 'permanent-local t) | |
| (defun basic-save-buffer (&optional called-interactively) | |
| "Save the current buffer in its visited file, if it has been modified. | |
| The hooks `write-contents-functions', `local-write-file-hooks' | |
| and `write-file-functions' get a chance to do the job of saving; | |
| if they do not, then the buffer is saved in the visited file in | |
| the usual way. | |
| Before and after saving the buffer, this function runs | |
| `before-save-hook' and `after-save-hook', respectively." | |
| (interactive '(called-interactively)) | |
| (save-current-buffer | |
| ;; In an indirect buffer, save its base buffer instead. | |
| (if (buffer-base-buffer) | |
| (set-buffer (buffer-base-buffer))) | |
| (if (or (buffer-modified-p) | |
| ;; Handle the case when no modification has been made but | |
| ;; the file disappeared since visited. | |
| (and buffer-file-name | |
| (not (file-exists-p buffer-file-name)))) | |
| (let ((recent-save (recent-auto-save-p)) | |
| setmodes) | |
| (or (null buffer-file-name) | |
| (verify-visited-file-modtime (current-buffer)) | |
| (not (file-exists-p buffer-file-name)) | |
| (yes-or-no-p | |
| (format | |
| "%s has changed since visited or saved. Save anyway? " | |
| (file-name-nondirectory buffer-file-name))) | |
| (user-error "Save not confirmed")) | |
| (save-restriction | |
| (widen) | |
| (save-excursion | |
| (and (> (point-max) (point-min)) | |
| (not find-file-literally) | |
| (null buffer-read-only) | |
| (/= (char-after (1- (point-max))) ?\n) | |
| (not (and (eq selective-display t) | |
| (= (char-after (1- (point-max))) ?\r))) | |
| (or (eq require-final-newline t) | |
| (eq require-final-newline 'visit-save) | |
| (and require-final-newline | |
| (y-or-n-p | |
| (format "Buffer %s does not end in newline. Add one? " | |
| (buffer-name))))) | |
| (save-excursion | |
| (goto-char (point-max)) | |
| (insert ?\n)))) | |
| ;; Don't let errors prevent saving the buffer. | |
| (with-demoted-errors (run-hooks 'before-save-hook)) | |
| ;; Give `write-contents-functions' a chance to | |
| ;; short-circuit the whole process. | |
| (unless (run-hook-with-args-until-success 'write-contents-functions) | |
| ;; If buffer has no file name, ask user for one. | |
| (or buffer-file-name | |
| (let ((filename | |
| (expand-file-name | |
| (read-file-name "File to save in: " | |
| nil (expand-file-name (buffer-name)))))) | |
| (if (file-exists-p filename) | |
| (if (file-directory-p filename) | |
| ;; Signal an error if the user specified the name of an | |
| ;; existing directory. | |
| (error "%s is a directory" filename) | |
| (unless (y-or-n-p (format-message | |
| "File `%s' exists; overwrite? " | |
| filename)) | |
| (error "Canceled")))) | |
| (set-visited-file-name filename))) | |
| ;; Support VC version backups. | |
| (vc-before-save) | |
| (or (run-hook-with-args-until-success 'local-write-file-hooks) | |
| (run-hook-with-args-until-success 'write-file-functions) | |
| ;; If a hook returned t, file is already "written". | |
| ;; Otherwise, write it the usual way now. | |
| (let ((dir (file-name-directory | |
| (expand-file-name buffer-file-name)))) | |
| (unless (file-exists-p dir) | |
| (if (y-or-n-p | |
| (format-message | |
| "Directory `%s' does not exist; create? " dir)) | |
| (make-directory dir t) | |
| (error "Canceled"))) | |
| (setq setmodes (basic-save-buffer-1))))) | |
| ;; Now we have saved the current buffer. Let's make sure | |
| ;; that buffer-file-coding-system is fixed to what | |
| ;; actually used for saving by binding it locally. | |
| (when buffer-file-name | |
| (if save-buffer-coding-system | |
| (setq save-buffer-coding-system last-coding-system-used) | |
| (setq buffer-file-coding-system last-coding-system-used)) | |
| (setq buffer-file-number | |
| (nthcdr 10 (file-attributes buffer-file-name))) | |
| (if setmodes | |
| (condition-case () | |
| (progn | |
| (unless | |
| (with-demoted-errors | |
| (set-file-modes buffer-file-name (car setmodes))) | |
| (set-file-extended-attributes buffer-file-name | |
| (nth 1 setmodes)))) | |
| (error nil))) | |
| ;; Support VC `implicit' locking. | |
| (vc-after-save)) | |
| ;; If the auto-save file was recent before this command, | |
| ;; delete it now. | |
| (delete-auto-save-file-if-necessary recent-save)) | |
| (run-hooks 'after-save-hook)) | |
| (or noninteractive | |
| (not called-interactively) | |
| (files--message "(No changes need to be saved)"))))) | |
| ;; This does the "real job" of writing a buffer into its visited file | |
| ;; and making a backup file. This is what is normally done | |
| ;; but inhibited if one of write-file-functions returns non-nil. | |
| ;; It returns a value (MODES EXTENDED-ATTRIBUTES BACKUPNAME), like | |
| ;; backup-buffer. | |
| (defun basic-save-buffer-1 () | |
| (prog1 | |
| (if save-buffer-coding-system | |
| (let ((coding-system-for-write save-buffer-coding-system)) | |
| (basic-save-buffer-2)) | |
| (basic-save-buffer-2)) | |
| (if buffer-file-coding-system-explicit | |
| (setcar buffer-file-coding-system-explicit last-coding-system-used)))) | |
| ;; This returns a value (MODES EXTENDED-ATTRIBUTES BACKUPNAME), like | |
| ;; backup-buffer. | |
| (defun basic-save-buffer-2 () | |
| (let (tempsetmodes setmodes) | |
| (if (not (file-writable-p buffer-file-name)) | |
| (let ((dir (file-name-directory buffer-file-name))) | |
| (if (not (file-directory-p dir)) | |
| (if (file-exists-p dir) | |
| (error "%s is not a directory" dir) | |
| (error "%s: no such directory" dir)) | |
| (if (not (file-exists-p buffer-file-name)) | |
| (error "Directory %s write-protected" dir) | |
| (if (yes-or-no-p | |
| (format | |
| "File %s is write-protected; try to save anyway? " | |
| (file-name-nondirectory | |
| buffer-file-name))) | |
| (setq tempsetmodes t) | |
| (error "Attempt to save to a file that you aren't allowed to write")))))) | |
| (or buffer-backed-up | |
| (setq setmodes (backup-buffer))) | |
| (let* ((dir (file-name-directory buffer-file-name)) | |
| (dir-writable (file-writable-p dir))) | |
| (if (or (and file-precious-flag dir-writable) | |
| (and break-hardlink-on-save | |
| (file-exists-p buffer-file-name) | |
| (> (file-nlinks buffer-file-name) 1) | |
| (or dir-writable | |
| (error (concat "Directory %s write-protected; " | |
| "cannot break hardlink when saving") | |
| dir)))) | |
| ;; Write temp name, then rename it. | |
| ;; This requires write access to the containing dir, | |
| ;; which is why we don't try it if we don't have that access. | |
| (let ((realname buffer-file-name) | |
| tempname | |
| (old-modtime (visited-file-modtime))) | |
| ;; Create temp files with strict access rights. It's easy to | |
| ;; loosen them later, whereas it's impossible to close the | |
| ;; time-window of loose permissions otherwise. | |
| (condition-case err | |
| (progn | |
| (clear-visited-file-modtime) | |
| ;; Call write-region in the appropriate way | |
| ;; for saving the buffer. | |
| (setq tempname | |
| (make-temp-file | |
| (expand-file-name "tmp" dir))) | |
| ;; Pass in nil&nil rather than point-min&max | |
| ;; cause we're saving the whole buffer. | |
| ;; write-region-annotate-functions may use it. | |
| (write-region nil nil tempname nil realname | |
| buffer-file-truename) | |
| (when save-silently (message nil))) | |
| ;; If we failed, restore the buffer's modtime. | |
| (error (set-visited-file-modtime old-modtime) | |
| (signal (car err) (cdr err)))) | |
| ;; Since we have created an entirely new file, | |
| ;; make sure it gets the right permission bits set. | |
| (setq setmodes (or setmodes | |
| (list (or (file-modes buffer-file-name) | |
| (logand ?\666 (default-file-modes))) | |
| (file-extended-attributes buffer-file-name) | |
| buffer-file-name))) | |
| ;; We succeeded in writing the temp file, | |
| ;; so rename it. | |
| (rename-file tempname buffer-file-name t)) | |
| ;; If file not writable, see if we can make it writable | |
| ;; temporarily while we write it. | |
| ;; But no need to do so if we have just backed it up | |
| ;; (setmodes is set) because that says we're superseding. | |
| (cond ((and tempsetmodes (not setmodes)) | |
| ;; Change the mode back, after writing. | |
| (setq setmodes (list (file-modes buffer-file-name) | |
| (file-extended-attributes buffer-file-name) | |
| buffer-file-name)) | |
| ;; If set-file-extended-attributes fails, fall back on | |
| ;; set-file-modes. | |
| (unless | |
| (with-demoted-errors | |
| (set-file-extended-attributes buffer-file-name | |
| (nth 1 setmodes))) | |
| (set-file-modes buffer-file-name | |
| (logior (car setmodes) 128))))) | |
| (let (success) | |
| (unwind-protect | |
| (progn | |
| ;; Pass in nil&nil rather than point-min&max to indicate | |
| ;; we're saving the buffer rather than just a region. | |
| ;; write-region-annotate-functions may make use of it. | |
| (write-region nil nil | |
| buffer-file-name nil t buffer-file-truename) | |
| (when save-silently (message nil)) | |
| (setq success t)) | |
| ;; If we get an error writing the new file, and we made | |
| ;; the backup by renaming, undo the backing-up. | |
| (and setmodes (not success) | |
| (progn | |
| (rename-file (nth 2 setmodes) buffer-file-name t) | |
| (setq buffer-backed-up nil))))))) | |
| setmodes)) | |
| (declare-function diff-no-select "diff" | |
| (old new &optional switches no-async buf)) | |
| (defvar save-some-buffers--switch-window-callback nil) | |
| (defvar save-some-buffers-action-alist | |
| `((?\C-r | |
| ,(lambda (buf) | |
| (if (not enable-recursive-minibuffers) | |
| (progn (display-buffer buf) | |
| (setq other-window-scroll-buffer buf)) | |
| (view-buffer buf (lambda (_) (exit-recursive-edit))) | |
| (recursive-edit)) | |
| ;; Return nil to ask about BUF again. | |
| nil) | |
| ,(purecopy "view this buffer")) | |
| (?\C-f | |
| ,(lambda (buf) | |
| (funcall save-some-buffers--switch-window-callback buf) | |
| (setq quit-flag t)) | |
| ,(purecopy "view this buffer and quit")) | |
| (?d ,(lambda (buf) | |
| (if (null (buffer-file-name buf)) | |
| (message "Not applicable: no file") | |
| (require 'diff) ;for diff-no-select. | |
| (let ((diffbuf (diff-no-select (buffer-file-name buf) buf | |
| nil 'noasync))) | |
| (if (not enable-recursive-minibuffers) | |
| (progn (display-buffer diffbuf) | |
| (setq other-window-scroll-buffer diffbuf)) | |
| (view-buffer diffbuf (lambda (_) (exit-recursive-edit))) | |
| (recursive-edit)))) | |
| ;; Return nil to ask about BUF again. | |
| nil) | |
| ,(purecopy "view changes in this buffer"))) | |
| "ACTION-ALIST argument used in call to `map-y-or-n-p'.") | |
| (put 'save-some-buffers-action-alist 'risky-local-variable t) | |
| (defvar buffer-save-without-query nil | |
| "Non-nil means `save-some-buffers' should save this buffer without asking.") | |
| (make-variable-buffer-local 'buffer-save-without-query) | |
| (defcustom save-some-buffers-default-predicate nil | |
| "Default predicate for `save-some-buffers'. | |
| This allows you to stop `save-some-buffers' from asking | |
| about certain files that you'd usually rather not save. | |
| This function is called (with no parameters) from the buffer to | |
| be saved." | |
| :group 'auto-save | |
| ;; FIXME nil should not be a valid option, let alone the default, | |
| ;; eg so that add-function can be used. | |
| :type '(choice (const :tag "Default" nil) function) | |
| :version "26.1") | |
| (defun save-some-buffers (&optional arg pred) | |
| "Save some modified file-visiting buffers. Asks user about each one. | |
| You can answer `y' or SPC to save, `n' or DEL not to save, `C-r' | |
| to look at the buffer in question with `view-buffer' before | |
| deciding, `d' to view the differences using | |
| `diff-buffer-with-file', `!' to save the buffer and all remaining | |
| buffers without any further querying, `.' to save only the | |
| current buffer and skip the remaining ones and `q' or RET to exit | |
| the function without saving any more buffers. `C-h' displays a | |
| help message describing these options. | |
| This command first saves any buffers where `buffer-save-without-query' is | |
| non-nil, without asking. | |
| Optional argument ARG (interactively, prefix argument) non-nil means save | |
| all with no questions. | |
| Optional second argument PRED determines which buffers are considered: | |
| If PRED is nil, all the file-visiting buffers are considered. | |
| If PRED is t, then certain non-file buffers will also be considered. | |
| If PRED is a zero-argument function, it indicates for each buffer whether | |
| to consider it or not when called with that buffer current. | |
| PRED defaults to the value of `save-some-buffers-default-predicate'. | |
| See `save-some-buffers-action-alist' if you want to | |
| change the additional actions you can take on files." | |
| (interactive "P") | |
| (unless pred | |
| (setq pred save-some-buffers-default-predicate)) | |
| (let* ((switched-buffer nil) | |
| (save-some-buffers--switch-window-callback | |
| (lambda (buffer) | |
| (setq switched-buffer buffer))) | |
| queried autosaved-buffers | |
| files-done abbrevs-done) | |
| (unwind-protect | |
| (save-window-excursion | |
| (dolist (buffer (buffer-list)) | |
| ;; First save any buffers that we're supposed to save | |
| ;; unconditionally. That way the following code won't ask | |
| ;; about them. | |
| (with-current-buffer buffer | |
| (when (and buffer-save-without-query (buffer-modified-p)) | |
| (push (buffer-name) autosaved-buffers) | |
| (save-buffer)))) | |
| ;; Ask about those buffers that merit it, | |
| ;; and record the number thus saved. | |
| (setq files-done | |
| (map-y-or-n-p | |
| (lambda (buffer) | |
| ;; Note that killing some buffers may kill others via | |
| ;; hooks (e.g. Rmail and its viewing buffer). | |
| (and (buffer-live-p buffer) | |
| (buffer-modified-p buffer) | |
| (not (buffer-base-buffer buffer)) | |
| (or | |
| (buffer-file-name buffer) | |
| (with-current-buffer buffer | |
| (or (eq buffer-offer-save 'always) | |
| (and pred buffer-offer-save | |
| (> (buffer-size) 0))))) | |
| (or (not (functionp pred)) | |
| (with-current-buffer buffer (funcall pred))) | |
| (if arg | |
| t | |
| (setq queried t) | |
| (if (buffer-file-name buffer) | |
| (format "Save file %s? " | |
| (buffer-file-name buffer)) | |
| (format "Save buffer %s? " | |
| (buffer-name buffer)))))) | |
| (lambda (buffer) | |
| (with-current-buffer buffer | |
| (save-buffer))) | |
| (buffer-list) | |
| '("buffer" "buffers" "save") | |
| save-some-buffers-action-alist)) | |
| ;; Maybe to save abbrevs, and record whether | |
| ;; we either saved them or asked to. | |
| (and save-abbrevs abbrevs-changed | |
| (progn | |
| (if (or arg | |
| (eq save-abbrevs 'silently) | |
| (y-or-n-p (format "Save abbrevs in %s? " | |
| abbrev-file-name))) | |
| (write-abbrev-file nil)) | |
| ;; Don't keep bothering user if he says no. | |
| (setq abbrevs-changed nil) | |
| (setq abbrevs-done t))) | |
| (or queried (> files-done 0) abbrevs-done | |
| (cond | |
| ((null autosaved-buffers) | |
| (when (called-interactively-p 'any) | |
| (files--message "(No files need saving)"))) | |
| ((= (length autosaved-buffers) 1) | |
| (files--message "(Saved %s)" (car autosaved-buffers))) | |
| (t | |
| (files--message | |
| "(Saved %d files: %s)" (length autosaved-buffers) | |
| (mapconcat 'identity autosaved-buffers ", ")))))) | |
| (when switched-buffer | |
| (pop-to-buffer-same-window switched-buffer))))) | |
| (defun clear-visited-file-modtime () | |
| "Clear out records of last mod time of visited file. | |
| Next attempt to save will not complain of a discrepancy." | |
| (set-visited-file-modtime 0)) | |
| (defun not-modified (&optional arg) | |
| "Mark current buffer as unmodified, not needing to be saved. | |
| With prefix ARG, mark buffer as modified, so \\[save-buffer] will save. | |
| It is not a good idea to use this function in Lisp programs, because it | |
| prints a message in the minibuffer. Instead, use `set-buffer-modified-p'." | |
| (declare (interactive-only set-buffer-modified-p)) | |
| (interactive "P") | |
| (files--message (if arg "Modification-flag set" | |
| "Modification-flag cleared")) | |
| (set-buffer-modified-p arg)) | |
| (defun toggle-read-only (&optional arg interactive) | |
| "Change whether this buffer is read-only." | |
| (declare (obsolete read-only-mode "24.3")) | |
| (interactive (list current-prefix-arg t)) | |
| (if interactive | |
| (call-interactively 'read-only-mode) | |
| (read-only-mode (or arg 'toggle)))) | |
| (defun insert-file (filename) | |
| "Insert contents of file FILENAME into buffer after point. | |
| Set mark after the inserted text. | |
| This function is meant for the user to run interactively. | |
| Don't call it from programs! Use `insert-file-contents' instead. | |
| \(Its calling sequence is different; see its documentation)." | |
| (declare (interactive-only insert-file-contents)) | |
| (interactive "*fInsert file: ") | |
| (insert-file-1 filename #'insert-file-contents)) | |
| (defun append-to-file (start end filename) | |
| "Append the contents of the region to the end of file FILENAME. | |
| When called from a function, expects three arguments, | |
| START, END and FILENAME. START and END are normally buffer positions | |
| specifying the part of the buffer to write. | |
| If START is nil, that means to use the entire buffer contents. | |
| If START is a string, then output that string to the file | |
| instead of any buffer contents; END is ignored. | |
| This does character code conversion and applies annotations | |
| like `write-region' does." | |
| (interactive "r\nFAppend to file: ") | |
| (prog1 (write-region start end filename t) | |
| (when save-silently (message nil)))) | |
| (defun file-newest-backup (filename) | |
| "Return most recent backup file for FILENAME or nil if no backups exist." | |
| ;; `make-backup-file-name' will get us the right directory for | |
| ;; ordinary or numeric backups. It might create a directory for | |
| ;; backups as a side-effect, according to `backup-directory-alist'. | |
| (let* ((filename (file-name-sans-versions | |
| (make-backup-file-name (expand-file-name filename)))) | |
| (file (file-name-nondirectory filename)) | |
| (dir (file-name-directory filename)) | |
| (comp (file-name-all-completions file dir)) | |
| (newest nil) | |
| tem) | |
| (while comp | |
| (setq tem (pop comp)) | |
| (cond ((and (backup-file-name-p tem) | |
| (string= (file-name-sans-versions tem) file)) | |
| (setq tem (concat dir tem)) | |
| (if (or (null newest) | |
| (file-newer-than-file-p tem newest)) | |
| (setq newest tem))))) | |
| newest)) | |
| (defun rename-uniquely () | |
| "Rename current buffer to a similar name not already taken. | |
| This function is useful for creating multiple shell process buffers | |
| or multiple mail buffers, etc. | |
| Note that some commands, in particular those based on `compilation-mode' | |
| \(`compile', `grep', etc.) will reuse the current buffer if it has the | |
| appropriate mode even if it has been renamed. So as well as renaming | |
| the buffer, you also need to switch buffers before running another | |
| instance of such commands." | |
| (interactive) | |
| (save-match-data | |
| (let ((base-name (buffer-name))) | |
| (and (string-match "<[0-9]+>\\'" base-name) | |
| (not (and buffer-file-name | |
| (string= base-name | |
| (file-name-nondirectory buffer-file-name)))) | |
| ;; If the existing buffer name has a <NNN>, | |
| ;; which isn't part of the file name (if any), | |
| ;; then get rid of that. | |
| (setq base-name (substring base-name 0 (match-beginning 0)))) | |
| (rename-buffer (generate-new-buffer-name base-name)) | |
| (force-mode-line-update)))) | |
| (defun files--ensure-directory (dir) | |
| "Make directory DIR if it is not already a directory. Return nil." | |
| (condition-case err | |
| (make-directory-internal dir) | |
| (error | |
| (unless (file-directory-p dir) | |
| (signal (car err) (cdr err)))))) | |
| (defun make-directory (dir &optional parents) | |
| "Create the directory DIR and optionally any nonexistent parent dirs. | |
| If DIR already exists as a directory, signal an error, unless | |
| PARENTS is non-nil. | |
| Interactively, the default choice of directory to create is the | |
| current buffer's default directory. That is useful when you have | |
| visited a file in a nonexistent directory. | |
| Noninteractively, the second (optional) argument PARENTS, if | |
| non-nil, says whether to create parent directories that don't | |
| exist. Interactively, this happens by default. | |
| If creating the directory or directories fail, an error will be | |
| raised." | |
| (interactive | |
| (list (read-file-name "Make directory: " default-directory default-directory | |
| nil nil) | |
| t)) | |
| ;; If default-directory is a remote directory, | |
| ;; make sure we find its make-directory handler. | |
| (setq dir (expand-file-name dir)) | |
| (let ((handler (find-file-name-handler dir 'make-directory))) | |
| (if handler | |
| (funcall handler 'make-directory dir parents) | |
| (if (not parents) | |
| (make-directory-internal dir) | |
| (let ((dir (directory-file-name (expand-file-name dir))) | |
| create-list parent) | |
| (while (progn | |
| (setq parent (directory-file-name | |
| (file-name-directory dir))) | |
| (condition-case () | |
| (files--ensure-directory dir) | |
| (file-missing | |
| ;; Do not loop if root does not exist (Bug#2309). | |
| (not (string= dir parent))))) | |
| (setq create-list (cons dir create-list) | |
| dir parent)) | |
| (dolist (dir create-list) | |
| (files--ensure-directory dir))))))) | |
| (defun make-empty-file (filename &optional parents) | |
| "Create an empty file FILENAME. | |
| Optional arg PARENTS, if non-nil then creates parent dirs as needed. | |
| If called interactively, then PARENTS is non-nil." | |
| (interactive | |
| (let ((filename (read-file-name "Create empty file: "))) | |
| (list filename t))) | |
| (when (and (file-exists-p filename) (null parents)) | |
| (signal 'file-already-exists `("File exists" ,filename))) | |
| (let ((paren-dir (file-name-directory filename))) | |
| (when (and paren-dir (not (file-exists-p paren-dir))) | |
| (make-directory paren-dir parents))) | |
| (write-region "" nil filename nil 0)) | |
| (defconst directory-files-no-dot-files-regexp | |
| "^\\([^.]\\|\\.\\([^.]\\|\\..\\)\\).*" | |
| "Regexp matching any file name except \".\" and \"..\".") | |
| (defun files--force (no-such fn &rest args) | |
| "Use NO-SUCH to affect behavior of function FN applied to list ARGS. | |
| This acts like (apply FN ARGS) except it returns NO-SUCH if it is | |
| non-nil and if FN fails due to a missing file or directory." | |
| (condition-case err | |
| (apply fn args) | |
| (file-missing (or no-such (signal (car err) (cdr err)))))) | |
| (defun delete-directory (directory &optional recursive trash) | |
| "Delete the directory named DIRECTORY. Does not follow symlinks. | |
| If RECURSIVE is non-nil, delete files in DIRECTORY as well, with | |
| no error if something else is simultaneously deleting them. | |
| TRASH non-nil means to trash the directory instead, provided | |
| `delete-by-moving-to-trash' is non-nil. | |
| When called interactively, TRASH is nil if and only if a prefix | |
| argument is given, and a further prompt asks the user for | |
| RECURSIVE if DIRECTORY is nonempty." | |
| (interactive | |
| (let* ((trashing (and delete-by-moving-to-trash | |
| (null current-prefix-arg))) | |
| (dir (expand-file-name | |
| (read-directory-name | |
| (if trashing | |
| "Move directory to trash: " | |
| "Delete directory: ") | |
| default-directory default-directory nil nil)))) | |
| (list dir | |
| (if (directory-files dir nil directory-files-no-dot-files-regexp) | |
| (y-or-n-p | |
| (format-message "Directory `%s' is not empty, really %s? " | |
| dir (if trashing "trash" "delete"))) | |
| nil) | |
| (null current-prefix-arg)))) | |
| ;; If default-directory is a remote directory, make sure we find its | |
| ;; delete-directory handler. | |
| (setq directory (directory-file-name (expand-file-name directory))) | |
| (let ((handler (find-file-name-handler directory 'delete-directory))) | |
| (cond | |
| (handler | |
| (funcall handler 'delete-directory directory recursive trash)) | |
| ((and delete-by-moving-to-trash trash) | |
| ;; Move non-empty dir to trash only if recursive deletion was | |
| ;; requested. This mimics the non-`delete-by-moving-to-trash' | |
| ;; case, where the operation fails in delete-directory-internal. | |
| ;; As `move-file-to-trash' trashes directories (empty or | |
| ;; otherwise) as a unit, we do not need to recurse here. | |
| (if (and (not recursive) | |
| ;; Check if directory is empty apart from "." and "..". | |
| (directory-files | |
| directory 'full directory-files-no-dot-files-regexp)) | |
| (error "Directory is not empty, not moving to trash") | |
| (move-file-to-trash directory))) | |
| ;; Otherwise, call ourselves recursively if needed. | |
| (t | |
| (when (or (not recursive) (file-symlink-p directory) | |
| (let* ((files | |
| (files--force t #'directory-files directory 'full | |
| directory-files-no-dot-files-regexp)) | |
| (directory-exists (listp files))) | |
| (when directory-exists | |
| (mapc (lambda (file) | |
| ;; This test is equivalent to but more efficient | |
| ;; than (and (file-directory-p fn) | |
| ;; (not (file-symlink-p fn))). | |
| (if (eq t (car (file-attributes file))) | |
| (delete-directory file recursive) | |
| (files--force t #'delete-file file))) | |
| files)) | |
| directory-exists)) | |
| (files--force recursive #'delete-directory-internal directory)))))) | |
| (defun file-equal-p (file1 file2) | |
| "Return non-nil if files FILE1 and FILE2 name the same file. | |
| If FILE1 or FILE2 does not exist, the return value is unspecified." | |
| (let ((handler (or (find-file-name-handler file1 'file-equal-p) | |
| (find-file-name-handler file2 'file-equal-p)))) | |
| (if handler | |
| (funcall handler 'file-equal-p file1 file2) | |
| (let (f1-attr f2-attr) | |
| (and (setq f1-attr (file-attributes (file-truename file1))) | |
| (setq f2-attr (file-attributes (file-truename file2))) | |
| (equal f1-attr f2-attr)))))) | |
| (defun file-in-directory-p (file dir) | |
| "Return non-nil if FILE is in DIR or a subdirectory of DIR. | |
| A directory is considered to be \"in\" itself. | |
| Return nil if DIR is not an existing directory." | |
| (let ((handler (or (find-file-name-handler file 'file-in-directory-p) | |
| (find-file-name-handler dir 'file-in-directory-p)))) | |
| (if handler | |
| (funcall handler 'file-in-directory-p file dir) | |
| (when (file-directory-p dir) ; DIR must exist. | |
| (setq file (file-truename file) | |
| dir (file-truename dir)) | |
| (let ((ls1 (split-string file "/" t)) | |
| (ls2 (split-string dir "/" t)) | |
| (root | |
| (cond | |
| ;; A UNC on Windows systems, or a "super-root" on Apollo. | |
| ((string-match "\\`//" file) "//") | |
| ((string-match "\\`/" file) "/") | |
| (t ""))) | |
| (mismatch nil)) | |
| (while (and ls1 ls2 (not mismatch)) | |
| (if (string-equal (car ls1) (car ls2)) | |
| (setq root (concat root (car ls1) "/")) | |
| (setq mismatch t)) | |
| (setq ls1 (cdr ls1) | |
| ls2 (cdr ls2))) | |
| (unless mismatch | |
| (file-equal-p root dir))))))) | |
| (defun copy-directory (directory newname &optional keep-time parents copy-contents) | |
| "Copy DIRECTORY to NEWNAME. Both args must be strings. | |
| This function always sets the file modes of the output files to match | |
| the corresponding input file. | |
| The third arg KEEP-TIME non-nil means give the output files the same | |
| last-modified time as the old ones. (This works on only some systems.) | |
| A prefix arg makes KEEP-TIME non-nil. | |
| Noninteractively, the last argument PARENTS says whether to | |
| create parent directories if they don't exist. Interactively, | |
| this happens by default. | |
| If NEWNAME is a directory name, copy DIRECTORY as a subdirectory | |
| there. However, if called from Lisp with a non-nil optional | |
| argument COPY-CONTENTS, copy the contents of DIRECTORY directly | |
| into NEWNAME instead." | |
| (interactive | |
| (let ((dir (read-directory-name | |
| "Copy directory: " default-directory default-directory t nil))) | |
| (list dir | |
| (read-directory-name | |
| (format "Copy directory %s to: " dir) | |
| default-directory default-directory nil nil) | |
| current-prefix-arg t nil))) | |
| (when (file-in-directory-p newname directory) | |
| (error "Cannot copy `%s' into its subdirectory `%s'" | |
| directory newname)) | |
| ;; If default-directory is a remote directory, make sure we find its | |
| ;; copy-directory handler. | |
| (let ((handler (or (find-file-name-handler directory 'copy-directory) | |
| (find-file-name-handler newname 'copy-directory))) | |
| (follow parents)) | |
| (if handler | |
| (funcall handler 'copy-directory directory | |
| newname keep-time parents copy-contents) | |
| ;; Compute target name. | |
| (setq directory (directory-file-name (expand-file-name directory)) | |
| newname (expand-file-name newname)) | |
| (cond ((not (directory-name-p newname)) | |
| ;; If NEWNAME is not a directory name, create it; | |
| ;; that is where we will copy the files of DIRECTORY. | |
| (make-directory newname parents)) | |
| ;; NEWNAME is a directory name. If COPY-CONTENTS is non-nil, | |
| ;; create NEWNAME if it is not already a directory; | |
| ;; otherwise, create NEWNAME/[DIRECTORY-BASENAME]. | |
| ((if copy-contents | |
| (or parents (not (file-directory-p newname))) | |
| (setq newname (concat newname | |
| (file-name-nondirectory directory)))) | |
| (make-directory (directory-file-name newname) parents)) | |
| (t (setq follow t))) | |
| ;; Copy recursively. | |
| (dolist (file | |
| ;; We do not want to copy "." and "..". | |
| (directory-files directory 'full | |
| directory-files-no-dot-files-regexp)) | |
| (let ((target (concat (file-name-as-directory newname) | |
| (file-name-nondirectory file))) | |
| (filetype (car (file-attributes file)))) | |
| (cond | |
| ((eq filetype t) ; Directory but not a symlink. | |
| (copy-directory file target keep-time parents t)) | |
| ((stringp filetype) ; Symbolic link | |
| (make-symbolic-link filetype target t)) | |
| ((copy-file file target t keep-time))))) | |
| ;; Set directory attributes. | |
| (let ((modes (file-modes directory)) | |
| (times (and keep-time (file-attribute-modification-time | |
| (file-attributes directory)))) | |
| (follow-flag (unless follow 'nofollow))) | |
| (if modes (set-file-modes newname modes follow-flag)) | |
| (if times (set-file-times newname times follow-flag)))))) | |
| ;; At time of writing, only info uses this. | |
| (defun prune-directory-list (dirs &optional keep reject) | |
| "Return a copy of DIRS with all non-existent directories removed. | |
| The optional argument KEEP is a list of directories to retain even if | |
| they don't exist, and REJECT is a list of directories to remove from | |
| DIRS, even if they exist; REJECT takes precedence over KEEP. | |
| Note that membership in REJECT and KEEP is checked using simple string | |
| comparison." | |
| (apply #'nconc | |
| (mapcar (lambda (dir) | |
| (and (not (member dir reject)) | |
| (or (member dir keep) (file-directory-p dir)) | |
| (list dir))) | |
| dirs))) | |
| (put 'revert-buffer-function 'permanent-local t) | |
| (defvar revert-buffer-function #'revert-buffer--default | |
| "Function to use to revert this buffer. | |
| The function receives two arguments IGNORE-AUTO and NOCONFIRM, | |
| which are the arguments that `revert-buffer' received. | |
| It also has access to the `preserve-modes' argument of `revert-buffer' | |
| via the `revert-buffer-preserve-modes' dynamic variable. | |
| For historical reasons, a value of nil means to use the default function. | |
| This should not be relied upon.") | |
| (put 'revert-buffer-insert-file-contents-function 'permanent-local t) | |
| (defvar revert-buffer-insert-file-contents-function | |
| #'revert-buffer-insert-file-contents--default-function | |
| "Function to use to insert contents when reverting this buffer. | |
| The function receives two arguments: the first the nominal file name to use; | |
| the second is t if reading the auto-save file. | |
| The function is responsible for updating (or preserving) point. | |
| For historical reasons, a value of nil means to use the default function. | |
| This should not be relied upon.") | |
| (defun buffer-stale--default-function (&optional _noconfirm) | |
| "Default function to use for `buffer-stale-function'. | |
| This function ignores its argument. | |
| This returns non-nil if the current buffer is visiting a readable file | |
| whose modification time does not match that of the buffer. | |
| This function handles only buffers that are visiting files. | |
| Non-file buffers need a custom function." | |
| (and buffer-file-name | |
| (file-readable-p buffer-file-name) | |
| (not (buffer-modified-p (current-buffer))) | |
| (not (verify-visited-file-modtime (current-buffer))))) | |
| (defvar buffer-stale-function #'buffer-stale--default-function | |
| "Function to check whether a buffer needs reverting. | |
| This should be a function with one optional argument NOCONFIRM. | |
| Auto Revert Mode passes t for NOCONFIRM. The function should return | |
| non-nil if the buffer should be reverted. A return value of | |
| `fast' means that the need for reverting was not checked, but | |
| that reverting the buffer is fast. The buffer is current when | |
| this function is called. | |
| The idea behind the NOCONFIRM argument is that it should be | |
| non-nil if the buffer is going to be reverted without asking the | |
| user. In such situations, one has to be careful with potentially | |
| time consuming operations. | |
| For historical reasons, a value of nil means to use the default function. | |
| This should not be relied upon. | |
| For more information on how this variable is used by Auto Revert mode, | |
| see Info node `(emacs)Supporting additional buffers'.") | |
| (defvar-local buffer-auto-revert-by-notification nil | |
| "Whether a buffer can rely on notification in Auto-Revert mode. | |
| If non-nil, monitoring changes to the directory of the current | |
| buffer is sufficient for knowing when that buffer needs to be | |
| updated in Auto Revert Mode. Such notification does not include | |
| changes to files in that directory, only to the directory itself. | |
| This variable applies only to buffers where `buffer-file-name' is | |
| nil; other buffers are tracked by their files.") | |
| (defvar before-revert-hook nil | |
| "Normal hook for `revert-buffer' to run before reverting. | |
| The function `revert-buffer--default' runs this. | |
| A customized `revert-buffer-function' need not run this hook.") | |
| (defvar after-revert-hook nil | |
| "Normal hook for `revert-buffer' to run after reverting. | |
| Note that the hook value that it runs is the value that was in effect | |
| before reverting; that makes a difference if you have buffer-local | |
| hook functions. | |
| The function `revert-buffer--default' runs this. | |
| A customized `revert-buffer-function' need not run this hook.") | |
| (defvar revert-buffer-in-progress-p nil | |
| "Non-nil if a `revert-buffer' operation is in progress, nil otherwise.") | |
| (defvar revert-buffer-internal-hook) | |
| ;; `revert-buffer-function' was defined long ago to be a function of only | |
| ;; 2 arguments, so we have to use a dynbind variable to pass the | |
| ;; `preserve-modes' argument of `revert-buffer'. | |
| (defvar revert-buffer-preserve-modes) | |
| (defun revert-buffer (&optional ignore-auto noconfirm preserve-modes) | |
| "Replace current buffer text with the text of the visited file on disk. | |
| This undoes all changes since the file was visited or saved. | |
| With a prefix argument, offer to revert from latest auto-save file, if | |
| that is more recent than the visited file. | |
| This command also implements an interface for special buffers | |
| that contain text that doesn't come from a file, but reflects | |
| some other data instead (e.g. Dired buffers, `buffer-list' | |
| buffers). This is done via the variable `revert-buffer-function'. | |
| In these cases, it should reconstruct the buffer contents from the | |
| appropriate data. | |
| When called from Lisp, the first argument is IGNORE-AUTO; offer to | |
| revert from the auto-save file only when this is nil. Note that the | |
| sense of this argument is the reverse of the prefix argument, for the | |
| sake of backward compatibility. IGNORE-AUTO is optional, defaulting | |
| to nil. | |
| Optional second argument NOCONFIRM means don't ask for confirmation | |
| at all. (The variable `revert-without-query' offers another way to | |
| revert buffers without querying for confirmation.) | |
| Optional third argument PRESERVE-MODES non-nil means don't alter | |
| the files modes. Normally we reinitialize them using `normal-mode'. | |
| This function binds `revert-buffer-in-progress-p' non-nil while it operates. | |
| This function calls the function that `revert-buffer-function' specifies | |
| to do the work, with arguments IGNORE-AUTO and NOCONFIRM. | |
| The default function runs the hooks `before-revert-hook' and | |
| `after-revert-hook'." | |
| ;; I admit it's odd to reverse the sense of the prefix argument, but | |
| ;; there is a lot of code out there that assumes that the first | |
| ;; argument should be t to avoid consulting the auto-save file, and | |
| ;; there's no straightforward way to encourage authors to notice a | |
| ;; reversal of the argument sense. So I'm just changing the user | |
| ;; interface, but leaving the programmatic interface the same. | |
| (interactive (list (not current-prefix-arg))) | |
| (let ((revert-buffer-in-progress-p t) | |
| (revert-buffer-preserve-modes preserve-modes)) | |
| (funcall (or revert-buffer-function #'revert-buffer--default) | |
| ignore-auto noconfirm))) | |
| (defun revert-buffer--default (ignore-auto noconfirm) | |
| "Default function for `revert-buffer'. | |
| The arguments IGNORE-AUTO and NOCONFIRM are as described for `revert-buffer'. | |
| Runs the hooks `before-revert-hook' and `after-revert-hook' at the | |
| start and end. | |
| Calls `revert-buffer-insert-file-contents-function' to reread the | |
| contents of the visited file, with two arguments: the first is the file | |
| name, the second is non-nil if reading an auto-save file. | |
| This function handles only buffers that are visiting files. | |
| Non-file buffers need a custom function." | |
| (with-current-buffer (or (buffer-base-buffer (current-buffer)) | |
| (current-buffer)) | |
| (let* ((auto-save-p (and (not ignore-auto) | |
| (recent-auto-save-p) | |
| buffer-auto-save-file-name | |
| (file-readable-p buffer-auto-save-file-name) | |
| (y-or-n-p | |
| "Buffer has been auto-saved recently. Revert from auto-save file? "))) | |
| (file-name (if auto-save-p | |
| buffer-auto-save-file-name | |
| buffer-file-name))) | |
| (cond ((null file-name) | |
| (error "Buffer does not seem to be associated with any file")) | |
| ((or noconfirm | |
| (and (not (buffer-modified-p)) | |
| (catch 'found | |
| (dolist (regexp revert-without-query) | |
| (when (string-match regexp file-name) | |
| (throw 'found t))))) | |
| (yes-or-no-p (format "Revert buffer from file %s? " | |
| file-name))) | |
| (run-hooks 'before-revert-hook) | |
| ;; If file was backed up but has changed since, | |
| ;; we should make another backup. | |
| (and (not auto-save-p) | |
| (not (verify-visited-file-modtime (current-buffer))) | |
| (setq buffer-backed-up nil)) | |
| ;; Effectively copy the after-revert-hook status, | |
| ;; since after-find-file will clobber it. | |
| (let ((global-hook (default-value 'after-revert-hook)) | |
| (local-hook (when (local-variable-p 'after-revert-hook) | |
| after-revert-hook)) | |
| (inhibit-read-only t)) | |
| ;; FIXME: Throw away undo-log when preserve-modes is nil? | |
| (funcall | |
| (or revert-buffer-insert-file-contents-function | |
| #'revert-buffer-insert-file-contents--default-function) | |
| file-name auto-save-p) | |
| ;; Recompute the truename in case changes in symlinks | |
| ;; have changed the truename. | |
| (setq buffer-file-truename | |
| (abbreviate-file-name (file-truename buffer-file-name))) | |
| (after-find-file nil nil t nil revert-buffer-preserve-modes) | |
| ;; Run after-revert-hook as it was before we reverted. | |
| (setq-default revert-buffer-internal-hook global-hook) | |
| (if local-hook | |
| (set (make-local-variable 'revert-buffer-internal-hook) | |
| local-hook) | |
| (kill-local-variable 'revert-buffer-internal-hook)) | |
| (run-hooks 'revert-buffer-internal-hook)) | |
| t))))) | |
| (defun revert-buffer-insert-file-contents--default-function (file-name auto-save-p) | |
| "Default function for `revert-buffer-insert-file-contents-function'. | |
| The function `revert-buffer--default' calls this. | |
| FILE-NAME is the name of the file. AUTO-SAVE-P is non-nil if this is | |
| an auto-save file." | |
| (cond | |
| ((not (file-exists-p file-name)) | |
| (error (if buffer-file-number | |
| "File %s no longer exists!" | |
| "Cannot revert nonexistent file %s") | |
| file-name)) | |
| ((not (file-readable-p file-name)) | |
| (error (if buffer-file-number | |
| "File %s no longer readable!" | |
| "Cannot revert unreadable file %s") | |
| file-name)) | |
| (t | |
| ;; Bind buffer-file-name to nil | |
| ;; so that we don't try to lock the file. | |
| (let ((buffer-file-name nil)) | |
| (or auto-save-p | |
| (unlock-buffer))) | |
| (widen) | |
| (let ((coding-system-for-read | |
| ;; Auto-saved file should be read by Emacs's | |
| ;; internal coding. | |
| (if auto-save-p 'auto-save-coding | |
| (or coding-system-for-read | |
| (and | |
| buffer-file-coding-system-explicit | |
| (car buffer-file-coding-system-explicit)))))) | |
| (if (and (not enable-multibyte-characters) | |
| coding-system-for-read | |
| (not (memq (coding-system-base | |
| coding-system-for-read) | |
| '(no-conversion raw-text)))) | |
| ;; As a coding system suitable for multibyte | |
| ;; buffer is specified, make the current | |
| ;; buffer multibyte. | |
| (set-buffer-multibyte t)) | |
| ;; This force after-insert-file-set-coding | |
| ;; (called from insert-file-contents) to set | |
| ;; buffer-file-coding-system to a proper value. | |
| (kill-local-variable 'buffer-file-coding-system) | |
| ;; Note that this preserves point in an intelligent way. | |
| (if revert-buffer-preserve-modes | |
| (let ((buffer-file-format buffer-file-format)) | |
| (insert-file-contents file-name (not auto-save-p) | |
| nil nil t)) | |
| (insert-file-contents file-name (not auto-save-p) | |
| nil nil t)))))) | |
| (defun recover-this-file () | |
| "Recover the visited file--get contents from its last auto-save file." | |
| (interactive) | |
| (or buffer-file-name | |
| (user-error "This buffer is not visiting a file")) | |
| (recover-file buffer-file-name)) | |
| (defun recover-file (file) | |
| "Visit file FILE, but get contents from its last auto-save file." | |
| ;; Actually putting the file name in the minibuffer should be used | |
| ;; only rarely. | |
| ;; Not just because users often use the default. | |
| (interactive "FRecover file: ") | |
| (setq file (expand-file-name file)) | |
| (if (auto-save-file-name-p (file-name-nondirectory file)) | |
| (user-error "%s is an auto-save file" (abbreviate-file-name file))) | |
| (let ((file-name (let ((buffer-file-name file)) | |
| (make-auto-save-file-name)))) | |
| (cond ((and (file-exists-p file) | |
| (not (file-exists-p file-name))) | |
| (error "Auto save file %s does not exist" | |
| (abbreviate-file-name file-name))) | |
| ((if (file-exists-p file) | |
| (not (file-newer-than-file-p file-name file)) | |
| (not (file-exists-p file-name))) | |
| (user-error "Auto-save file %s not current" | |
| (abbreviate-file-name file-name))) | |
| ((with-temp-buffer-window | |
| "*Directory*" nil | |
| #'(lambda (window _value) | |
| (with-selected-window window | |
| (unwind-protect | |
| (yes-or-no-p (format "Recover auto save file %s? " file-name)) | |
| (when (window-live-p window) | |
| (quit-restore-window window 'kill))))) | |
| (with-current-buffer standard-output | |
| (let ((switches dired-listing-switches)) | |
| (if (file-symlink-p file) | |
| (setq switches (concat switches " -L"))) | |
| ;; Use insert-directory-safely, not insert-directory, | |
| ;; because these files might not exist. In particular, | |
| ;; FILE might not exist if the auto-save file was for | |
| ;; a buffer that didn't visit a file, such as "*mail*". | |
| ;; The code in v20.x called `ls' directly, so we need | |
| ;; to emulate what `ls' did in that case. | |
| (insert-directory-safely file switches) | |
| (insert-directory-safely file-name switches)))) | |
| (switch-to-buffer (find-file-noselect file t)) | |
| (let ((inhibit-read-only t) | |
| ;; Keep the current buffer-file-coding-system. | |
| (coding-system buffer-file-coding-system) | |
| ;; Auto-saved file should be read with special coding. | |
| (coding-system-for-read 'auto-save-coding)) | |
| (erase-buffer) | |
| (insert-file-contents file-name nil) | |
| (set-buffer-file-coding-system coding-system)) | |
| (after-find-file nil nil t)) | |
| (t (user-error "Recover-file canceled"))))) | |
| (defvar dired-mode-hook) | |
| (defun recover-session () | |
| "Recover auto save files from a previous Emacs session. | |
| This command first displays a Dired buffer showing you the | |
| previous sessions that you could recover from. | |
| To choose one, move point to the proper line and then type C-c C-c. | |
| Then you'll be asked about a number of files to recover." | |
| (interactive) | |
| (if (null auto-save-list-file-prefix) | |
| (error "You set `auto-save-list-file-prefix' to disable making session files")) | |
| (let ((dir (file-name-directory auto-save-list-file-prefix)) | |
| (nd (file-name-nondirectory auto-save-list-file-prefix))) | |
| (unless (file-directory-p dir) | |
| (make-directory dir t)) | |
| (unless (directory-files dir nil | |
| (if (string= "" nd) | |
| directory-files-no-dot-files-regexp | |
| (concat "\\`" (regexp-quote nd))) | |
| t) | |
| (error "No previous sessions to recover"))) | |
| (require 'dired) | |
| (let ((ls-lisp-support-shell-wildcards t) | |
| ;; Ensure that we don't omit the session files as the user may | |
| ;; have (as suggested by the manual) `dired-omit-mode' in the | |
| ;; hook. | |
| (dired-mode-hook (delete 'dired-omit-mode dired-mode-hook))) | |
| (dired (concat auto-save-list-file-prefix "*") | |
| (concat dired-listing-switches " -t"))) | |
| (use-local-map (nconc (make-sparse-keymap) (current-local-map))) | |
| (define-key (current-local-map) "\C-c\C-c" 'recover-session-finish) | |
| (save-excursion | |
| (goto-char (point-min)) | |
| (or (looking-at " Move to the session you want to recover,") | |
| (let ((inhibit-read-only t)) | |
| ;; Each line starts with a space | |
| ;; so that Font Lock mode won't highlight the first character. | |
| (insert " To recover a session, move to it and type C-c C-c.\n" | |
| (substitute-command-keys | |
| " To delete a session file, type \ | |
| \\[dired-flag-file-deletion] on its line to flag | |
| the file for deletion, then \\[dired-do-flagged-delete] to \ | |
| delete flagged files.\n\n")))))) | |
| (defun recover-session-finish () | |
| "Choose one saved session to recover auto-save files from. | |
| This command is used in the special Dired buffer created by | |
| \\[recover-session]." | |
| (interactive) | |
| ;; Get the name of the session file to recover from. | |
| (let ((file (dired-get-filename)) | |
| files | |
| (buffer (get-buffer-create " *recover*"))) | |
| (dired-unmark 1) | |
| (dired-do-flagged-delete t) | |
| (unwind-protect | |
| (with-current-buffer buffer | |
| ;; Read in the auto-save-list file. | |
| (erase-buffer) | |
| (insert-file-contents file) | |
| ;; Loop thru the text of that file | |
| ;; and get out the names of the files to recover. | |
| (while (not (eobp)) | |
| (let (thisfile autofile) | |
| (if (eolp) | |
| ;; This is a pair of lines for a non-file-visiting buffer. | |
| ;; Get the auto-save file name and manufacture | |
| ;; a "visited file name" from that. | |
| (progn | |
| (forward-line 1) | |
| ;; If there is no auto-save file name, the | |
| ;; auto-save-list file is probably corrupted. | |
| (unless (eolp) | |
| (setq autofile | |
| (buffer-substring-no-properties | |
| (point) | |
| (line-end-position))) | |
| (setq thisfile | |
| (expand-file-name | |
| (substring | |
| (file-name-nondirectory autofile) | |
| 1 -1) | |
| (file-name-directory autofile)))) | |
| (forward-line 1)) | |
| ;; This pair of lines is a file-visiting | |
| ;; buffer. Use the visited file name. | |
| (progn | |
| (setq thisfile | |
| (buffer-substring-no-properties | |
| (point) (progn (end-of-line) (point)))) | |
| (forward-line 1) | |
| (setq autofile | |
| (buffer-substring-no-properties | |
| (point) (progn (end-of-line) (point)))) | |
| (forward-line 1))) | |
| ;; Ignore a file if its auto-save file does not exist now. | |
| (if (and autofile (file-exists-p autofile)) | |
| (setq files (cons thisfile files))))) | |
| (setq files (nreverse files)) | |
| ;; The file contains a pair of line for each auto-saved buffer. | |
| ;; The first line of the pair contains the visited file name | |
| ;; or is empty if the buffer was not visiting a file. | |
| ;; The second line is the auto-save file name. | |
| (if files | |
| (map-y-or-n-p "Recover %s? " | |
| (lambda (file) | |
| (condition-case nil | |
| (save-excursion (recover-file file)) | |
| (error | |
| "Failed to recover `%s'" file))) | |
| files | |
| '("file" "files" "recover")) | |
| (message "No files can be recovered from this session now"))) | |
| (kill-buffer buffer)))) | |
| (defun kill-buffer-ask (buffer) | |
| "Kill BUFFER if confirmed." | |
| (when (yes-or-no-p (format "Buffer %s %s. Kill? " | |
| (buffer-name buffer) | |
| (if (buffer-modified-p buffer) | |
| "HAS BEEN EDITED" "is unmodified"))) | |
| (kill-buffer buffer))) | |
| (defun kill-some-buffers (&optional list) | |
| "Kill some buffers. Asks the user whether to kill each one of them. | |
| Non-interactively, if optional argument LIST is non-nil, it | |
| specifies the list of buffers to kill, asking for approval for each one." | |
| (interactive) | |
| (if (null list) | |
| (setq list (buffer-list))) | |
| (while list | |
| (let* ((buffer (car list)) | |
| (name (buffer-name buffer))) | |
| (and name ; Can be nil for an indirect buffer | |
| ; if we killed the base buffer. | |
| (not (string-equal name "")) | |
| (/= (aref name 0) ?\s) | |
| (kill-buffer-ask buffer))) | |
| (setq list (cdr list)))) | |
| (defun kill-matching-buffers (regexp &optional internal-too no-ask) | |
| "Kill buffers whose name matches the specified REGEXP. | |
| Ignores buffers whose name starts with a space, unless optional | |
| prefix argument INTERNAL-TOO is non-nil. Asks before killing | |
| each buffer, unless NO-ASK is non-nil." | |
| (interactive "sKill buffers matching this regular expression: \nP") | |
| (dolist (buffer (buffer-list)) | |
| (let ((name (buffer-name buffer))) | |
| (when (and name (not (string-equal name "")) | |
| (or internal-too (/= (aref name 0) ?\s)) | |
| (string-match regexp name)) | |
| (funcall (if no-ask 'kill-buffer 'kill-buffer-ask) buffer))))) | |
| (defun rename-auto-save-file () | |
| "Adjust current buffer's auto save file name for current conditions. | |
| Also rename any existing auto save file, if it was made in this session." | |
| (let ((osave buffer-auto-save-file-name)) | |
| (setq buffer-auto-save-file-name | |
| (make-auto-save-file-name)) | |
| (if (and osave buffer-auto-save-file-name | |
| (not (string= buffer-auto-save-file-name buffer-file-name)) | |
| (not (string= buffer-auto-save-file-name osave)) | |
| (file-exists-p osave) | |
| (recent-auto-save-p)) | |
| (rename-file osave buffer-auto-save-file-name t)))) | |
| (defun make-auto-save-file-name () | |
| "Return file name to use for auto-saves of current buffer. | |
| Does not consider `auto-save-visited-file-name' as that variable is checked | |
| before calling this function. You can redefine this for customization. | |
| See also `auto-save-file-name-p'." | |
| (if buffer-file-name | |
| (let ((handler (find-file-name-handler buffer-file-name | |
| 'make-auto-save-file-name))) | |
| (if handler | |
| (funcall handler 'make-auto-save-file-name) | |
| (let ((list auto-save-file-name-transforms) | |
| (filename buffer-file-name) | |
| result uniq) | |
| ;; Apply user-specified translations | |
| ;; to the file name. | |
| (while (and list (not result)) | |
| (if (string-match (car (car list)) filename) | |
| (setq result (replace-match (cadr (car list)) t nil | |
| filename) | |
| uniq (car (cddr (car list))))) | |
| (setq list (cdr list))) | |
| (if result | |
| (if uniq | |
| (setq filename (concat | |
| (file-name-directory result) | |
| (subst-char-in-string | |
| ?/ ?! | |
| (replace-regexp-in-string "!" "!!" | |
| filename)))) | |
| (setq filename result))) | |
| (setq result | |
| (if (and (eq system-type 'ms-dos) | |
| (not (msdos-long-file-names))) | |
| ;; We truncate the file name to DOS 8+3 limits | |
| ;; before doing anything else, because the regexp | |
| ;; passed to string-match below cannot handle | |
| ;; extensions longer than 3 characters, multiple | |
| ;; dots, and other atrocities. | |
| (let ((fn (dos-8+3-filename | |
| (file-name-nondirectory buffer-file-name)))) | |
| (string-match | |
| "\\`\\([^.]+\\)\\(\\.\\(..?\\)?.?\\|\\)\\'" | |
| fn) | |
| (concat (file-name-directory buffer-file-name) | |
| "#" (match-string 1 fn) | |
| "." (match-string 3 fn) "#")) | |
| (concat (file-name-directory filename) | |
| "#" | |
| (file-name-nondirectory filename) | |
| "#"))) | |
| ;; Make sure auto-save file names don't contain characters | |
| ;; invalid for the underlying filesystem. | |
| (if (and (memq system-type '(ms-dos windows-nt cygwin)) | |
| ;; Don't modify remote filenames | |
| (not (file-remote-p result))) | |
| (convert-standard-filename result) | |
| result)))) | |
| ;; Deal with buffers that don't have any associated files. (Mail | |
| ;; mode tends to create a good number of these.) | |
| (let ((buffer-name (buffer-name)) | |
| (limit 0) | |
| file-name) | |
| ;; Restrict the characters used in the file name to those that | |
| ;; are known to be safe on all filesystems, url-encoding the | |
| ;; rest. | |
| ;; We do this on all platforms, because even if we are not | |
| ;; running on DOS/Windows, the current directory may be on a | |
| ;; mounted VFAT filesystem, such as a USB memory stick. | |
| (while (string-match "[^A-Za-z0-9_.~#+-]" buffer-name limit) | |
| (let* ((character (aref buffer-name (match-beginning 0))) | |
| (replacement | |
| ;; For multibyte characters, this will produce more than | |
| ;; 2 hex digits, so is not true URL encoding. | |
| (format "%%%02X" character))) | |
| (setq buffer-name (replace-match replacement t t buffer-name)) | |
| (setq limit (1+ (match-end 0))))) | |
| ;; Generate the file name. | |
| (setq file-name | |
| (make-temp-file | |
| (let ((fname | |
| (expand-file-name | |
| (format "#%s#" buffer-name) | |
| ;; Try a few alternative directories, to get one we can | |
| ;; write it. | |
| (cond | |
| ((file-writable-p default-directory) default-directory) | |
| ((file-writable-p "/var/tmp/") "/var/tmp/") | |
| ("~/"))))) | |
| (if (and (memq system-type '(ms-dos windows-nt cygwin)) | |
| ;; Don't modify remote filenames | |
| (not (file-remote-p fname))) | |
| ;; The call to convert-standard-filename is in case | |
| ;; buffer-name includes characters not allowed by the | |
| ;; DOS/Windows filesystems. make-temp-file writes to the | |
| ;; file it creates, so we must fix the file name _before_ | |
| ;; make-temp-file is called. | |
| (convert-standard-filename fname) | |
| fname)) | |
| nil "#")) | |
| ;; make-temp-file creates the file, | |
| ;; but we don't want it to exist until we do an auto-save. | |
| (condition-case () | |
| (delete-file file-name) | |
| (file-error nil)) | |
| file-name))) | |
| (defun auto-save-file-name-p (filename) | |
| "Return non-nil if FILENAME can be yielded by `make-auto-save-file-name'. | |
| FILENAME should lack slashes. You can redefine this for customization." | |
| (string-match "\\`#.*#\\'" filename)) | |
| (defun wildcard-to-regexp (wildcard) | |
| "Given a shell file name pattern WILDCARD, return an equivalent regexp. | |
| The generated regexp will match a filename only if the filename | |
| matches that wildcard according to shell rules. Only wildcards known | |
| by `sh' are supported." | |
| (let* ((i (string-match "[[.*+\\^$?]" wildcard)) | |
| ;; Copy the initial run of non-special characters. | |
| (result (substring wildcard 0 i)) | |
| (len (length wildcard))) | |
| ;; If no special characters, we're almost done. | |
| (if i | |
| (while (< i len) | |
| (let ((ch (aref wildcard i)) | |
| j) | |
| (setq | |
| result | |
| (concat result | |
| (cond | |
| ((and (eq ch ?\[) | |
| (< (1+ i) len) | |
| (eq (aref wildcard (1+ i)) ?\])) | |
| "\\[") | |
| ((eq ch ?\[) ; [...] maps to regexp char class | |
| (progn | |
| (setq i (1+ i)) | |
| (concat | |
| (cond | |
| ((eq (aref wildcard i) ?!) ; [!...] -> [^...] | |
| (progn | |
| (setq i (1+ i)) | |
| (if (eq (aref wildcard i) ?\]) | |
| (progn | |
| (setq i (1+ i)) | |
| "[^]") | |
| "[^"))) | |
| ((eq (aref wildcard i) ?^) | |
| ;; Found "[^". Insert a `\0' character | |
| ;; (which cannot happen in a filename) | |
| ;; into the character class, so that `^' | |
| ;; is not the first character after `[', | |
| ;; and thus non-special in a regexp. | |
| (progn | |
| (setq i (1+ i)) | |
| "[\000^")) | |
| ((eq (aref wildcard i) ?\]) | |
| ;; I don't think `]' can appear in a | |
| ;; character class in a wildcard, but | |
| ;; let's be general here. | |
| (progn | |
| (setq i (1+ i)) | |
| "[]")) | |
| (t "[")) | |
| (prog1 ; copy everything upto next `]'. | |
| (substring wildcard | |
| i | |
| (setq j (string-match | |
| "]" wildcard i))) | |
| (setq i (if j (1- j) (1- len))))))) | |
| ((eq ch ?.) "\\.") | |
| ((eq ch ?*) "[^\000]*") | |
| ((eq ch ?+) "\\+") | |
| ((eq ch ?^) "\\^") | |
| ((eq ch ?$) "\\$") | |
| ((eq ch ?\\) "\\\\") ; probably cannot happen... | |
| ((eq ch ??) "[^\000]") | |
| (t (char-to-string ch))))) | |
| (setq i (1+ i))))) | |
| ;; Shell wildcards should match the entire filename, | |
| ;; not its part. Make the regexp say so. | |
| (concat "\\`" result "\\'"))) | |
| (defcustom list-directory-brief-switches | |
| (purecopy "-CF") | |
| "Switches for `list-directory' to pass to `ls' for brief listing." | |
| :type 'string | |
| :group 'dired) | |
| (defcustom list-directory-verbose-switches | |
| (purecopy "-l") | |
| "Switches for `list-directory' to pass to `ls' for verbose listing." | |
| :type 'string | |
| :group 'dired) | |
| (defun file-expand-wildcards (pattern &optional full) | |
| "Expand wildcard pattern PATTERN. | |
| This returns a list of file names that match the pattern. | |
| Files are sorted in `string<' order. | |
| If PATTERN is written as an absolute file name, | |
| the values are absolute also. | |
| If PATTERN is written as a relative file name, it is interpreted | |
| relative to the current default directory, `default-directory'. | |
| The file names returned are normally also relative to the current | |
| default directory. However, if FULL is non-nil, they are absolute." | |
| (save-match-data | |
| (let* ((nondir (file-name-nondirectory pattern)) | |
| (dirpart (file-name-directory pattern)) | |
| ;; A list of all dirs that DIRPART specifies. | |
| ;; This can be more than one dir | |
| ;; if DIRPART contains wildcards. | |
| (dirs (if (and dirpart | |
| (string-match "[[*?]" (file-local-name dirpart))) | |
| (mapcar 'file-name-as-directory | |
| (file-expand-wildcards (directory-file-name dirpart))) | |
| (list dirpart))) | |
| contents) | |
| (dolist (dir dirs) | |
| (when (or (null dir) ; Possible if DIRPART is not wild. | |
| (file-accessible-directory-p dir)) | |
| (let ((this-dir-contents | |
| ;; Filter out "." and ".." | |
| (delq nil | |
| (mapcar #'(lambda (name) | |
| (unless (string-match "\\`\\.\\.?\\'" | |
| (file-name-nondirectory name)) | |
| name)) | |
| (directory-files (or dir ".") full | |
| (wildcard-to-regexp nondir)))))) | |
| (setq contents | |
| (nconc | |
| (if (and dir (not full)) | |
| (mapcar #'(lambda (name) (concat dir name)) | |
| this-dir-contents) | |
| this-dir-contents) | |
| contents))))) | |
| contents))) | |
| ;; Let Tramp know that `file-expand-wildcards' does not need an advice. | |
| (provide 'files '(remote-wildcards)) | |
| (defun list-directory (dirname &optional verbose) | |
| "Display a list of files in or matching DIRNAME, a la `ls'. | |
| DIRNAME is globbed by the shell if necessary. | |
| Prefix arg (second arg if noninteractive) means supply -l switch to `ls'. | |
| Actions controlled by variables `list-directory-brief-switches' | |
| and `list-directory-verbose-switches'." | |
| (interactive (let ((pfx current-prefix-arg)) | |
| (list (read-directory-name (if pfx "List directory (verbose): " | |
| "List directory (brief): ") | |
| nil default-directory nil) | |
| pfx))) | |
| (let ((switches (if verbose list-directory-verbose-switches | |
| list-directory-brief-switches)) | |
| buffer) | |
| (or dirname (setq dirname default-directory)) | |
| (setq dirname (expand-file-name dirname)) | |
| (with-output-to-temp-buffer "*Directory*" | |
| (setq buffer standard-output) | |
| (buffer-disable-undo standard-output) | |
| (princ "Directory ") | |
| (princ dirname) | |
| (terpri) | |
| (with-current-buffer "*Directory*" | |
| (let ((wildcard (not (file-directory-p dirname)))) | |
| (insert-directory dirname switches wildcard (not wildcard))))) | |
| ;; Finishing with-output-to-temp-buffer seems to clobber default-directory. | |
| (with-current-buffer buffer | |
| (setq default-directory | |
| (if (file-directory-p dirname) | |
| (file-name-as-directory dirname) | |
| (file-name-directory dirname)))))) | |
| (defun shell-quote-wildcard-pattern (pattern) | |
| "Quote characters special to the shell in PATTERN, leave wildcards alone. | |
| PATTERN is assumed to represent a file-name wildcard suitable for the | |
| underlying filesystem. For Unix and GNU/Linux, each character from the | |
| set [ \\t\\n;<>&|()\\=`\\='\"#$] is quoted with a backslash; for DOS/Windows, all | |
| the parts of the pattern that don't include wildcard characters are | |
| quoted with double quotes. | |
| This function leaves alone existing quote characters (\\ on Unix and \" | |
| on Windows), so PATTERN can use them to quote wildcard characters that | |
| need to be passed verbatim to shell commands." | |
| (save-match-data | |
| (cond | |
| ((memq system-type '(ms-dos windows-nt cygwin)) | |
| ;; DOS/Windows don't allow `"' in file names. So if the | |
| ;; argument has quotes, we can safely assume it is already | |
| ;; quoted by the caller. | |
| (if (or (string-match "[\"]" pattern) | |
| ;; We quote [&()#$`'] in case their shell is a port of a | |
| ;; Unixy shell. We quote [,=+] because stock DOS and | |
| ;; Windows shells require that in some cases, such as | |
| ;; passing arguments to batch files that use positional | |
| ;; arguments like %1. | |
| (not (string-match "[ \t;&()#$`',=+]" pattern))) | |
| pattern | |
| (let ((result "\"") | |
| (beg 0) | |
| end) | |
| (while (string-match "[*?]+" pattern beg) | |
| (setq end (match-beginning 0) | |
| result (concat result (substring pattern beg end) | |
| "\"" | |
| (substring pattern end (match-end 0)) | |
| "\"") | |
| beg (match-end 0))) | |
| (concat result (substring pattern beg) "\"")))) | |
| (t | |
| (let ((beg 0)) | |
| (while (string-match "[ \t\n;<>&|()`'\"#$]" pattern beg) | |
| (setq pattern | |
| (concat (substring pattern 0 (match-beginning 0)) | |
| "\\" | |
| (substring pattern (match-beginning 0))) | |
| beg (1+ (match-end 0))))) | |
| pattern)))) | |
| (defvar insert-directory-program (purecopy "ls") | |
| "Absolute or relative name of the `ls' program used by `insert-directory'.") | |
| (defcustom directory-free-space-program (purecopy "df") | |
| "Program to get the amount of free space on a file system. | |
| We assume the output has the format of `df'. | |
| The value of this variable must be just a command name or file name; | |
| if you want to specify options, use `directory-free-space-args'. | |
| A value of nil disables this feature. | |
| This variable is obsolete; Emacs no longer uses it." | |
| :type '(choice (string :tag "Program") (const :tag "None" nil)) | |
| :group 'dired) | |
| (make-obsolete-variable 'directory-free-space-program | |
| "ignored, as Emacs uses `file-system-info' instead" | |
| "27.1") | |
| (defcustom directory-free-space-args | |
| (purecopy (if (eq system-type 'darwin) "-k" "-Pk")) | |
| "Options to use when running `directory-free-space-program'." | |
| :type 'string | |
| :group 'dired) | |
| (make-obsolete-variable 'directory-free-space-args | |
| "ignored, as Emacs uses `file-system-info' instead" | |
| "27.1") | |
| (defun get-free-disk-space (dir) | |
| "String describing the amount of free space on DIR's file system. | |
| If DIR's free space cannot be obtained, this function returns nil." | |
| (save-match-data | |
| (let ((avail (nth 2 (file-system-info dir)))) | |
| (if avail | |
| (funcall byte-count-to-string-function avail))))) | |
| ;; The following expression replaces `dired-move-to-filename-regexp'. | |
| (defvar directory-listing-before-filename-regexp | |
| (let* ((l "\\([A-Za-z]\\|[^\0-\177]\\)") | |
| (l-or-quote "\\([A-Za-z']\\|[^\0-\177]\\)") | |
| ;; In some locales, month abbreviations are as short as 2 letters, | |
| ;; and they can be followed by ".". | |
| ;; In Breton, a month name can include a quote character. | |
| (month (concat l-or-quote l-or-quote "+\\.?")) | |
| (s " ") | |
| (yyyy "[0-9][0-9][0-9][0-9]") | |
| (dd "[ 0-3][0-9]") | |
| (HH:MM "[ 0-2][0-9][:.][0-5][0-9]") | |
| (seconds "[0-6][0-9]\\([.,][0-9]+\\)?") | |
| (zone "[-+][0-2][0-9][0-5][0-9]") | |
| (iso-mm-dd "[01][0-9]-[0-3][0-9]") | |
| (iso-time (concat HH:MM "\\(:" seconds "\\( ?" zone "\\)?\\)?")) | |
| (iso (concat "\\(\\(" yyyy "-\\)?" iso-mm-dd "[ T]" iso-time | |
| "\\|" yyyy "-" iso-mm-dd "\\)")) | |
| (western (concat "\\(" month s "+" dd "\\|" dd "\\.?" s month "\\)" | |
| s "+" | |
| "\\(" HH:MM "\\|" yyyy "\\)")) | |
| (western-comma (concat month s "+" dd "," s "+" yyyy)) | |
| ;; Japanese MS-Windows ls-lisp has one-digit months, and | |
| ;; omits the Kanji characters after month and day-of-month. | |
| ;; On Mac OS X 10.3, the date format in East Asian locales is | |
| ;; day-of-month digits followed by month digits. | |
| (mm "[ 0-1]?[0-9]") | |
| (east-asian | |
| (concat "\\(" mm l "?" s dd l "?" s "+" | |
| "\\|" dd s mm s "+" "\\)" | |
| "\\(" HH:MM "\\|" yyyy l "?" "\\)"))) | |
| ;; The "[0-9]" below requires the previous column to end in a digit. | |
| ;; This avoids recognizing `1 may 1997' as a date in the line: | |
| ;; -r--r--r-- 1 may 1997 1168 Oct 19 16:49 README | |
| ;; The "[BkKMGTPEZY]?" below supports "ls -alh" output. | |
| ;; For non-iso date formats, we add the ".*" in order to find | |
| ;; the last possible match. This avoids recognizing | |
| ;; `jservice 10 1024' as a date in the line: | |
| ;; drwxr-xr-x 3 jservice 10 1024 Jul 2 1997 esg-host | |
| ;; vc dired listings provide the state or blanks between file | |
| ;; permissions and date. The state is always surrounded by | |
| ;; parentheses: | |
| ;; -rw-r--r-- (modified) 2005-10-22 21:25 files.el | |
| ;; This is not supported yet. | |
| (purecopy (concat "\\([0-9][BkKMGTPEZY]? " iso | |
| "\\|.*[0-9][BkKMGTPEZY]? " | |
| "\\(" western "\\|" western-comma "\\|" east-asian "\\)" | |
| "\\) +"))) | |
| "Regular expression to match up to the file name in a directory listing. | |
| The default value is designed to recognize dates and times | |
| regardless of the language.") | |
| (defvar insert-directory-ls-version 'unknown) | |
| (defun insert-directory-wildcard-in-dir-p (dir) | |
| "Return non-nil if DIR contents a shell wildcard in the directory part. | |
| The return value is a cons (DIR . WILDCARDS); DIR is the | |
| `default-directory' in the Dired buffer, and WILDCARDS are the wildcards. | |
| Valid wildcards are `*', `?', `[abc]' and `[a-z]'." | |
| (let ((wildcards "[?*")) | |
| (when (and (or (not (featurep 'ls-lisp)) | |
| ls-lisp-support-shell-wildcards) | |
| (string-match (concat "[" wildcards "]") (file-name-directory dir)) | |
| (not (file-exists-p dir))) ; Prefer an existing file to wildcards. | |
| (let ((regexp (format "\\`\\([^%s]*/\\)\\([^%s]*[%s].*\\)" | |
| wildcards wildcards wildcards))) | |
| (string-match regexp dir) | |
| (cons (match-string 1 dir) (match-string 2 dir)))))) | |
| (defun insert-directory-clean (beg switches) | |
| (when (if (stringp switches) | |
| (string-match "--dired\\>" switches) | |
| (member "--dired" switches)) | |
| ;; The following overshoots by one line for an empty | |
| ;; directory listed with "--dired", but without "-a" | |
| ;; switch, where the ls output contains a | |
| ;; "//DIRED-OPTIONS//" line, but no "//DIRED//" line. | |
| ;; We take care of that case later. | |
| (forward-line -2) | |
| (when (looking-at "//SUBDIRED//") | |
| (delete-region (point) (progn (forward-line 1) (point))) | |
| (forward-line -1)) | |
| (if (looking-at "//DIRED//") | |
| (let ((end (line-end-position)) | |
| (linebeg (point)) | |
| error-lines) | |
| ;; Find all the lines that are error messages, | |
| ;; and record the bounds of each one. | |
| (goto-char beg) | |
| (while (< (point) linebeg) | |
| (or (eql (following-char) ?\s) | |
| (push (list (point) (line-end-position)) error-lines)) | |
| (forward-line 1)) | |
| (setq error-lines (nreverse error-lines)) | |
| ;; Now read the numeric positions of file names. | |
| (goto-char linebeg) | |
| (forward-word-strictly 1) | |
| (forward-char 3) | |
| (while (< (point) end) | |
| (let ((start (insert-directory-adj-pos | |
| (+ beg (read (current-buffer))) | |
| error-lines)) | |
| (end (insert-directory-adj-pos | |
| (+ beg (read (current-buffer))) | |
| error-lines))) | |
| (if (memq (char-after end) '(?\n ?\s)) | |
| ;; End is followed by \n or by " -> ". | |
| (put-text-property start end 'dired-filename t) | |
| ;; It seems that we can't trust ls's output as to | |
| ;; byte positions of filenames. | |
| (put-text-property beg (point) 'dired-filename nil) | |
| (end-of-line)))) | |
| (goto-char end) | |
| (beginning-of-line) | |
| (delete-region (point) (progn (forward-line 1) (point)))) | |
| ;; Take care of the case where the ls output contains a | |
| ;; "//DIRED-OPTIONS//"-line, but no "//DIRED//"-line | |
| ;; and we went one line too far back (see above). | |
| (forward-line 1)) | |
| (if (looking-at "//DIRED-OPTIONS//") | |
| (delete-region (point) (progn (forward-line 1) (point)))))) | |
| ;; insert-directory | |
| ;; - must insert _exactly_one_line_ describing FILE if WILDCARD and | |
| ;; FULL-DIRECTORY-P is nil. | |
| ;; The single line of output must display FILE's name as it was | |
| ;; given, namely, an absolute path name. | |
| ;; - must insert exactly one line for each file if WILDCARD or | |
| ;; FULL-DIRECTORY-P is t, plus one optional "total" line | |
| ;; before the file lines, plus optional text after the file lines. | |
| ;; Lines are delimited by "\n", so filenames containing "\n" are not | |
| ;; allowed. | |
| ;; File lines should display the basename. | |
| ;; - must be consistent with | |
| ;; - functions dired-move-to-filename, (these two define what a file line is) | |
| ;; dired-move-to-end-of-filename, | |
| ;; dired-between-files, (shortcut for (not (dired-move-to-filename))) | |
| ;; dired-insert-headerline | |
| ;; dired-after-subdir-garbage (defines what a "total" line is) | |
| ;; - variable dired-subdir-regexp | |
| ;; - may be passed "--dired" as the first argument in SWITCHES. | |
| ;; File name handlers might have to remove this switch if their | |
| ;; "ls" command does not support it. | |
| (defun insert-directory (file switches &optional wildcard full-directory-p) | |
| "Insert directory listing for FILE, formatted according to SWITCHES. | |
| Leaves point after the inserted text. | |
| SWITCHES may be a string of options, or a list of strings | |
| representing individual options. | |
| Optional third arg WILDCARD means treat FILE as shell wildcard. | |
| Optional fourth arg FULL-DIRECTORY-P means file is a directory and | |
| switches do not contain `d', so that a full listing is expected. | |
| This works by running a directory listing program | |
| whose name is in the variable `insert-directory-program'. | |
| If WILDCARD, it also runs the shell specified by `shell-file-name'. | |
| When SWITCHES contains the long `--dired' option, this function | |
| treats it specially, for the sake of dired. However, the | |
| normally equivalent short `-D' option is just passed on to | |
| `insert-directory-program', as any other option." | |
| ;; We need the directory in order to find the right handler. | |
| (let ((handler (find-file-name-handler (expand-file-name file) | |
| 'insert-directory))) | |
| (if handler | |
| (funcall handler 'insert-directory file switches | |
| wildcard full-directory-p) | |
| (let (result (beg (point))) | |
| ;; Read the actual directory using `insert-directory-program'. | |
| ;; RESULT gets the status code. | |
| (let* (;; We at first read by no-conversion, then after | |
| ;; putting text property `dired-filename, decode one | |
| ;; bunch by one to preserve that property. | |
| (coding-system-for-read 'no-conversion) | |
| ;; This is to control encoding the arguments in call-process. | |
| (coding-system-for-write | |
| (and enable-multibyte-characters | |
| (or file-name-coding-system | |
| default-file-name-coding-system)))) | |
| (setq result | |
| (if wildcard | |
| ;; If the wildcard is just in the file part, then run ls in | |
| ;; the directory part of the file pattern using the last | |
| ;; component as argument. Otherwise, run ls in the longest | |
| ;; subdirectory of the directory part free of wildcards; use | |
| ;; the remaining of the file pattern as argument. | |
| (let* ((dir-wildcard (insert-directory-wildcard-in-dir-p file)) | |
| (default-directory | |
| (cond (dir-wildcard (car dir-wildcard)) | |
| (t | |
| (if (file-name-absolute-p file) | |
| (file-name-directory file) | |
| (file-name-directory (expand-file-name file)))))) | |
| (pattern (if dir-wildcard (cdr dir-wildcard) (file-name-nondirectory file)))) | |
| ;; NB since switches is passed to the shell, be | |
| ;; careful of malicious values, eg "-l;reboot". | |
| ;; See eg dired-safe-switches-p. | |
| (call-process | |
| shell-file-name nil t nil | |
| shell-command-switch | |
| (concat (if (memq system-type '(ms-dos windows-nt)) | |
| "" | |
| "\\") ; Disregard Unix shell aliases! | |
| insert-directory-program | |
| " -d " | |
| (if (stringp switches) | |
| switches | |
| (mapconcat 'identity switches " ")) | |
| " -- " | |
| ;; Quote some characters that have | |
| ;; special meanings in shells; but | |
| ;; don't quote the wildcards--we want | |
| ;; them to be special. We also | |
| ;; currently don't quote the quoting | |
| ;; characters in case people want to | |
| ;; use them explicitly to quote | |
| ;; wildcard characters. | |
| (shell-quote-wildcard-pattern pattern)))) | |
| ;; SunOS 4.1.3, SVr4 and others need the "." to list the | |
| ;; directory if FILE is a symbolic link. | |
| (unless full-directory-p | |
| (setq switches | |
| (cond | |
| ((stringp switches) (concat switches " -d")) | |
| ((member "-d" switches) switches) | |
| (t (append switches '("-d")))))) | |
| (apply 'call-process | |
| insert-directory-program nil t nil | |
| (append | |
| (if (listp switches) switches | |
| (unless (equal switches "") | |
| ;; Split the switches at any spaces so we can | |
| ;; pass separate options as separate args. | |
| (split-string-and-unquote switches))) | |
| ;; Avoid lossage if FILE starts with `-'. | |
| '("--") | |
| (progn | |
| (if (string-match "\\`~" file) | |
| (setq file (expand-file-name file))) | |
| (list | |
| (if full-directory-p | |
| ;; (concat (file-name-as-directory file) ".") | |
| file | |
| file)))))))) | |
| ;; If we got "//DIRED//" in the output, it means we got a real | |
| ;; directory listing, even if `ls' returned nonzero. | |
| ;; So ignore any errors. | |
| (when (if (stringp switches) | |
| (string-match "--dired\\>" switches) | |
| (member "--dired" switches)) | |
| (save-excursion | |
| (forward-line -2) | |
| (when (looking-at "//SUBDIRED//") | |
| (forward-line -1)) | |
| (if (looking-at "//DIRED//") | |
| (setq result 0)))) | |
| (when (and (not (eq 0 result)) | |
| (eq insert-directory-ls-version 'unknown)) | |
| ;; The first time ls returns an error, | |
| ;; find the version numbers of ls, | |
| ;; and set insert-directory-ls-version | |
| ;; to > if it is more than 5.2.1, < if it is less, nil if it | |
| ;; is equal or if the info cannot be obtained. | |
| ;; (That can mean it isn't GNU ls.) | |
| (let ((version-out | |
| (with-temp-buffer | |
| (call-process "ls" nil t nil "--version") | |
| (buffer-string)))) | |
| (if (string-match "ls (.*utils) \\([0-9.]*\\)$" version-out) | |
| (let* ((version (match-string 1 version-out)) | |
| (split (split-string version "[.]")) | |
| (numbers (mapcar 'string-to-number split)) | |
| (min '(5 2 1)) | |
| comparison) | |
| (while (and (not comparison) (or numbers min)) | |
| (cond ((null min) | |
| (setq comparison '>)) | |
| ((null numbers) | |
| (setq comparison '<)) | |
| ((> (car numbers) (car min)) | |
| (setq comparison '>)) | |
| ((< (car numbers) (car min)) | |
| (setq comparison '<)) | |
| (t | |
| (setq numbers (cdr numbers) | |
| min (cdr min))))) | |
| (setq insert-directory-ls-version (or comparison '=))) | |
| (setq insert-directory-ls-version nil)))) | |
| ;; For GNU ls versions 5.2.2 and up, ignore minor errors. | |
| (when (and (eq 1 result) (eq insert-directory-ls-version '>)) | |
| (setq result 0)) | |
| ;; If `insert-directory-program' failed, signal an error. | |
| (unless (eq 0 result) | |
| ;; Delete the error message it may have output. | |
| (delete-region beg (point)) | |
| ;; On non-Posix systems, we cannot open a directory, so | |
| ;; don't even try, because that will always result in | |
| ;; the ubiquitous "Access denied". Instead, show the | |
| ;; command line so the user can try to guess what went wrong. | |
| (if (and (file-directory-p file) | |
| (memq system-type '(ms-dos windows-nt))) | |
| (error | |
| "Reading directory: \"%s %s -- %s\" exited with status %s" | |
| insert-directory-program | |
| (if (listp switches) (concat switches) switches) | |
| file result) | |
| ;; Unix. Access the file to get a suitable error. | |
| (access-file file "Reading directory") | |
| (error "Listing directory failed but `access-file' worked"))) | |
| (insert-directory-clean beg switches) | |
| ;; Now decode what read if necessary. | |
| (let ((coding (or coding-system-for-read | |
| file-name-coding-system | |
| default-file-name-coding-system | |
| 'undecided)) | |
| coding-no-eol | |
| val pos) | |
| (when (and enable-multibyte-characters | |
| (not (memq (coding-system-base coding) | |
| '(raw-text no-conversion)))) | |
| ;; If no coding system is specified or detection is | |
| ;; requested, detect the coding. | |
| (if (eq (coding-system-base coding) 'undecided) | |
| (setq coding (detect-coding-region beg (point) t))) | |
| (if (not (eq (coding-system-base coding) 'undecided)) | |
| (save-restriction | |
| (setq coding-no-eol | |
| (coding-system-change-eol-conversion coding 'unix)) | |
| (narrow-to-region beg (point)) | |
| (goto-char (point-min)) | |
| (while (not (eobp)) | |
| (setq pos (point) | |
| val (get-text-property (point) 'dired-filename)) | |
| (goto-char (next-single-property-change | |
| (point) 'dired-filename nil (point-max))) | |
| ;; Force no eol conversion on a file name, so | |
| ;; that CR is preserved. | |
| (decode-coding-region pos (point) | |
| (if val coding-no-eol coding)) | |
| (if val | |
| (put-text-property pos (point) | |
| 'dired-filename t))))))) | |
| (if full-directory-p | |
| ;; Try to insert the amount of free space. | |
| (save-excursion | |
| (goto-char beg) | |
| ;; First find the line to put it on. | |
| (when (re-search-forward "^ *\\(total\\)" nil t) | |
| ;; Replace "total" with "total used in directory" to | |
| ;; avoid confusion. | |
| (replace-match "total used in directory" nil nil nil 1) | |
| (let ((available (get-free-disk-space "."))) | |
| (when available | |
| (end-of-line) | |
| (insert " available " available)))))))))) | |
| (defun insert-directory-adj-pos (pos error-lines) | |
| "Convert `ls --dired' file name position value POS to a buffer position. | |
| File name position values returned in ls --dired output | |
| count only stdout; they don't count the error messages sent to stderr. | |
| So this function converts to them to real buffer positions. | |
| ERROR-LINES is a list of buffer positions of error message lines, | |
| of the form (START END)." | |
| (while (and error-lines (< (caar error-lines) pos)) | |
| (setq pos (+ pos (- (nth 1 (car error-lines)) (nth 0 (car error-lines))))) | |
| (pop error-lines)) | |
| pos) | |
| (defun insert-directory-safely (file switches | |
| &optional wildcard full-directory-p) | |
| "Insert directory listing for FILE, formatted according to SWITCHES. | |
| Like `insert-directory', but if FILE does not exist, it inserts a | |
| message to that effect instead of signaling an error." | |
| (if (file-exists-p file) | |
| (insert-directory file switches wildcard full-directory-p) | |
| ;; Simulate the message printed by `ls'. | |
| (insert (format "%s: No such file or directory\n" file)))) | |
| (defcustom kill-emacs-query-functions nil | |
| "Functions to call with no arguments to query about killing Emacs. | |
| If any of these functions returns nil, killing Emacs is canceled. | |
| `save-buffers-kill-emacs' calls these functions, but `kill-emacs', | |
| the low level primitive, does not. See also `kill-emacs-hook'." | |
| :type 'hook | |
| :version "26.1" | |
| :group 'convenience) | |
| (defcustom confirm-kill-emacs nil | |
| "How to ask for confirmation when leaving Emacs. | |
| If nil, the default, don't ask at all. If the value is non-nil, it should | |
| be a predicate function; for example `yes-or-no-p'." | |
| :type '(choice (const :tag "Ask with yes-or-no-p" yes-or-no-p) | |
| (const :tag "Ask with y-or-n-p" y-or-n-p) | |
| (const :tag "Don't confirm" nil) | |
| (function :tag "Predicate function")) | |
| :group 'convenience | |
| :version "21.1") | |
| (defcustom confirm-kill-processes t | |
| "Non-nil if Emacs should confirm killing processes on exit. | |
| If this variable is nil, the value of | |
| `process-query-on-exit-flag' is ignored. Otherwise, if there are | |
| processes with a non-nil `process-query-on-exit-flag', Emacs will | |
| prompt the user before killing them." | |
| :type 'boolean | |
| :group 'convenience | |
| :version "26.1") | |
| (defun save-buffers-kill-emacs (&optional arg) | |
| "Offer to save each buffer, then kill this Emacs process. | |
| With prefix ARG, silently save all file-visiting buffers without asking. | |
| If there are active processes where `process-query-on-exit-flag' | |
| returns non-nil and `confirm-kill-processes' is non-nil, | |
| asks whether processes should be killed. | |
| Runs the members of `kill-emacs-query-functions' in turn and stops | |
| if any returns nil. If `confirm-kill-emacs' is non-nil, calls it." | |
| (interactive "P") | |
| ;; Don't use save-some-buffers-default-predicate, because we want | |
| ;; to ask about all the buffers before killing Emacs. | |
| (save-some-buffers arg t) | |
| (let ((confirm confirm-kill-emacs)) | |
| (and | |
| (or (not (memq t (mapcar (function | |
| (lambda (buf) (and (buffer-file-name buf) | |
| (buffer-modified-p buf)))) | |
| (buffer-list)))) | |
| (progn (setq confirm nil) | |
| (yes-or-no-p "Modified buffers exist; exit anyway? "))) | |
| (or (not (fboundp 'process-list)) | |
| ;; process-list is not defined on MSDOS. | |
| (not confirm-kill-processes) | |
| (let ((processes (process-list)) | |
| active) | |
| (while processes | |
| (and (memq (process-status (car processes)) '(run stop open listen)) | |
| (process-query-on-exit-flag (car processes)) | |
| (setq active t)) | |
| (setq processes (cdr processes))) | |
| (or (not active) | |
| (with-displayed-buffer-window | |
| (get-buffer-create "*Process List*") | |
| '(display-buffer--maybe-at-bottom | |
| (dedicated . t)) | |
| #'(lambda (window _value) | |
| (with-selected-window window | |
| (unwind-protect | |
| (progn | |
| (setq confirm nil) | |
| (yes-or-no-p "Active processes exist; kill them and exit anyway? ")) | |
| (when (window-live-p window) | |
| (quit-restore-window window 'kill))))) | |
| (list-processes t))))) | |
| ;; Query the user for other things, perhaps. | |
| (run-hook-with-args-until-failure 'kill-emacs-query-functions) | |
| (or (null confirm) | |
| (funcall confirm "Really exit Emacs? ")) | |
| (kill-emacs)))) | |
| (defun save-buffers-kill-terminal (&optional arg) | |
| "Offer to save each buffer, then kill the current connection. | |
| If the current frame has no client, kill Emacs itself using | |
| `save-buffers-kill-emacs'. | |
| With prefix ARG, silently save all file-visiting buffers, then kill. | |
| If emacsclient was started with a list of filenames to edit, then | |
| only these files will be asked to be saved." | |
| (interactive "P") | |
| (if (frame-parameter nil 'client) | |
| (server-save-buffers-kill-terminal arg) | |
| (save-buffers-kill-emacs arg))) | |
| ;; We use /: as a prefix to "quote" a file name | |
| ;; so that magic file name handlers will not apply to it. | |
| (setq file-name-handler-alist | |
| (cons (cons (purecopy "\\`/:") 'file-name-non-special) | |
| file-name-handler-alist)) | |
| ;; We depend on being the last handler on the list, | |
| ;; so that anything else that does need handling | |
| ;; has been handled already. | |
| ;; So it is safe for us to inhibit *all* magic file name handlers for | |
| ;; operations, which return a file name. See Bug#29579. | |
| (defun file-name-non-special (operation &rest arguments) | |
| (let (;; In general, we don't want any file name handler. For some | |
| ;; few cases, operations with two file name arguments which | |
| ;; might be bound to different file name handlers, we still | |
| ;; need this. | |
| (saved-file-name-handler-alist file-name-handler-alist) | |
| file-name-handler-alist | |
| ;; Some operations respect file name handlers in | |
| ;; `default-directory'. Because core function like | |
| ;; `call-process' don't care about file name handlers in | |
| ;; `default-directory', we here have to resolve the directory | |
| ;; into a local one. For `process-file', | |
| ;; `start-file-process', and `shell-command', this fixes | |
| ;; Bug#25949. | |
| (default-directory | |
| (if (memq operation | |
| '(insert-directory process-file start-file-process | |
| make-process shell-command | |
| temporary-file-directory)) | |
| (directory-file-name | |
| (expand-file-name | |
| (unhandled-file-name-directory default-directory))) | |
| default-directory)) | |
| ;; Get a list of the indices of the args that are file names. | |
| (file-arg-indices | |
| (cdr (or (assq operation | |
| '(;; The first seven are special because they | |
| ;; return a file name. We want to include | |
| ;; the /: in the return value. So just | |
| ;; avoid stripping it in the first place. | |
| (directory-file-name) | |
| (expand-file-name) | |
| (file-name-as-directory) | |
| (file-name-directory) | |
| (file-name-sans-versions) | |
| (file-remote-p) | |
| (find-backup-file-name) | |
| ;; `identity' means just return the first | |
| ;; arg not stripped of its quoting. | |
| (substitute-in-file-name identity) | |
| ;; `add' means add "/:" to the result. | |
| (file-truename add 0) | |
| ;;`insert-file-contents' needs special handling. | |
| (insert-file-contents insert-file-contents 0) | |
| ;; `unquote-then-quote' means set buffer-file-name | |
| ;; temporarily to unquoted filename. | |
| (verify-visited-file-modtime unquote-then-quote) | |
| ;; Unquote `buffer-file-name' temporarily. | |
| (make-auto-save-file-name buffer-file-name) | |
| (set-visited-file-modtime buffer-file-name) | |
| ;; Use a temporary local copy. | |
| (copy-file local-copy) | |
| (rename-file local-copy) | |
| (copy-directory local-copy) | |
| ;; List the arguments that are filenames. | |
| (file-name-completion 0 1) | |
| (file-name-all-completions 0 1) | |
| (file-equal-p 0 1) | |
| (file-newer-than-file-p 0 1) | |
| (write-region 2 5) | |
| (file-in-directory-p 0 1) | |
| (make-symbolic-link 0 1) | |
| (add-name-to-file 0 1) | |
| ;; These file-notify-* operations take a | |
| ;; descriptor. | |
| (file-notify-rm-watch) | |
| (file-notify-valid-p) | |
| ;; `make-process' uses keyword arguments and | |
| ;; doesn't mangle its filenames in any way. | |
| ;; It already strips /: from the binary | |
| ;; filename, so we don't have to do this | |
| ;; here. | |
| (make-process))) | |
| ;; For all other operations, treat the first | |
| ;; argument only as the file name. | |
| '(nil 0)))) | |
| method | |
| ;; Copy ARGUMENTS so we can replace elements in it. | |
| (arguments (copy-sequence arguments))) | |
| (if (symbolp (car file-arg-indices)) | |
| (setq method (pop file-arg-indices))) | |
| ;; Strip off the /: from the file names that have it. | |
| (save-match-data ;FIXME: Why? | |
| (while (consp file-arg-indices) | |
| (let ((pair (nthcdr (car file-arg-indices) arguments))) | |
| (when (car pair) | |
| (setcar pair (file-name-unquote (car pair) t)))) | |
| (setq file-arg-indices (cdr file-arg-indices)))) | |
| (pcase method | |
| ('identity (car arguments)) | |
| ('add (file-name-quote (apply operation arguments) t)) | |
| ('buffer-file-name | |
| (let ((buffer-file-name (file-name-unquote buffer-file-name t))) | |
| (apply operation arguments))) | |
| ('insert-file-contents | |
| (let ((visit (nth 1 arguments))) | |
| (unwind-protect | |
| (apply operation arguments) | |
| (when (and visit buffer-file-name) | |
| (setq buffer-file-name (file-name-quote buffer-file-name t)))))) | |
| ('unquote-then-quote | |
| ;; We can't use `cl-letf' with `(buffer-local-value)' here | |
| ;; because it wouldn't work during bootstrapping. | |
| (let ((buffer (current-buffer))) | |
| ;; `unquote-then-quote' is used only for the | |
| ;; `verify-visited-file-modtime' action, which takes a buffer | |
| ;; as only optional argument. | |
| (with-current-buffer (or (car arguments) buffer) | |
| (let ((buffer-file-name (file-name-unquote buffer-file-name t))) | |
| ;; Make sure to hide the temporary buffer change from the | |
| ;; underlying operation. | |
| (with-current-buffer buffer | |
| (apply operation arguments)))))) | |
| ('local-copy | |
| (let* ((file-name-handler-alist saved-file-name-handler-alist) | |
| (source (car arguments)) | |
| (target (car (cdr arguments))) | |
| (prefix (expand-file-name | |
| "file-name-non-special" temporary-file-directory)) | |
| tmpfile) | |
| (cond | |
| ;; If source is remote, we must create a local copy. | |
| ((file-remote-p source) | |
| (setq tmpfile (make-temp-name prefix)) | |
| (apply operation source tmpfile (cddr arguments)) | |
| (setq source tmpfile)) | |
| ;; If source is quoted, and the unquoted source looks | |
| ;; remote, we must create a local copy. | |
| ((file-name-quoted-p source t) | |
| (setq source (file-name-unquote source t)) | |
| (when (file-remote-p source) | |
| (setq tmpfile (make-temp-name prefix)) | |
| (let (file-name-handler-alist) | |
| (apply operation source tmpfile (cddr arguments))) | |
| (setq source tmpfile)))) | |
| ;; If target is quoted, and the unquoted target looks remote, | |
| ;; we must disable the file name handler. | |
| (when (file-name-quoted-p target t) | |
| (setq target (file-name-unquote target t)) | |
| (when (file-remote-p target) | |
| (setq file-name-handler-alist nil))) | |
| ;; Do it. | |
| (setcar arguments source) | |
| (setcar (cdr arguments) target) | |
| (apply operation arguments) | |
| ;; Cleanup. | |
| (when (and tmpfile (file-exists-p tmpfile)) | |
| (if (file-directory-p tmpfile) | |
| (delete-directory tmpfile 'recursive) (delete-file tmpfile))))) | |
| (_ | |
| (apply operation arguments))))) | |
| (defsubst file-name-quoted-p (name &optional top) | |
| "Whether NAME is quoted with prefix \"/:\". | |
| If NAME is a remote file name and TOP is nil, check the local part of NAME." | |
| (let ((file-name-handler-alist (unless top file-name-handler-alist))) | |
| (string-prefix-p "/:" (file-local-name name)))) | |
| (defsubst file-name-quote (name &optional top) | |
| "Add the quotation prefix \"/:\" to file NAME. | |
| If NAME is a remote file name and TOP is nil, the local part of | |
| NAME is quoted. If NAME is already a quoted file name, NAME is | |
| returned unchanged." | |
| (let ((file-name-handler-alist (unless top file-name-handler-alist))) | |
| (if (file-name-quoted-p name top) | |
| name | |
| (concat (file-remote-p name) "/:" (file-local-name name))))) | |
| (defsubst file-name-unquote (name &optional top) | |
| "Remove quotation prefix \"/:\" from file NAME, if any. | |
| If NAME is a remote file name and TOP is nil, the local part of | |
| NAME is unquoted." | |
| (let* ((file-name-handler-alist (unless top file-name-handler-alist)) | |
| (localname (file-local-name name))) | |
| (when (file-name-quoted-p localname top) | |
| (setq | |
| localname (if (= (length localname) 2) "/" (substring localname 2)))) | |
| (concat (file-remote-p name) localname))) | |
| ;; Symbolic modes and read-file-modes. | |
| (defun file-modes-char-to-who (char) | |
| "Convert CHAR to a numeric bit-mask for extracting mode bits. | |
| CHAR is in [ugoa] and represents the category of users (Owner, Group, | |
| Others, or All) for whom to produce the mask. | |
| The bit-mask that is returned extracts from mode bits the access rights | |
| for the specified category of users." | |
| (cond ((= char ?u) #o4700) | |
| ((= char ?g) #o2070) | |
| ((= char ?o) #o1007) | |
| ((= char ?a) #o7777) | |
| (t (error "%c: bad `who' character" char)))) | |
| (defun file-modes-char-to-right (char &optional from) | |
| "Convert CHAR to a numeric value of mode bits. | |
| CHAR is in [rwxXstugo] and represents symbolic access permissions. | |
| If CHAR is in [Xugo], the value is taken from FROM (or 0 if omitted)." | |
| (or from (setq from 0)) | |
| (cond ((= char ?r) #o0444) | |
| ((= char ?w) #o0222) | |
| ((= char ?x) #o0111) | |
| ((= char ?s) #o6000) | |
| ((= char ?t) #o1000) | |
| ;; Rights relative to the previous file modes. | |
| ((= char ?X) (if (= (logand from #o111) 0) 0 #o0111)) | |
| ((= char ?u) (let ((uright (logand #o4700 from))) | |
| (+ uright (/ uright #o10) (/ uright #o100)))) | |
| ((= char ?g) (let ((gright (logand #o2070 from))) | |
| (+ gright (/ gright #o10) (* gright #o10)))) | |
| ((= char ?o) (let ((oright (logand #o1007 from))) | |
| (+ oright (* oright #o10) (* oright #o100)))) | |
| (t (error "%c: bad right character" char)))) | |
| (defun file-modes-rights-to-number (rights who-mask &optional from) | |
| "Convert a symbolic mode string specification to an equivalent number. | |
| RIGHTS is the symbolic mode spec, it should match \"([+=-][rwxXstugo]*)+\". | |
| WHO-MASK is the bit-mask specifying the category of users to which to | |
| apply the access permissions. See `file-modes-char-to-who'. | |
| FROM (or 0 if nil) gives the mode bits on which to base permissions if | |
| RIGHTS request to add, remove, or set permissions based on existing ones, | |
| as in \"og+rX-w\"." | |
| (let* ((num-rights (or from 0)) | |
| (list-rights (string-to-list rights)) | |
| (op (pop list-rights))) | |
| (while (memq op '(?+ ?- ?=)) | |
| (let ((num-right 0) | |
| char-right) | |
| (while (memq (setq char-right (pop list-rights)) | |
| '(?r ?w ?x ?X ?s ?t ?u ?g ?o)) | |
| (setq num-right | |
| (logior num-right | |
| (file-modes-char-to-right char-right num-rights)))) | |
| (setq num-right (logand who-mask num-right) | |
| num-rights | |
| (cond ((= op ?+) (logior num-rights num-right)) | |
| ((= op ?-) (logand num-rights (lognot num-right))) | |
| (t (logior (logand num-rights (lognot who-mask)) num-right))) | |
| op char-right))) | |
| num-rights)) | |
| (defun file-modes-symbolic-to-number (modes &optional from) | |
| "Convert symbolic file modes to numeric file modes. | |
| MODES is the string to convert, it should match | |
| \"[ugoa]*([+-=][rwxXstugo]*)+,...\". | |
| See Info node `(coreutils)File permissions' for more information on this | |
| notation. | |
| FROM (or 0 if nil) gives the mode bits on which to base permissions if | |
| MODES request to add, remove, or set permissions based on existing ones, | |
| as in \"og+rX-w\"." | |
| (save-match-data | |
| (let ((case-fold-search nil) | |
| (num-modes (or from 0))) | |
| (while (/= (string-to-char modes) 0) | |
| (if (string-match "^\\([ugoa]*\\)\\([+=-][rwxXstugo]*\\)+\\(,\\|\\)" modes) | |
| (let ((num-who (apply 'logior 0 | |
| (mapcar 'file-modes-char-to-who | |
| (match-string 1 modes))))) | |
| (when (= num-who 0) | |
| (setq num-who (logior #o7000 (default-file-modes)))) | |
| (setq num-modes | |
| (file-modes-rights-to-number (substring modes (match-end 1)) | |
| num-who num-modes) | |
| modes (substring modes (match-end 3)))) | |
| (error "Parse error in modes near `%s'" (substring modes 0)))) | |
| num-modes))) | |
| (defun read-file-modes (&optional prompt orig-file) | |
| "Read file modes in octal or symbolic notation and return its numeric value. | |
| PROMPT is used as the prompt, default to \"File modes (octal or symbolic): \". | |
| ORIG-FILE is the name of a file on whose mode bits to base returned | |
| permissions if what user types requests to add, remove, or set permissions | |
| based on existing mode bits, as in \"og+rX-w\"." | |
| (let* ((modes (or (if orig-file (file-modes orig-file) 0) | |
| (error "File not found"))) | |
| (modestr (and (stringp orig-file) | |
| (file-attribute-modes (file-attributes orig-file)))) | |
| (default | |
| (and (stringp modestr) | |
| (string-match "^.\\(...\\)\\(...\\)\\(...\\)$" modestr) | |
| (replace-regexp-in-string | |
| "-" "" | |
| (format "u=%s,g=%s,o=%s" | |
| (match-string 1 modestr) | |
| (match-string 2 modestr) | |
| (match-string 3 modestr))))) | |
| (value (read-string (or prompt "File modes (octal or symbolic): ") | |
| nil nil default))) | |
| (save-match-data | |
| (if (string-match "^[0-7]+" value) | |
| (string-to-number value 8) | |
| (file-modes-symbolic-to-number value modes))))) | |
| (define-obsolete-variable-alias 'cache-long-line-scans | |
| 'cache-long-scans "24.4") | |
| ;; Trashcan handling. | |
| (defcustom trash-directory nil | |
| "Directory for `move-file-to-trash' to move files and directories to. | |
| This directory is used only when the function `system-move-file-to-trash' | |
| is not defined. | |
| Relative paths are interpreted relative to `default-directory'. | |
| If the value is nil, Emacs uses a freedesktop.org-style trashcan." | |
| :type '(choice (const nil) directory) | |
| :group 'auto-save | |
| :version "23.2") | |
| (defvar trash--hexify-table) | |
| (declare-function system-move-file-to-trash "w32fns.c" (filename)) | |
| (defun move-file-to-trash (filename) | |
| "Move the file (or directory) named FILENAME to the trash. | |
| When `delete-by-moving-to-trash' is non-nil, this function is | |
| called by `delete-file' and `delete-directory' instead of | |
| deleting files outright. | |
| If the function `system-move-file-to-trash' is defined, call it | |
| with FILENAME as an argument. | |
| Otherwise, if `trash-directory' is non-nil, move FILENAME to that | |
| directory. | |
| Otherwise, trash FILENAME using the freedesktop.org conventions, | |
| like the GNOME, KDE and XFCE desktop environments. Emacs moves | |
| files only to \"home trash\", ignoring per-volume trashcans." | |
| (interactive "fMove file to trash: ") | |
| ;; If `system-move-file-to-trash' is defined, use it. | |
| (cond ((fboundp 'system-move-file-to-trash) | |
| (system-move-file-to-trash filename)) | |
| (trash-directory | |
| ;; If `trash-directory' is non-nil, move the file there. | |
| (let* ((trash-dir (expand-file-name trash-directory)) | |
| (fn (directory-file-name (expand-file-name filename))) | |
| (new-fn (concat (file-name-as-directory trash-dir) | |
| (file-name-nondirectory fn)))) | |
| ;; We can't trash a parent directory of trash-directory. | |
| (if (string-prefix-p fn trash-dir) | |
| (error "Trash directory `%s' is a subdirectory of `%s'" | |
| trash-dir filename)) | |
| (unless (file-directory-p trash-dir) | |
| (make-directory trash-dir t)) | |
| ;; Ensure that the trashed file-name is unique. | |
| (if (file-exists-p new-fn) | |
| (let ((version-control t) | |
| (backup-directory-alist nil)) | |
| (setq new-fn (car (find-backup-file-name new-fn))))) | |
| (let (delete-by-moving-to-trash) | |
| (rename-file fn new-fn)))) | |
| ;; Otherwise, use the freedesktop.org method, as specified at | |
| ;; http://freedesktop.org/wiki/Specifications/trash-spec | |
| (t | |
| (let* ((xdg-data-dir | |
| (directory-file-name | |
| (expand-file-name "Trash" | |
| (or (getenv "XDG_DATA_HOME") | |
| "~/.local/share")))) | |
| (trash-files-dir (expand-file-name "files" xdg-data-dir)) | |
| (trash-info-dir (expand-file-name "info" xdg-data-dir)) | |
| (fn (directory-file-name (expand-file-name filename)))) | |
| ;; Check if we have permissions to delete. | |
| (unless (file-writable-p (directory-file-name | |
| (file-name-directory fn))) | |
| (error "Cannot move %s to trash: Permission denied" filename)) | |
| ;; The trashed file cannot be the trash dir or its parent. | |
| (if (string-prefix-p fn trash-files-dir) | |
| (error "The trash directory %s is a subdirectory of %s" | |
| trash-files-dir filename)) | |
| (if (string-prefix-p fn trash-info-dir) | |
| (error "The trash directory %s is a subdirectory of %s" | |
| trash-info-dir filename)) | |
| ;; Ensure that the trash directory exists; otherwise, create it. | |
| (with-file-modes #o700 | |
| (unless (file-exists-p trash-files-dir) | |
| (make-directory trash-files-dir t)) | |
| (unless (file-exists-p trash-info-dir) | |
| (make-directory trash-info-dir t))) | |
| ;; Try to move to trash with .trashinfo undo information | |
| (save-excursion | |
| (with-temp-buffer | |
| (set-buffer-file-coding-system 'utf-8-unix) | |
| (insert "[Trash Info]\nPath=") | |
| ;; Perform url-encoding on FN. For compatibility with | |
| ;; other programs (e.g. XFCE Thunar), allow literal "/" | |
| ;; for path separators. | |
| (unless (boundp 'trash--hexify-table) | |
| (setq trash--hexify-table (make-vector 256 nil)) | |
| (let ((unreserved-chars | |
| (list ?/ ?a ?b ?c ?d ?e ?f ?g ?h ?i ?j ?k ?l ?m | |
| ?n ?o ?p ?q ?r ?s ?t ?u ?v ?w ?x ?y ?z ?A | |
| ?B ?C ?D ?E ?F ?G ?H ?I ?J ?K ?L ?M ?N ?O | |
| ?P ?Q ?R ?S ?T ?U ?V ?W ?X ?Y ?Z ?0 ?1 ?2 | |
| ?3 ?4 ?5 ?6 ?7 ?8 ?9 ?- ?_ ?. ?! ?~ ?* ?' | |
| ?\( ?\)))) | |
| (dotimes (byte 256) | |
| (aset trash--hexify-table byte | |
| (if (memq byte unreserved-chars) | |
| (char-to-string byte) | |
| (format "%%%02x" byte)))))) | |
| (mapc (lambda (byte) | |
| (insert (aref trash--hexify-table byte))) | |
| (if (multibyte-string-p fn) | |
| (encode-coding-string fn 'utf-8) | |
| fn)) | |
| (insert "\nDeletionDate=" | |
| (format-time-string "%Y-%m-%dT%T") | |
| "\n") | |
| ;; Make a .trashinfo file. Use O_EXCL, as per trash-spec 1.0. | |
| (let* ((files-base (file-name-nondirectory fn)) | |
| (info-fn (expand-file-name | |
| (concat files-base ".trashinfo") | |
| trash-info-dir))) | |
| (condition-case nil | |
| (write-region nil nil info-fn nil 'quiet info-fn 'excl) | |
| (file-already-exists | |
| ;; Uniquify new-fn. Some file managers do not | |
| ;; like Emacs-style backup file names. E.g.: | |
| ;; https://bugs.kde.org/170956 | |
| (setq info-fn (make-temp-file | |
| (expand-file-name files-base trash-info-dir) | |
| nil ".trashinfo")) | |
| (setq files-base (substring (file-name-nondirectory info-fn) | |
| 0 (- (length ".trashinfo")))) | |
| (write-region nil nil info-fn nil 'quiet info-fn))) | |
| ;; Finally, try to move the file to the trashcan. | |
| (let ((delete-by-moving-to-trash nil) | |
| (new-fn (expand-file-name files-base trash-files-dir))) | |
| (rename-file fn new-fn))))))))) | |
| (defsubst file-attribute-type (attributes) | |
| "The type field in ATTRIBUTES returned by `file-attributes'. | |
| The value is either t for directory, string (name linked to) for | |
| symbolic link, or nil." | |
| (nth 0 attributes)) | |
| (defsubst file-attribute-link-number (attributes) | |
| "Return the number of links in ATTRIBUTES returned by `file-attributes'." | |
| (nth 1 attributes)) | |
| (defsubst file-attribute-user-id (attributes) | |
| "The UID field in ATTRIBUTES returned by `file-attributes'. | |
| This is either a string or a number. If a string value cannot be | |
| looked up, a numeric value, either an integer or a float, is | |
| returned." | |
| (nth 2 attributes)) | |
| (defsubst file-attribute-group-id (attributes) | |
| "The GID field in ATTRIBUTES returned by `file-attributes'. | |
| This is either a string or a number. If a string value cannot be | |
| looked up, a numeric value, either an integer or a float, is | |
| returned." | |
| (nth 3 attributes)) | |
| (defsubst file-attribute-access-time (attributes) | |
| "The last access time in ATTRIBUTES returned by `file-attributes'. | |
| This a Lisp timestamp in the style of `current-time'." | |
| (nth 4 attributes)) | |
| (defsubst file-attribute-modification-time (attributes) | |
| "The modification time in ATTRIBUTES returned by `file-attributes'. | |
| This is the time of the last change to the file's contents, and | |
| is a Lisp timestamp in the style of `current-time'." | |
| (nth 5 attributes)) | |
| (defsubst file-attribute-status-change-time (attributes) | |
| "The status modification time in ATTRIBUTES returned by `file-attributes'. | |
| This is the time of last change to the file's attributes: owner | |
| and group, access mode bits, etc., and is a Lisp timestamp in the | |
| style of `current-time'." | |
| (nth 6 attributes)) | |
| (defsubst file-attribute-size (attributes) | |
| "The integer size (in bytes) in ATTRIBUTES returned by `file-attributes'." | |
| (nth 7 attributes)) | |
| (defsubst file-attribute-modes (attributes) | |
| "The file modes in ATTRIBUTES returned by `file-attributes'. | |
| This is a string of ten letters or dashes as in ls -l." | |
| (nth 8 attributes)) | |
| (defsubst file-attribute-inode-number (attributes) | |
| "The inode number in ATTRIBUTES returned by `file-attributes'. | |
| It is a nonnegative integer." | |
| (nth 10 attributes)) | |
| (defsubst file-attribute-device-number (attributes) | |
| "The file system device number in ATTRIBUTES returned by `file-attributes'. | |
| It is an integer." | |
| (nth 11 attributes)) | |
| (defun file-attribute-collect (attributes &rest attr-names) | |
| "Return a sublist of ATTRIBUTES returned by `file-attributes'. | |
| ATTR-NAMES are symbols with the selected attribute names. | |
| Valid attribute names are: type, link-number, user-id, group-id, | |
| access-time, modification-time, status-change-time, size, modes, | |
| inode-number and device-number." | |
| (let ((all '(type link-number user-id group-id access-time | |
| modification-time status-change-time | |
| size modes inode-number device-number)) | |
| result) | |
| (while attr-names | |
| (let ((attr (pop attr-names))) | |
| (if (memq attr all) | |
| (push (funcall | |
| (intern (format "file-attribute-%s" (symbol-name attr))) | |
| attributes) | |
| result) | |
| (error "Wrong attribute name '%S'" attr)))) | |
| (nreverse result))) | |
| (define-key ctl-x-map "\C-f" 'find-file) | |
| (define-key ctl-x-map "\C-r" 'find-file-read-only) | |
| (define-key ctl-x-map "\C-v" 'find-alternate-file) | |
| (define-key ctl-x-map "\C-s" 'save-buffer) | |
| (define-key ctl-x-map "s" 'save-some-buffers) | |
| (define-key ctl-x-map "\C-w" 'write-file) | |
| (define-key ctl-x-map "i" 'insert-file) | |
| (define-key esc-map "~" 'not-modified) | |
| (define-key ctl-x-map "\C-d" 'list-directory) | |
| (define-key ctl-x-map "\C-c" 'save-buffers-kill-terminal) | |
| (define-key ctl-x-map "\C-q" 'read-only-mode) | |
| (define-key ctl-x-4-map "f" 'find-file-other-window) | |
| (define-key ctl-x-4-map "r" 'find-file-read-only-other-window) | |
| (define-key ctl-x-4-map "\C-f" 'find-file-other-window) | |
| (define-key ctl-x-4-map "b" 'switch-to-buffer-other-window) | |
| (define-key ctl-x-4-map "\C-o" 'display-buffer) | |
| (define-key ctl-x-5-map "b" 'switch-to-buffer-other-frame) | |
| (define-key ctl-x-5-map "f" 'find-file-other-frame) | |
| (define-key ctl-x-5-map "\C-f" 'find-file-other-frame) | |
| (define-key ctl-x-5-map "r" 'find-file-read-only-other-frame) | |
| (define-key ctl-x-5-map "\C-o" 'display-buffer-other-frame) | |
| ;;; files.el ends here |
This file contains hidden or bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
| ;;; simple.el --- basic editing commands for Emacs -*- lexical-binding: t -*- | |
| ;; Copyright (C) 1985-1987, 1993-2020 Free Software Foundation, Inc. | |
| ;; Maintainer: [email protected] | |
| ;; Keywords: internal | |
| ;; Package: emacs | |
| ;; This file is part of GNU Emacs. | |
| ;; GNU Emacs is free software: you can redistribute it and/or modify | |
| ;; it under the terms of the GNU General Public License as published by | |
| ;; the Free Software Foundation, either version 3 of the License, or | |
| ;; (at your option) any later version. | |
| ;; GNU Emacs is distributed in the hope that it will be useful, | |
| ;; but WITHOUT ANY WARRANTY; without even the implied warranty of | |
| ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
| ;; GNU General Public License for more details. | |
| ;; You should have received a copy of the GNU General Public License | |
| ;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. | |
| ;;; Commentary: | |
| ;; A grab-bag of basic Emacs commands not specifically related to some | |
| ;; major mode or to file-handling. | |
| ;;; Code: | |
| (eval-when-compile (require 'cl-lib)) | |
| (declare-function widget-convert "wid-edit" (type &rest args)) | |
| (declare-function shell-mode "shell" ()) | |
| ;;; From compile.el | |
| (defvar compilation-current-error) | |
| (defvar compilation-context-lines) | |
| (defcustom idle-update-delay 0.5 | |
| "Idle time delay before updating various things on the screen. | |
| Various Emacs features that update auxiliary information when point moves | |
| wait this many seconds after Emacs becomes idle before doing an update." | |
| :type 'number | |
| :group 'display | |
| :version "22.1") | |
| (defvar amalgamating-undo-limit 20 | |
| "The maximum number of changes to possibly amalgamate when undoing changes. | |
| The `undo' command will normally consider \"similar\" changes | |
| (like inserting characters) to be part of the same change. This | |
| is called \"amalgamating\" the changes. This variable says what | |
| the maximum number of changes considered is when amalgamating. A | |
| value of 1 means that nothing is amalgamated.") | |
| (defgroup killing nil | |
| "Killing and yanking commands." | |
| :group 'editing) | |
| (defgroup paren-matching nil | |
| "Highlight (un)matching of parens and expressions." | |
| :group 'matching) | |
| ;;; next-error support framework | |
| (defgroup next-error nil | |
| "`next-error' support framework." | |
| :group 'compilation | |
| :version "22.1") | |
| (defface next-error | |
| '((t (:inherit region))) | |
| "Face used to highlight next error locus." | |
| :group 'next-error | |
| :version "22.1") | |
| (defcustom next-error-highlight 0.5 | |
| "Highlighting of locations in the selected buffer. | |
| If a number, highlight the locus in `next-error' face for the given time | |
| in seconds, or until the next command is executed. | |
| If t, highlight the locus until the next command is executed, or until | |
| some other locus replaces it. | |
| If nil, don't highlight the locus in the source buffer. | |
| If `fringe-arrow', indicate the locus by the fringe arrow | |
| indefinitely until some other locus replaces it. | |
| See `next-error-highlight-no-select' to customize highlighting | |
| of the locus in non-selected buffers." | |
| :type '(choice (number :tag "Highlight for specified time") | |
| (const :tag "Semipermanent highlighting" t) | |
| (const :tag "No highlighting" nil) | |
| (const :tag "Fringe arrow" fringe-arrow)) | |
| :group 'next-error | |
| :version "22.1") | |
| (defcustom next-error-highlight-no-select 0.5 | |
| "Highlighting of locations in non-selected source buffers. | |
| Usually non-selected buffers are displayed by `next-error-no-select'. | |
| If number, highlight the locus in `next-error' face for given time in seconds. | |
| If t, highlight the locus indefinitely until some other locus replaces it. | |
| If nil, don't highlight the locus in the source buffer. | |
| If `fringe-arrow', indicate the locus by the fringe arrow | |
| indefinitely until some other locus replaces it. | |
| See `next-error-highlight' to customize highlighting of the locus | |
| in the selected buffer." | |
| :type '(choice (number :tag "Highlight for specified time") | |
| (const :tag "Semipermanent highlighting" t) | |
| (const :tag "No highlighting" nil) | |
| (const :tag "Fringe arrow" fringe-arrow)) | |
| :group 'next-error | |
| :version "22.1") | |
| (defcustom next-error-recenter nil | |
| "Display the line in the visited source file recentered as specified. | |
| If non-nil, the value is passed directly to `recenter'." | |
| :type '(choice (integer :tag "Line to recenter to") | |
| (const :tag "Center of window" (4)) | |
| (const :tag "No recentering" nil)) | |
| :group 'next-error | |
| :version "23.1") | |
| (defcustom next-error-hook nil | |
| "List of hook functions run by `next-error' after visiting source file." | |
| :type 'hook | |
| :group 'next-error) | |
| (defcustom next-error-verbose t | |
| "If non-nil, `next-error' always outputs the current error buffer. | |
| If nil, the message is output only when the error buffer | |
| changes." | |
| :group 'next-error | |
| :type 'boolean | |
| :safe #'booleanp | |
| :version "27.1") | |
| (defvar next-error-highlight-timer nil) | |
| (defvar next-error-overlay-arrow-position nil) | |
| (put 'next-error-overlay-arrow-position 'overlay-arrow-string (purecopy "=>")) | |
| (add-to-list 'overlay-arrow-variable-list 'next-error-overlay-arrow-position) | |
| (defvar next-error-last-buffer nil | |
| "The most recent `next-error' buffer. | |
| A buffer becomes most recent when its compilation, grep, or | |
| similar mode is started, or when it is used with \\[next-error] | |
| or \\[compile-goto-error].") | |
| (defvar next-error-buffer nil | |
| "The buffer-local value of the most recent `next-error' buffer.") | |
| ;; next-error-buffer is made buffer-local to keep the reference | |
| ;; to the parent buffer used to navigate to the current buffer, so the | |
| ;; next call of next-buffer will use the same parent buffer to | |
| ;; continue navigation from it. | |
| (make-variable-buffer-local 'next-error-buffer) | |
| (defvar next-error-function nil | |
| "Function to use to find the next error in the current buffer. | |
| The function is called with 2 parameters: | |
| ARG is an integer specifying by how many errors to move. | |
| RESET is a boolean which, if non-nil, says to go back to the beginning | |
| of the errors before moving. | |
| Major modes providing compile-like functionality should set this variable | |
| to indicate to `next-error' that this is a candidate buffer and how | |
| to navigate in it.") | |
| (make-variable-buffer-local 'next-error-function) | |
| (defvar next-error-move-function nil | |
| "Function to use to move to an error locus. | |
| It takes two arguments, a buffer position in the error buffer | |
| and a buffer position in the error locus buffer. | |
| The buffer for the error locus should already be current. | |
| nil means use goto-char using the second argument position.") | |
| (make-variable-buffer-local 'next-error-move-function) | |
| (defsubst next-error-buffer-p (buffer | |
| &optional avoid-current | |
| extra-test-inclusive | |
| extra-test-exclusive) | |
| "Return non-nil if BUFFER is a `next-error' capable buffer. | |
| If AVOID-CURRENT is non-nil, and BUFFER is the current buffer, | |
| return nil. | |
| The function EXTRA-TEST-INCLUSIVE, if non-nil, is called if | |
| BUFFER would not normally qualify. If it returns non-nil, BUFFER | |
| is considered `next-error' capable, anyway, and the function | |
| returns non-nil. | |
| The function EXTRA-TEST-EXCLUSIVE, if non-nil, is called if the | |
| buffer would normally qualify. If it returns nil, BUFFER is | |
| rejected, and the function returns nil." | |
| (and (buffer-name buffer) ;First make sure it's live. | |
| (not (and avoid-current (eq buffer (current-buffer)))) | |
| (with-current-buffer buffer | |
| (if next-error-function ; This is the normal test. | |
| ;; Optionally reject some buffers. | |
| (if extra-test-exclusive | |
| (funcall extra-test-exclusive) | |
| t) | |
| ;; Optionally accept some other buffers. | |
| (and extra-test-inclusive | |
| (funcall extra-test-inclusive)))))) | |
| (defcustom next-error-find-buffer-function #'ignore | |
| "Function called to find a `next-error' capable buffer. | |
| This functions takes the same three arguments as the function | |
| `next-error-find-buffer', and should return the buffer to be | |
| used by the subsequent invocation of the command `next-error' | |
| and `previous-error'. | |
| If the function returns nil, `next-error-find-buffer' will | |
| try to use the buffer it used previously, and failing that | |
| all other buffers." | |
| :type '(choice (const :tag "No default" ignore) | |
| (const :tag "Single next-error capable buffer on selected frame" | |
| next-error-buffer-on-selected-frame) | |
| (function :tag "Other function")) | |
| :group 'next-error | |
| :version "27.1") | |
| (defcustom next-error-found-function #'ignore | |
| "Function called when a next locus is found and displayed. | |
| Function is called with two arguments: a FROM-BUFFER buffer | |
| from which next-error navigated, and a target buffer TO-BUFFER." | |
| :type '(choice (const :tag "No default" ignore) | |
| (function :tag "Other function")) | |
| :group 'next-error | |
| :version "27.1") | |
| (defun next-error-buffer-on-selected-frame (&optional _avoid-current | |
| extra-test-inclusive | |
| extra-test-exclusive) | |
| "Return a single visible next-error buffer on the selected frame." | |
| (let ((window-buffers | |
| (delete-dups | |
| (delq nil (mapcar (lambda (w) | |
| (if (next-error-buffer-p | |
| (window-buffer w) | |
| t | |
| extra-test-inclusive extra-test-exclusive) | |
| (window-buffer w))) | |
| (window-list)))))) | |
| (if (eq (length window-buffers) 1) | |
| (car window-buffers)))) | |
| (defun next-error-find-buffer (&optional avoid-current | |
| extra-test-inclusive | |
| extra-test-exclusive) | |
| "Return a `next-error' capable buffer. | |
| If AVOID-CURRENT is non-nil, treat the current buffer | |
| as an absolute last resort only. | |
| The function EXTRA-TEST-INCLUSIVE, if non-nil, is called in each buffer | |
| that normally would not qualify. If it returns t, the buffer | |
| in question is treated as usable. | |
| The function EXTRA-TEST-EXCLUSIVE, if non-nil, is called in each buffer | |
| that would normally be considered usable. If it returns nil, | |
| that buffer is rejected." | |
| (or | |
| ;; 1. If a customizable function returns a buffer, use it. | |
| (funcall next-error-find-buffer-function avoid-current | |
| extra-test-inclusive | |
| extra-test-exclusive) | |
| ;; 2. If next-error-buffer has no buffer-local value | |
| ;; (i.e. never navigated to the current buffer from another), | |
| ;; and the current buffer is a `next-error' capable buffer, | |
| ;; use it unconditionally, so next-error will always use it. | |
| (if (and (not (local-variable-p 'next-error-buffer)) | |
| (next-error-buffer-p (current-buffer) avoid-current | |
| extra-test-inclusive extra-test-exclusive)) | |
| (current-buffer)) | |
| ;; 3. If next-error-last-buffer is an acceptable buffer, use that. | |
| (if (and next-error-last-buffer | |
| (next-error-buffer-p next-error-last-buffer avoid-current | |
| extra-test-inclusive extra-test-exclusive)) | |
| next-error-last-buffer) | |
| ;; 4. If the current buffer is acceptable, choose it. | |
| (if (next-error-buffer-p (current-buffer) avoid-current | |
| extra-test-inclusive extra-test-exclusive) | |
| (current-buffer)) | |
| ;; 5. Look for any acceptable buffer. | |
| (let ((buffers (buffer-list))) | |
| (while (and buffers | |
| (not (next-error-buffer-p | |
| (car buffers) avoid-current | |
| extra-test-inclusive extra-test-exclusive))) | |
| (setq buffers (cdr buffers))) | |
| (car buffers)) | |
| ;; 6. Use the current buffer as a last resort if it qualifies, | |
| ;; even despite AVOID-CURRENT. | |
| (and avoid-current | |
| (next-error-buffer-p (current-buffer) nil | |
| extra-test-inclusive extra-test-exclusive) | |
| (progn | |
| (message "This is the only buffer with error message locations") | |
| (current-buffer))) | |
| ;; 7. Give up. | |
| (error "No buffers contain error message locations"))) | |
| (defun next-error (&optional arg reset) | |
| "Visit next `next-error' message and corresponding source code. | |
| If all the error messages parsed so far have been processed already, | |
| the message buffer is checked for new ones. | |
| A prefix ARG specifies how many error messages to move; | |
| negative means move back to previous error messages. | |
| Just \\[universal-argument] as a prefix means reparse the error message buffer | |
| and start at the first error. | |
| The RESET argument specifies that we should restart from the beginning. | |
| \\[next-error] normally uses the most recently started | |
| compilation, grep, or occur buffer. It can also operate on any | |
| buffer with output from the \\[compile], \\[grep] commands, or, | |
| more generally, on any buffer in Compilation mode or with | |
| Compilation Minor mode enabled, or any buffer in which | |
| `next-error-function' is bound to an appropriate function. | |
| To specify use of a particular buffer for error messages, type | |
| \\[next-error] in that buffer. You can also use the command | |
| `next-error-select-buffer' to select the buffer to use for the subsequent | |
| invocation of `next-error'. | |
| Once \\[next-error] has chosen the buffer for error messages, it | |
| runs `next-error-hook' with `run-hooks', and stays with that buffer | |
| until you use it in some other buffer that uses Compilation mode | |
| or Compilation Minor mode. | |
| To control which errors are matched, customize the variable | |
| `compilation-error-regexp-alist'." | |
| (interactive "P") | |
| (if (consp arg) (setq reset t arg nil)) | |
| (let ((buffer (next-error-find-buffer))) | |
| (when buffer | |
| ;; We know here that next-error-function is a valid symbol we can funcall | |
| (with-current-buffer buffer | |
| (funcall next-error-function (prefix-numeric-value arg) reset) | |
| (let ((prev next-error-last-buffer)) | |
| (next-error-found buffer (current-buffer)) | |
| (when (or next-error-verbose | |
| (not (eq prev next-error-last-buffer))) | |
| (message "%s locus from %s" | |
| (cond (reset "First") | |
| ((eq (prefix-numeric-value arg) 0) "Current") | |
| ((< (prefix-numeric-value arg) 0) "Previous") | |
| (t "Next")) | |
| next-error-last-buffer))))))) | |
| (defun next-error-internal () | |
| "Visit the source code corresponding to the `next-error' message at point." | |
| (let ((buffer (current-buffer))) | |
| ;; We know here that next-error-function is a valid symbol we can funcall | |
| (funcall next-error-function 0 nil) | |
| (let ((prev next-error-last-buffer)) | |
| (next-error-found buffer (current-buffer)) | |
| (when (or next-error-verbose | |
| (not (eq prev next-error-last-buffer))) | |
| (message "Current locus from %s" next-error-last-buffer))))) | |
| (defun next-error-found (&optional from-buffer to-buffer) | |
| "Function to call when the next locus is found and displayed. | |
| FROM-BUFFER is a buffer from which next-error navigated, | |
| and TO-BUFFER is a target buffer." | |
| (setq next-error-last-buffer (or from-buffer (current-buffer))) | |
| (when to-buffer | |
| (with-current-buffer to-buffer | |
| (setq next-error-buffer from-buffer))) | |
| (when next-error-recenter | |
| (recenter next-error-recenter)) | |
| (funcall next-error-found-function from-buffer to-buffer) | |
| (run-hooks 'next-error-hook)) | |
| (defun next-error-select-buffer (buffer) | |
| "Select a `next-error' capable BUFFER and set it as the last used. | |
| This means that the selected buffer becomes the source of locations | |
| for the subsequent invocation of `next-error' or `previous-error'. | |
| Interactively, this command allows selection only among buffers | |
| where `next-error-function' is bound to an appropriate function." | |
| (interactive | |
| (list (get-buffer | |
| (read-buffer "Select next-error buffer: " nil nil | |
| (lambda (b) (next-error-buffer-p (cdr b))))))) | |
| (setq next-error-last-buffer buffer)) | |
| (defalias 'goto-next-locus 'next-error) | |
| (defalias 'next-match 'next-error) | |
| (defun previous-error (&optional n) | |
| "Visit previous `next-error' message and corresponding source code. | |
| Prefix arg N says how many error messages to move backwards (or | |
| forwards, if negative). | |
| This operates on the output from the \\[compile] and \\[grep] commands. | |
| See `next-error' for the details." | |
| (interactive "p") | |
| (next-error (- (or n 1)))) | |
| (defun first-error (&optional n) | |
| "Restart at the first error. | |
| Visit corresponding source code. | |
| With prefix arg N, visit the source code of the Nth error. | |
| This operates on the output from the \\[compile] command, for instance." | |
| (interactive "p") | |
| (next-error n t)) | |
| (defun next-error-no-select (&optional n) | |
| "Move point to the next error in the `next-error' buffer and highlight match. | |
| Prefix arg N says how many error messages to move forwards (or | |
| backwards, if negative). | |
| Finds and highlights the source line like \\[next-error], but does not | |
| select the source buffer." | |
| (interactive "p") | |
| (save-selected-window | |
| (let ((next-error-highlight next-error-highlight-no-select) | |
| (display-buffer-overriding-action | |
| '(nil (inhibit-same-window . t)))) | |
| (next-error n)))) | |
| (defun previous-error-no-select (&optional n) | |
| "Move point to the previous error in the `next-error' buffer and highlight match. | |
| Prefix arg N says how many error messages to move backwards (or | |
| forwards, if negative). | |
| Finds and highlights the source line like \\[previous-error], but does not | |
| select the source buffer." | |
| (interactive "p") | |
| (next-error-no-select (- (or n 1)))) | |
| ;; Internal variable for `next-error-follow-mode-post-command-hook'. | |
| (defvar next-error-follow-last-line nil) | |
| (define-minor-mode next-error-follow-minor-mode | |
| "Minor mode for compilation, occur and diff modes. | |
| When turned on, cursor motion in the compilation, grep, occur or diff | |
| buffer causes automatic display of the corresponding source code location." | |
| :group 'next-error :init-value nil :lighter " Fol" | |
| (if (not next-error-follow-minor-mode) | |
| (remove-hook 'post-command-hook 'next-error-follow-mode-post-command-hook t) | |
| (add-hook 'post-command-hook 'next-error-follow-mode-post-command-hook nil t) | |
| (make-local-variable 'next-error-follow-last-line))) | |
| ;; Used as a `post-command-hook' by `next-error-follow-mode' | |
| ;; for the *Compilation* *grep* and *Occur* buffers. | |
| (defun next-error-follow-mode-post-command-hook () | |
| (unless (equal next-error-follow-last-line (line-number-at-pos)) | |
| (setq next-error-follow-last-line (line-number-at-pos)) | |
| (condition-case nil | |
| (let ((compilation-context-lines nil)) | |
| (setq compilation-current-error (point)) | |
| (next-error-no-select 0)) | |
| (error t)))) | |
| ;;; | |
| (defun fundamental-mode () | |
| "Major mode not specialized for anything in particular. | |
| Other major modes are defined by comparison with this one." | |
| (interactive) | |
| (kill-all-local-variables) | |
| (run-mode-hooks)) | |
| ;; Special major modes to view specially formatted data rather than files. | |
| (defvar special-mode-map | |
| (let ((map (make-sparse-keymap))) | |
| (suppress-keymap map) | |
| (define-key map "q" 'quit-window) | |
| (define-key map " " 'scroll-up-command) | |
| (define-key map [?\S-\ ] 'scroll-down-command) | |
| (define-key map "\C-?" 'scroll-down-command) | |
| (define-key map "?" 'describe-mode) | |
| (define-key map "h" 'describe-mode) | |
| (define-key map ">" 'end-of-buffer) | |
| (define-key map "<" 'beginning-of-buffer) | |
| (define-key map "g" 'revert-buffer) | |
| map)) | |
| (put 'special-mode 'mode-class 'special) | |
| (define-derived-mode special-mode nil "Special" | |
| "Parent major mode from which special major modes should inherit. | |
| A special major mode is intended to view specially formatted data | |
| rather than files. These modes usually use read-only buffers." | |
| (setq buffer-read-only t)) | |
| ;; Making and deleting lines. | |
| (defvar self-insert-uses-region-functions nil | |
| "Special hook to tell if `self-insert-command' will use the region. | |
| It must be called via `run-hook-with-args-until-success' with no arguments. | |
| If any function on this hook returns a non-nil value, `delete-selection-mode' | |
| will act on that value (see `delete-selection-helper') and will | |
| usually delete the region. If all the functions on this hook return | |
| nil, it is an indiction that `self-insert-command' needs the region | |
| untouched by `delete-selection-mode' and will itself do whatever is | |
| appropriate with the region. | |
| Any function on `post-self-insert-hook' that acts on the region should | |
| add a function to this hook so that `delete-selection-mode' could | |
| refrain from deleting the region before the `post-self-insert-hook' | |
| functions are called. | |
| This hook is run by `delete-selection-uses-region-p', which see.") | |
| (defvar hard-newline (propertize "\n" 'hard t 'rear-nonsticky '(hard)) | |
| "Propertized string representing a hard newline character.") | |
| (defun newline (&optional arg interactive) | |
| "Insert a newline, and move to left margin of the new line if it's blank. | |
| With prefix argument ARG, insert that many newlines. | |
| If `electric-indent-mode' is enabled, this indents the final new line | |
| that it adds, and reindents the preceding line. To just insert | |
| a newline, use \\[electric-indent-just-newline]. | |
| If `auto-fill-mode' is enabled, this may cause automatic line | |
| breaking of the preceding line. A non-nil ARG inhibits this. | |
| If `use-hard-newlines' is enabled, the newline is marked with the | |
| text-property `hard'. | |
| A non-nil INTERACTIVE argument means to run the `post-self-insert-hook'." | |
| (interactive "*P\np") | |
| (barf-if-buffer-read-only) | |
| ;; Call self-insert so that auto-fill, abbrev expansion etc. happen. | |
| ;; Set last-command-event to tell self-insert what to insert. | |
| (let* ((was-page-start (and (bolp) (looking-at page-delimiter))) | |
| (beforepos (point)) | |
| (last-command-event ?\n) | |
| ;; Don't auto-fill if we have a prefix argument. | |
| (auto-fill-function (if arg nil auto-fill-function)) | |
| (arg (prefix-numeric-value arg)) | |
| (postproc | |
| ;; Do the rest in post-self-insert-hook, because we want to do it | |
| ;; *before* other functions on that hook. | |
| (lambda () | |
| ;; Mark the newline(s) `hard'. | |
| (if use-hard-newlines | |
| (set-hard-newline-properties | |
| (- (point) arg) (point))) | |
| ;; If the newline leaves the previous line blank, and we | |
| ;; have a left margin, delete that from the blank line. | |
| (save-excursion | |
| (goto-char beforepos) | |
| (beginning-of-line) | |
| (and (looking-at "[ \t]$") | |
| (> (current-left-margin) 0) | |
| (delete-region (point) | |
| (line-end-position)))) | |
| ;; Indent the line after the newline, except in one case: | |
| ;; when we added the newline at the beginning of a line that | |
| ;; starts a page. | |
| (or was-page-start | |
| (move-to-left-margin nil t))))) | |
| (if (not interactive) | |
| ;; FIXME: For non-interactive uses, many calls actually | |
| ;; just want (insert "\n"), so maybe we should do just | |
| ;; that, so as to avoid the risk of filling or running | |
| ;; abbrevs unexpectedly. | |
| (let ((post-self-insert-hook (list postproc))) | |
| (self-insert-command arg)) | |
| (unwind-protect | |
| (progn | |
| (add-hook 'post-self-insert-hook postproc nil t) | |
| (self-insert-command arg)) | |
| ;; We first used let-binding to protect the hook, but that | |
| ;; was naive since add-hook affects the symbol-default | |
| ;; value of the variable, whereas the let-binding might | |
| ;; protect only the buffer-local value. | |
| (remove-hook 'post-self-insert-hook postproc t)))) | |
| nil) | |
| (defun set-hard-newline-properties (from to) | |
| (let ((sticky (get-text-property from 'rear-nonsticky))) | |
| (put-text-property from to 'hard 't) | |
| ;; If rear-nonsticky is not "t", add 'hard to rear-nonsticky list | |
| (if (and (listp sticky) (not (memq 'hard sticky))) | |
| (put-text-property from (point) 'rear-nonsticky | |
| (cons 'hard sticky))))) | |
| (defun open-line (n) | |
| "Insert a newline and leave point before it. | |
| If there is a fill prefix and/or a `left-margin', insert them on | |
| the new line if the line would have been blank. | |
| With arg N, insert N newlines." | |
| (interactive "*p") | |
| (let* ((do-fill-prefix (and fill-prefix (bolp))) | |
| (do-left-margin (and (bolp) (> (current-left-margin) 0))) | |
| (loc (point-marker)) | |
| ;; Don't expand an abbrev before point. | |
| (abbrev-mode nil)) | |
| (newline n) | |
| (goto-char loc) | |
| (while (> n 0) | |
| (cond ((bolp) | |
| (if do-left-margin (indent-to (current-left-margin))) | |
| (if do-fill-prefix (insert-and-inherit fill-prefix)))) | |
| (forward-line 1) | |
| (setq n (1- n))) | |
| (goto-char loc) | |
| ;; Necessary in case a margin or prefix was inserted. | |
| (end-of-line))) | |
| (defun split-line (&optional arg) | |
| "Split current line, moving portion beyond point vertically down. | |
| If the current line starts with `fill-prefix', insert it on the new | |
| line as well. With prefix ARG, don't insert `fill-prefix' on new line. | |
| When called from Lisp code, ARG may be a prefix string to copy." | |
| (interactive "*P") | |
| (skip-chars-forward " \t") | |
| (let* ((col (current-column)) | |
| (pos (point)) | |
| ;; What prefix should we check for (nil means don't). | |
| (prefix (cond ((stringp arg) arg) | |
| (arg nil) | |
| (t fill-prefix))) | |
| ;; Does this line start with it? | |
| (have-prfx (and prefix | |
| (save-excursion | |
| (beginning-of-line) | |
| (looking-at (regexp-quote prefix)))))) | |
| (newline 1) | |
| (if have-prfx (insert-and-inherit prefix)) | |
| (indent-to col 0) | |
| (goto-char pos))) | |
| (defun delete-indentation (&optional arg beg end) | |
| "Join this line to previous and fix up whitespace at join. | |
| If there is a fill prefix, delete it from the beginning of this | |
| line. | |
| With prefix ARG, join the current line to the following line. | |
| When BEG and END are non-nil, join all lines in the region they | |
| define. Interactively, BEG and END are, respectively, the start | |
| and end of the region if it is active, else nil. (The region is | |
| ignored if prefix ARG is given.)" | |
| (interactive | |
| (progn (barf-if-buffer-read-only) | |
| (cons current-prefix-arg | |
| (and (use-region-p) | |
| (list (region-beginning) (region-end)))))) | |
| ;; Consistently deactivate mark even when no text is changed. | |
| (setq deactivate-mark t) | |
| (if (and beg (not arg)) | |
| ;; Region is active. Go to END, but only if region spans | |
| ;; multiple lines. | |
| (and (goto-char beg) | |
| (> end (line-end-position)) | |
| (goto-char end)) | |
| ;; Region is inactive. Set a loop sentinel | |
| ;; (subtracting 1 in order to compare less than BOB). | |
| (setq beg (1- (line-beginning-position (and arg 2)))) | |
| (when arg (forward-line))) | |
| (let ((prefix (and (> (length fill-prefix) 0) | |
| (regexp-quote fill-prefix)))) | |
| (while (and (> (line-beginning-position) beg) | |
| (forward-line 0) | |
| (= (preceding-char) ?\n)) | |
| (delete-char -1) | |
| ;; If the appended line started with the fill prefix, | |
| ;; delete the prefix. | |
| (if (and prefix (looking-at prefix)) | |
| (replace-match "" t t)) | |
| (fixup-whitespace)))) | |
| (defalias 'join-line #'delete-indentation) ; easier to find | |
| (defun delete-blank-lines () | |
| "On blank line, delete all surrounding blank lines, leaving just one. | |
| On isolated blank line, delete that one. | |
| On nonblank line, delete any immediately following blank lines." | |
| (interactive "*") | |
| (let (thisblank singleblank) | |
| (save-excursion | |
| (beginning-of-line) | |
| (setq thisblank (looking-at "[ \t]*$")) | |
| ;; Set singleblank if there is just one blank line here. | |
| (setq singleblank | |
| (and thisblank | |
| (not (looking-at "[ \t]*\n[ \t]*$")) | |
| (or (bobp) | |
| (progn (forward-line -1) | |
| (not (looking-at "[ \t]*$"))))))) | |
| ;; Delete preceding blank lines, and this one too if it's the only one. | |
| (if thisblank | |
| (progn | |
| (beginning-of-line) | |
| (if singleblank (forward-line 1)) | |
| (delete-region (point) | |
| (if (re-search-backward "[^ \t\n]" nil t) | |
| (progn (forward-line 1) (point)) | |
| (point-min))))) | |
| ;; Delete following blank lines, unless the current line is blank | |
| ;; and there are no following blank lines. | |
| (if (not (and thisblank singleblank)) | |
| (save-excursion | |
| (end-of-line) | |
| (forward-line 1) | |
| (delete-region (point) | |
| (if (re-search-forward "[^ \t\n]" nil t) | |
| (progn (beginning-of-line) (point)) | |
| (point-max))))) | |
| ;; Handle the special case where point is followed by newline and eob. | |
| ;; Delete the line, leaving point at eob. | |
| (if (looking-at "^[ \t]*\n\\'") | |
| (delete-region (point) (point-max))))) | |
| (defcustom delete-trailing-lines t | |
| "If non-nil, \\[delete-trailing-whitespace] deletes trailing lines. | |
| Trailing lines are deleted only if `delete-trailing-whitespace' | |
| is called on the entire buffer (rather than an active region)." | |
| :type 'boolean | |
| :group 'editing | |
| :version "24.3") | |
| (defun region-modifiable-p (start end) | |
| "Return non-nil if the region contains no read-only text." | |
| (and (not (get-text-property start 'read-only)) | |
| (eq end (next-single-property-change start 'read-only nil end)))) | |
| (defun delete-trailing-whitespace (&optional start end) | |
| "Delete trailing whitespace between START and END. | |
| If called interactively, START and END are the start/end of the | |
| region if the mark is active, or of the buffer's accessible | |
| portion if the mark is inactive. | |
| This command deletes whitespace characters after the last | |
| non-whitespace character in each line between START and END. It | |
| does not consider formfeed characters to be whitespace. | |
| If this command acts on the entire buffer (i.e. if called | |
| interactively with the mark inactive, or called from Lisp with | |
| END nil), it also deletes all trailing lines at the end of the | |
| buffer if the variable `delete-trailing-lines' is non-nil." | |
| (interactive (progn | |
| (barf-if-buffer-read-only) | |
| (if (use-region-p) | |
| (list (region-beginning) (region-end)) | |
| (list nil nil)))) | |
| (save-match-data | |
| (save-excursion | |
| (let ((end-marker (and end (copy-marker end)))) | |
| (goto-char (or start (point-min))) | |
| (with-syntax-table (make-syntax-table (syntax-table)) | |
| ;; Don't delete formfeeds, even if they are considered whitespace. | |
| (modify-syntax-entry ?\f "_") | |
| (while (re-search-forward "\\s-$" end-marker t) | |
| (skip-syntax-backward "-" (line-beginning-position)) | |
| (let ((b (point)) (e (match-end 0))) | |
| (if (region-modifiable-p b e) | |
| (delete-region b e) | |
| (goto-char e))))) | |
| (if end | |
| (set-marker end-marker nil) | |
| ;; Delete trailing empty lines. | |
| (and delete-trailing-lines | |
| ;; Really the end of buffer. | |
| (= (goto-char (point-max)) (1+ (buffer-size))) | |
| (<= (skip-chars-backward "\n") -2) | |
| (region-modifiable-p (1+ (point)) (point-max)) | |
| (delete-region (1+ (point)) (point-max))))))) | |
| ;; Return nil for the benefit of `write-file-functions'. | |
| nil) | |
| (defun newline-and-indent (&optional arg) | |
| "Insert a newline, then indent according to major mode. | |
| Indentation is done using the value of `indent-line-function'. | |
| In programming language modes, this is the same as TAB. | |
| In some text modes, where TAB inserts a tab, this command indents to the | |
| column specified by the function `current-left-margin'. | |
| With ARG, perform this action that many times." | |
| (interactive "*p") | |
| (delete-horizontal-space t) | |
| (unless arg | |
| (setq arg 1)) | |
| (dotimes (_ arg) | |
| (newline nil t) | |
| (indent-according-to-mode))) | |
| (defun reindent-then-newline-and-indent () | |
| "Reindent current line, insert newline, then indent the new line. | |
| Indentation of both lines is done according to the current major mode, | |
| which means calling the current value of `indent-line-function'. | |
| In programming language modes, this is the same as TAB. | |
| In some text modes, where TAB inserts a tab, this indents to the | |
| column specified by the function `current-left-margin'." | |
| (interactive "*") | |
| (let ((pos (point))) | |
| ;; Be careful to insert the newline before indenting the line. | |
| ;; Otherwise, the indentation might be wrong. | |
| (newline) | |
| (save-excursion | |
| (goto-char pos) | |
| ;; We are at EOL before the call to indent-according-to-mode, and | |
| ;; after it we usually are as well, but not always. We tried to | |
| ;; address it with `save-excursion' but that uses a normal marker | |
| ;; whereas we need `move after insertion', so we do the save/restore | |
| ;; by hand. | |
| (setq pos (copy-marker pos t)) | |
| (indent-according-to-mode) | |
| (goto-char pos) | |
| ;; Remove the trailing white-space after indentation because | |
| ;; indentation may introduce the whitespace. | |
| (delete-horizontal-space t)) | |
| (indent-according-to-mode))) | |
| (defcustom read-quoted-char-radix 8 | |
| "Radix for \\[quoted-insert] and other uses of `read-quoted-char'. | |
| Legitimate radix values are 8, 10 and 16." | |
| :type '(choice (const 8) (const 10) (const 16)) | |
| :group 'editing-basics) | |
| (defun read-quoted-char (&optional prompt) | |
| "Like `read-char', but do not allow quitting. | |
| Also, if the first character read is an octal digit, | |
| we read any number of octal digits and return the | |
| specified character code. Any nondigit terminates the sequence. | |
| If the terminator is RET, it is discarded; | |
| any other terminator is used itself as input. | |
| The optional argument PROMPT specifies a string to use to prompt the user. | |
| The variable `read-quoted-char-radix' controls which radix to use | |
| for numeric input." | |
| (let ((message-log-max nil) | |
| (help-events (delq nil (mapcar (lambda (c) (unless (characterp c) c)) | |
| help-event-list))) | |
| done (first t) (code 0) char translated) | |
| (while (not done) | |
| (let ((inhibit-quit first) | |
| ;; Don't let C-h or other help chars get the help | |
| ;; message--only help function keys. See bug#16617. | |
| (help-char nil) | |
| (help-event-list help-events) | |
| (help-form | |
| "Type the special character you want to use, | |
| or the octal character code. | |
| RET terminates the character code and is discarded; | |
| any other non-digit terminates the character code and is then used as input.")) | |
| (setq char (read-event (and prompt (format "%s-" prompt)) t)) | |
| (if inhibit-quit (setq quit-flag nil))) | |
| ;; Translate TAB key into control-I ASCII character, and so on. | |
| ;; Note: `read-char' does it using the `ascii-character' property. | |
| ;; We tried using read-key instead, but that disables the keystroke | |
| ;; echo produced by 'C-q', see bug#24635. | |
| (let ((translation (lookup-key local-function-key-map (vector char)))) | |
| (setq translated (if (arrayp translation) | |
| (aref translation 0) | |
| char))) | |
| (if (integerp translated) | |
| (setq translated (char-resolve-modifiers translated))) | |
| (cond ((null translated)) | |
| ((not (integerp translated)) | |
| (setq unread-command-events (list char) | |
| done t)) | |
| ((/= (logand translated ?\M-\^@) 0) | |
| ;; Turn a meta-character into a character with the 0200 bit set. | |
| (setq code (logior (logand translated (lognot ?\M-\^@)) 128) | |
| done t)) | |
| ((and (<= ?0 translated) | |
| (< translated (+ ?0 (min 10 read-quoted-char-radix)))) | |
| (setq code (+ (* code read-quoted-char-radix) (- translated ?0))) | |
| (and prompt (setq prompt (message "%s %c" prompt translated)))) | |
| ((and (<= ?a (downcase translated)) | |
| (< (downcase translated) | |
| (+ ?a -10 (min 36 read-quoted-char-radix)))) | |
| (setq code (+ (* code read-quoted-char-radix) | |
| (+ 10 (- (downcase translated) ?a)))) | |
| (and prompt (setq prompt (message "%s %c" prompt translated)))) | |
| ((and (not first) (eq translated ?\C-m)) | |
| (setq done t)) | |
| ((not first) | |
| (setq unread-command-events (list char) | |
| done t)) | |
| (t (setq code translated | |
| done t))) | |
| (setq first nil)) | |
| code)) | |
| (defun quoted-insert (arg) | |
| "Read next input character and insert it. | |
| This is useful for inserting control characters. | |
| With argument, insert ARG copies of the character. | |
| If the first character you type after this command is an octal digit, | |
| you should type a sequence of octal digits that specify a character code. | |
| Any nondigit terminates the sequence. If the terminator is a RET, | |
| it is discarded; any other terminator is used itself as input. | |
| The variable `read-quoted-char-radix' specifies the radix for this feature; | |
| set it to 10 or 16 to use decimal or hex instead of octal. | |
| In overwrite mode, this function inserts the character anyway, and | |
| does not handle octal digits specially. This means that if you use | |
| overwrite as your normal editing mode, you can use this function to | |
| insert characters when necessary. | |
| In binary overwrite mode, this function does overwrite, and octal | |
| digits are interpreted as a character code. This is intended to be | |
| useful for editing binary files." | |
| (interactive "*p") | |
| (let* ((char | |
| ;; Avoid "obsolete" warnings for translation-table-for-input. | |
| (with-no-warnings | |
| (let (translation-table-for-input input-method-function) | |
| (if (or (not overwrite-mode) | |
| (eq overwrite-mode 'overwrite-mode-binary)) | |
| (read-quoted-char) | |
| (read-char)))))) | |
| ;; This used to assume character codes 0240 - 0377 stand for | |
| ;; characters in some single-byte character set, and converted them | |
| ;; to Emacs characters. But in 23.1 this feature is deprecated | |
| ;; in favor of inserting the corresponding Unicode characters. | |
| ;; (if (and enable-multibyte-characters | |
| ;; (>= char ?\240) | |
| ;; (<= char ?\377)) | |
| ;; (setq char (unibyte-char-to-multibyte char))) | |
| (unless (characterp char) | |
| (user-error "%s is not a valid character" | |
| (key-description (vector char)))) | |
| (if (> arg 0) | |
| (if (eq overwrite-mode 'overwrite-mode-binary) | |
| (delete-char arg))) | |
| (while (> arg 0) | |
| (insert-and-inherit char) | |
| (setq arg (1- arg))))) | |
| (defun forward-to-indentation (&optional arg) | |
| "Move forward ARG lines and position at first nonblank character." | |
| (interactive "^p") | |
| (forward-line (or arg 1)) | |
| (skip-chars-forward " \t")) | |
| (defun backward-to-indentation (&optional arg) | |
| "Move backward ARG lines and position at first nonblank character." | |
| (interactive "^p") | |
| (forward-line (- (or arg 1))) | |
| (skip-chars-forward " \t")) | |
| (defun back-to-indentation () | |
| "Move point to the first non-whitespace character on this line." | |
| (interactive "^") | |
| (beginning-of-line 1) | |
| (skip-syntax-forward " " (line-end-position)) | |
| ;; Move back over chars that have whitespace syntax but have the p flag. | |
| (backward-prefix-chars)) | |
| (defun fixup-whitespace () | |
| "Fixup white space between objects around point. | |
| Leave one space or none, according to the context." | |
| (interactive "*") | |
| (save-excursion | |
| (delete-horizontal-space) | |
| (if (or (looking-at "^\\|$\\|\\s)") | |
| (save-excursion (forward-char -1) | |
| (looking-at "$\\|\\s(\\|\\s'"))) | |
| nil | |
| (insert ?\s)))) | |
| (defun delete-horizontal-space (&optional backward-only) | |
| "Delete all spaces and tabs around point. | |
| If BACKWARD-ONLY is non-nil, delete them only before point." | |
| (interactive "*P") | |
| (let ((orig-pos (point))) | |
| (delete-region | |
| (if backward-only | |
| orig-pos | |
| (progn | |
| (skip-chars-forward " \t") | |
| (constrain-to-field nil orig-pos t))) | |
| (progn | |
| (skip-chars-backward " \t") | |
| (constrain-to-field nil orig-pos))))) | |
| (defun just-one-space (&optional n) | |
| "Delete all spaces and tabs around point, leaving one space (or N spaces). | |
| If N is negative, delete newlines as well, leaving -N spaces. | |
| See also `cycle-spacing'." | |
| (interactive "*p") | |
| (cycle-spacing n nil 'single-shot)) | |
| (defvar cycle-spacing--context nil | |
| "Store context used in consecutive calls to `cycle-spacing' command. | |
| The first time `cycle-spacing' runs, it saves in this variable: | |
| its N argument, the original point position, and the original spacing | |
| around point.") | |
| (defun cycle-spacing (&optional n preserve-nl-back mode) | |
| "Manipulate whitespace around point in a smart way. | |
| In interactive use, this function behaves differently in successive | |
| consecutive calls. | |
| The first call in a sequence acts like `just-one-space'. | |
| It deletes all spaces and tabs around point, leaving one space | |
| \(or N spaces). N is the prefix argument. If N is negative, | |
| it deletes newlines as well, leaving -N spaces. | |
| \(If PRESERVE-NL-BACK is non-nil, it does not delete newlines before point.) | |
| The second call in a sequence deletes all spaces. | |
| The third call in a sequence restores the original whitespace (and point). | |
| If MODE is `single-shot', it performs only the first step in the sequence. | |
| If MODE is `fast' and the first step would not result in any change | |
| \(i.e., there are exactly (abs N) spaces around point), | |
| the function goes straight to the second step. | |
| Repeatedly calling the function with different values of N starts a | |
| new sequence each time." | |
| (interactive "*p") | |
| (let ((orig-pos (point)) | |
| (skip-characters (if (and n (< n 0)) " \t\n\r" " \t")) | |
| (num (abs (or n 1)))) | |
| (skip-chars-backward (if preserve-nl-back " \t" skip-characters)) | |
| (constrain-to-field nil orig-pos) | |
| (cond | |
| ;; Command run for the first time, single-shot mode or different argument | |
| ((or (eq 'single-shot mode) | |
| (not (equal last-command this-command)) | |
| (not cycle-spacing--context) | |
| (not (eq (car cycle-spacing--context) n))) | |
| (let* ((start (point)) | |
| (num (- num (skip-chars-forward " " (+ num (point))))) | |
| (mid (point)) | |
| (end (progn | |
| (skip-chars-forward skip-characters) | |
| (constrain-to-field nil orig-pos t)))) | |
| (setq cycle-spacing--context ;; Save for later. | |
| ;; Special handling for case where there was no space at all. | |
| (unless (= start end) | |
| (cons n (cons orig-pos (buffer-substring start (point)))))) | |
| ;; If this run causes no change in buffer content, delete all spaces, | |
| ;; otherwise delete all excess spaces. | |
| (delete-region (if (and (eq mode 'fast) (zerop num) (= mid end)) | |
| start mid) end) | |
| (insert (make-string num ?\s)))) | |
| ;; Command run for the second time. | |
| ((not (equal orig-pos (point))) | |
| (delete-region (point) orig-pos)) | |
| ;; Command run for the third time. | |
| (t | |
| (insert (cddr cycle-spacing--context)) | |
| (goto-char (cadr cycle-spacing--context)) | |
| (setq cycle-spacing--context nil))))) | |
| (defun beginning-of-buffer (&optional arg) | |
| "Move point to the beginning of the buffer. | |
| With numeric arg N, put point N/10 of the way from the beginning. | |
| If the buffer is narrowed, this command uses the beginning of the | |
| accessible part of the buffer. | |
| Push mark at previous position, unless either a \\[universal-argument] prefix | |
| is supplied, or Transient Mark mode is enabled and the mark is active." | |
| (declare (interactive-only "use `(goto-char (point-min))' instead.")) | |
| (interactive "^P") | |
| (or (consp arg) | |
| (region-active-p) | |
| (push-mark)) | |
| (let ((size (- (point-max) (point-min)))) | |
| (goto-char (if (and arg (not (consp arg))) | |
| (+ (point-min) 1 | |
| (/ (* size (prefix-numeric-value arg)) 10)) | |
| (point-min)))) | |
| (if (and arg (not (consp arg))) (forward-line 1))) | |
| (defun end-of-buffer (&optional arg) | |
| "Move point to the end of the buffer. | |
| With numeric arg N, put point N/10 of the way from the end. | |
| If the buffer is narrowed, this command uses the end of the | |
| accessible part of the buffer. | |
| Push mark at previous position, unless either a \\[universal-argument] prefix | |
| is supplied, or Transient Mark mode is enabled and the mark is active." | |
| (declare (interactive-only "use `(goto-char (point-max))' instead.")) | |
| (interactive "^P") | |
| (or (consp arg) (region-active-p) (push-mark)) | |
| (let ((size (- (point-max) (point-min)))) | |
| (goto-char (if (and arg (not (consp arg))) | |
| (- (point-max) | |
| (/ (* size (prefix-numeric-value arg)) 10)) | |
| (point-max)))) | |
| ;; If we went to a place in the middle of the buffer, | |
| ;; adjust it to the beginning of a line. | |
| (cond ((and arg (not (consp arg))) (forward-line 1)) | |
| ((and (eq (current-buffer) (window-buffer)) | |
| (> (point) (window-end nil t))) | |
| ;; If the end of the buffer is not already on the screen, | |
| ;; then scroll specially to put it near, but not at, the bottom. | |
| (overlay-recenter (point)) | |
| (recenter -3)))) | |
| (defcustom delete-active-region t | |
| "Whether single-char deletion commands delete an active region. | |
| This has an effect only if Transient Mark mode is enabled, and | |
| affects `delete-forward-char' and `delete-backward-char', though | |
| not `delete-char'. | |
| If the value is the symbol `kill', the active region is killed | |
| instead of deleted." | |
| :type '(choice (const :tag "Delete active region" t) | |
| (const :tag "Kill active region" kill) | |
| (const :tag "Do ordinary deletion" nil)) | |
| :group 'killing | |
| :version "24.1") | |
| (setq region-extract-function | |
| (lambda (method) | |
| (when (region-beginning) | |
| (cond | |
| ((eq method 'bounds) | |
| (list (cons (region-beginning) (region-end)))) | |
| ((eq method 'delete-only) | |
| (delete-region (region-beginning) (region-end))) | |
| (t | |
| (filter-buffer-substring (region-beginning) (region-end) method)))))) | |
| (defvar region-insert-function | |
| (lambda (lines) | |
| (let ((first t)) | |
| (while lines | |
| (or first | |
| (insert ?\n)) | |
| (insert-for-yank (car lines)) | |
| (setq lines (cdr lines) | |
| first nil)))) | |
| "Function to insert the region's content. | |
| Called with one argument LINES. | |
| Insert the region as a list of lines.") | |
| (defun delete-backward-char (n &optional killflag) | |
| "Delete the previous N characters (following if N is negative). | |
| If Transient Mark mode is enabled, the mark is active, and N is 1, | |
| delete the text in the region and deactivate the mark instead. | |
| To disable this, set option `delete-active-region' to nil. | |
| Optional second arg KILLFLAG, if non-nil, means to kill (save in | |
| kill ring) instead of delete. If called interactively, a numeric | |
| prefix argument specifies N, and KILLFLAG is also set if a prefix | |
| argument is used. | |
| When killing, the killed text is filtered by | |
| `filter-buffer-substring' before it is saved in the kill ring, so | |
| the actual saved text might be different from what was killed. | |
| In Overwrite mode, single character backward deletion may replace | |
| tabs with spaces so as to back over columns, unless point is at | |
| the end of the line." | |
| (declare (interactive-only delete-char)) | |
| (interactive "p\nP") | |
| (unless (integerp n) | |
| (signal 'wrong-type-argument (list 'integerp n))) | |
| (cond ((and (use-region-p) | |
| delete-active-region | |
| (= n 1)) | |
| ;; If a region is active, kill or delete it. | |
| (if (eq delete-active-region 'kill) | |
| (kill-region (region-beginning) (region-end) 'region) | |
| (funcall region-extract-function 'delete-only))) | |
| ;; In Overwrite mode, maybe untabify while deleting | |
| ((null (or (null overwrite-mode) | |
| (<= n 0) | |
| (memq (char-before) '(?\t ?\n)) | |
| (eobp) | |
| (eq (char-after) ?\n))) | |
| (let ((ocol (current-column))) | |
| (delete-char (- n) killflag) | |
| (save-excursion | |
| (insert-char ?\s (- ocol (current-column)) nil)))) | |
| ;; Otherwise, do simple deletion. | |
| (t (delete-char (- n) killflag)))) | |
| (defun delete-forward-char (n &optional killflag) | |
| "Delete the following N characters (previous if N is negative). | |
| If Transient Mark mode is enabled, the mark is active, and N is 1, | |
| delete the text in the region and deactivate the mark instead. | |
| To disable this, set variable `delete-active-region' to nil. | |
| Optional second arg KILLFLAG non-nil means to kill (save in kill | |
| ring) instead of delete. If called interactively, a numeric | |
| prefix argument specifies N, and KILLFLAG is also set if a prefix | |
| argument is used. | |
| When killing, the killed text is filtered by | |
| `filter-buffer-substring' before it is saved in the kill ring, so | |
| the actual saved text might be different from what was killed." | |
| (declare (interactive-only delete-char)) | |
| (interactive "p\nP") | |
| (unless (integerp n) | |
| (signal 'wrong-type-argument (list 'integerp n))) | |
| (cond ((and (use-region-p) | |
| delete-active-region | |
| (= n 1)) | |
| ;; If a region is active, kill or delete it. | |
| (if (eq delete-active-region 'kill) | |
| (kill-region (region-beginning) (region-end) 'region) | |
| (funcall region-extract-function 'delete-only))) | |
| ;; Otherwise, do simple deletion. | |
| (t (delete-char n killflag)))) | |
| (defun mark-whole-buffer () | |
| "Put point at beginning and mark at end of buffer. | |
| Also push mark at point before pushing mark at end of buffer. | |
| If narrowing is in effect, uses only the accessible part of the buffer. | |
| You probably should not use this function in Lisp programs; | |
| it is usually a mistake for a Lisp function to use any subroutine | |
| that uses or sets the mark." | |
| (declare (interactive-only t)) | |
| (interactive) | |
| (push-mark) | |
| (push-mark (point-max) nil t) | |
| ;; This is really `point-min' in most cases, but if we're in the | |
| ;; minibuffer, this is at the end of the prompt. | |
| (goto-char (minibuffer-prompt-end))) | |
| ;; Counting lines, one way or another. | |
| (defvar goto-line-history nil | |
| "History of values entered with `goto-line'.") | |
| (make-variable-buffer-local 'goto-line-history) | |
| (defun goto-line (line &optional buffer) | |
| "Go to LINE, counting from line 1 at beginning of buffer. | |
| If called interactively, a numeric prefix argument specifies | |
| LINE; without a numeric prefix argument, read LINE from the | |
| minibuffer. | |
| If optional argument BUFFER is non-nil, switch to that buffer and | |
| move to line LINE there. If called interactively with \\[universal-argument] | |
| as argument, BUFFER is the most recently selected other buffer. | |
| Prior to moving point, this function sets the mark (without | |
| activating it), unless Transient Mark mode is enabled and the | |
| mark is already active. | |
| This function is usually the wrong thing to use in a Lisp program. | |
| What you probably want instead is something like: | |
| (goto-char (point-min)) | |
| (forward-line (1- N)) | |
| If at all possible, an even better solution is to use char counts | |
| rather than line counts." | |
| (declare (interactive-only forward-line)) | |
| (interactive | |
| (if (and current-prefix-arg (not (consp current-prefix-arg))) | |
| (list (prefix-numeric-value current-prefix-arg)) | |
| ;; Look for a default, a number in the buffer at point. | |
| (let* ((default | |
| (save-excursion | |
| (skip-chars-backward "0-9") | |
| (if (looking-at "[0-9]") | |
| (string-to-number | |
| (buffer-substring-no-properties | |
| (point) | |
| (progn (skip-chars-forward "0-9") | |
| (point))))))) | |
| ;; Decide if we're switching buffers. | |
| (buffer | |
| (if (consp current-prefix-arg) | |
| (other-buffer (current-buffer) t))) | |
| (buffer-prompt | |
| (if buffer | |
| (concat " in " (buffer-name buffer)) | |
| ""))) | |
| ;; Read the argument, offering that number (if any) as default. | |
| (list (read-number (format "Goto line%s: " buffer-prompt) | |
| (list default (line-number-at-pos)) | |
| 'goto-line-history) | |
| buffer)))) | |
| ;; Switch to the desired buffer, one way or another. | |
| (if buffer | |
| (let ((window (get-buffer-window buffer))) | |
| (if window (select-window window) | |
| (switch-to-buffer-other-window buffer)))) | |
| ;; Leave mark at previous position | |
| (or (region-active-p) (push-mark)) | |
| ;; Move to the specified line number in that buffer. | |
| (save-restriction | |
| (widen) | |
| (goto-char (point-min)) | |
| (if (eq selective-display t) | |
| (re-search-forward "[\n\C-m]" nil 'end (1- line)) | |
| (forward-line (1- line))))) | |
| (defun count-words-region (start end &optional arg) | |
| "Count the number of words in the region. | |
| If called interactively, print a message reporting the number of | |
| lines, words, and characters in the region (whether or not the | |
| region is active); with prefix ARG, report for the entire buffer | |
| rather than the region. | |
| If called from Lisp, return the number of words between positions | |
| START and END." | |
| (interactive (if current-prefix-arg | |
| (list nil nil current-prefix-arg) | |
| (list (region-beginning) (region-end) nil))) | |
| (cond ((not (called-interactively-p 'any)) | |
| (count-words start end)) | |
| (arg | |
| (count-words--buffer-message)) | |
| (t | |
| (count-words--message "Region" start end)))) | |
| (defun count-words (start end) | |
| "Count words between START and END. | |
| If called interactively, START and END are normally the start and | |
| end of the buffer; but if the region is active, START and END are | |
| the start and end of the region. Print a message reporting the | |
| number of lines, words, and chars. | |
| If called from Lisp, return the number of words between START and | |
| END, without printing any message." | |
| (interactive (list nil nil)) | |
| (cond ((not (called-interactively-p 'any)) | |
| (let ((words 0)) | |
| (save-excursion | |
| (save-restriction | |
| (narrow-to-region start end) | |
| (goto-char (point-min)) | |
| (while (forward-word-strictly 1) | |
| (setq words (1+ words))))) | |
| words)) | |
| ((use-region-p) | |
| (call-interactively 'count-words-region)) | |
| (t | |
| (count-words--buffer-message)))) | |
| (defun count-words--buffer-message () | |
| (count-words--message | |
| (if (buffer-narrowed-p) "Narrowed part of buffer" "Buffer") | |
| (point-min) (point-max))) | |
| (defun count-words--message (str start end) | |
| (let ((lines (count-lines start end)) | |
| (words (count-words start end)) | |
| (chars (- end start))) | |
| (message "%s has %d line%s, %d word%s, and %d character%s." | |
| str | |
| lines (if (= lines 1) "" "s") | |
| words (if (= words 1) "" "s") | |
| chars (if (= chars 1) "" "s")))) | |
| (define-obsolete-function-alias 'count-lines-region 'count-words-region "24.1") | |
| (defun what-line () | |
| "Print the current buffer line number and narrowed line number of point." | |
| (interactive) | |
| (let ((start (point-min)) | |
| (n (line-number-at-pos))) | |
| (if (= start 1) | |
| (message "Line %d" n) | |
| (save-excursion | |
| (save-restriction | |
| (widen) | |
| (message "line %d (narrowed line %d)" | |
| (+ n (line-number-at-pos start) -1) n)))))) | |
| (defun count-lines (start end) | |
| "Return number of lines between START and END. | |
| This is usually the number of newlines between them, | |
| but can be one more if START is not equal to END | |
| and the greater of them is not at the start of a line." | |
| (save-excursion | |
| (save-restriction | |
| (narrow-to-region start end) | |
| (goto-char (point-min)) | |
| (if (eq selective-display t) | |
| (save-match-data | |
| (let ((done 0)) | |
| (while (re-search-forward "[\n\C-m]" nil t 40) | |
| (setq done (+ 40 done))) | |
| (while (re-search-forward "[\n\C-m]" nil t 1) | |
| (setq done (+ 1 done))) | |
| (goto-char (point-max)) | |
| (if (and (/= start end) | |
| (not (bolp))) | |
| (1+ done) | |
| done))) | |
| (- (buffer-size) (forward-line (buffer-size))))))) | |
| (defun line-number-at-pos (&optional pos absolute) | |
| "Return buffer line number at position POS. | |
| If POS is nil, use current buffer location. | |
| If ABSOLUTE is nil, the default, counting starts | |
| at (point-min), so the value refers to the contents of the | |
| accessible portion of the (potentially narrowed) buffer. If | |
| ABSOLUTE is non-nil, ignore any narrowing and return the | |
| absolute line number." | |
| (save-restriction | |
| (when absolute | |
| (widen)) | |
| (let ((opoint (or pos (point))) start) | |
| (save-excursion | |
| (goto-char (point-min)) | |
| (setq start (point)) | |
| (goto-char opoint) | |
| (forward-line 0) | |
| (1+ (count-lines start (point))))))) | |
| (defcustom what-cursor-show-names nil | |
| "Whether to show character names in `what-cursor-position'." | |
| :type 'boolean | |
| :version "27.1" | |
| :group 'editing-basics) | |
| (defun what-cursor-position (&optional detail) | |
| "Print info on cursor position (on screen and within buffer). | |
| Also describe the character after point, and give its character | |
| code in octal, decimal and hex. If `what-cursor-show-names' is | |
| non-nil, additionally show the name of the character. | |
| For a non-ASCII multibyte character, also give its encoding in the | |
| buffer's selected coding system if the coding system encodes the | |
| character safely. If the character is encoded into one byte, that | |
| code is shown in hex. If the character is encoded into more than one | |
| byte, just \"...\" is shown. | |
| In addition, with prefix argument, show details about that character | |
| in *Help* buffer. See also the command `describe-char'." | |
| (interactive "P") | |
| (let* ((char (following-char)) | |
| (char-name (and what-cursor-show-names | |
| (or (get-char-code-property char 'name) | |
| (get-char-code-property char 'old-name)))) | |
| (char-name-fmt (if char-name | |
| (format ", %s" char-name) | |
| "")) | |
| (bidi-fixer | |
| ;; If the character is one of LRE, LRO, RLE, RLO, it will | |
| ;; start a directional embedding, which could completely | |
| ;; disrupt the rest of the line (e.g., RLO will display the | |
| ;; rest of the line right-to-left). So we put an invisible | |
| ;; PDF character after these characters, to end the | |
| ;; embedding, which eliminates any effects on the rest of | |
| ;; the line. For RLE and RLO we also append an invisible | |
| ;; LRM, to avoid reordering the following numerical | |
| ;; characters. For LRI/RLI/FSI we append a PDI. | |
| (cond ((memq char '(?\x202a ?\x202d)) | |
| (propertize (string ?\x202c) 'invisible t)) | |
| ((memq char '(?\x202b ?\x202e)) | |
| (propertize (string ?\x202c ?\x200e) 'invisible t)) | |
| ((memq char '(?\x2066 ?\x2067 ?\x2068)) | |
| (propertize (string ?\x2069) 'invisible t)) | |
| ;; Strong right-to-left characters cause reordering of | |
| ;; the following numerical characters which show the | |
| ;; codepoint, so append LRM to countermand that. | |
| ((memq (get-char-code-property char 'bidi-class) '(R AL)) | |
| (propertize (string ?\x200e) 'invisible t)) | |
| (t | |
| ""))) | |
| (beg (point-min)) | |
| (end (point-max)) | |
| (pos (point)) | |
| (total (buffer-size)) | |
| (percent (round (* 100.0 (1- pos)) (max 1 total))) | |
| (hscroll (if (= (window-hscroll) 0) | |
| "" | |
| (format " Hscroll=%d" (window-hscroll)))) | |
| (col (current-column))) | |
| (if (= pos end) | |
| (if (or (/= beg 1) (/= end (1+ total))) | |
| (message "point=%d of %d (%d%%) <%d-%d> column=%d%s" | |
| pos total percent beg end col hscroll) | |
| (message "point=%d of %d (EOB) column=%d%s" | |
| pos total col hscroll)) | |
| (let ((coding buffer-file-coding-system) | |
| encoded encoding-msg display-prop under-display) | |
| (if (or (not coding) | |
| (eq (coding-system-type coding) t)) | |
| (setq coding (default-value 'buffer-file-coding-system))) | |
| (if (eq (char-charset char) 'eight-bit) | |
| (setq encoding-msg | |
| (format "(%d, #o%o, #x%x%s, raw-byte)" char char char char-name-fmt)) | |
| ;; Check if the character is displayed with some `display' | |
| ;; text property. In that case, set under-display to the | |
| ;; buffer substring covered by that property. | |
| (setq display-prop (get-char-property pos 'display)) | |
| (if display-prop | |
| (let ((to (or (next-single-char-property-change pos 'display) | |
| (point-max)))) | |
| (if (< to (+ pos 4)) | |
| (setq under-display "") | |
| (setq under-display "..." | |
| to (+ pos 4))) | |
| (setq under-display | |
| (concat (buffer-substring-no-properties pos to) | |
| under-display))) | |
| (setq encoded (and (>= char 128) (encode-coding-char char coding)))) | |
| (setq encoding-msg | |
| (if display-prop | |
| (if (not (stringp display-prop)) | |
| (format "(%d, #o%o, #x%x%s, part of display \"%s\")" | |
| char char char char-name-fmt under-display) | |
| (format "(%d, #o%o, #x%x%s, part of display \"%s\"->\"%s\")" | |
| char char char char-name-fmt under-display display-prop)) | |
| (if encoded | |
| (format "(%d, #o%o, #x%x%s, file %s)" | |
| char char char char-name-fmt | |
| (if (> (length encoded) 1) | |
| "..." | |
| (encoded-string-description encoded coding))) | |
| (format "(%d, #o%o, #x%x%s)" char char char char-name-fmt))))) | |
| (if detail | |
| ;; We show the detailed information about CHAR. | |
| (describe-char (point))) | |
| (if (or (/= beg 1) (/= end (1+ total))) | |
| (message "Char: %s%s %s point=%d of %d (%d%%) <%d-%d> column=%d%s" | |
| (if (< char 256) | |
| (single-key-description char) | |
| (buffer-substring-no-properties (point) (1+ (point)))) | |
| bidi-fixer | |
| encoding-msg pos total percent beg end col hscroll) | |
| (message "Char: %s%s %s point=%d of %d (%d%%) column=%d%s" | |
| (if enable-multibyte-characters | |
| (if (< char 128) | |
| (single-key-description char) | |
| (buffer-substring-no-properties (point) (1+ (point)))) | |
| (single-key-description char)) | |
| bidi-fixer encoding-msg pos total percent col hscroll)))))) | |
| ;; Initialize read-expression-map. It is defined at C level. | |
| (defvar read-expression-map | |
| (let ((m (make-sparse-keymap))) | |
| (define-key m "\M-\t" 'completion-at-point) | |
| ;; Might as well bind TAB to completion, since inserting a TAB char is | |
| ;; much too rarely useful. | |
| (define-key m "\t" 'completion-at-point) | |
| (set-keymap-parent m minibuffer-local-map) | |
| m)) | |
| (defun read-minibuffer (prompt &optional initial-contents) | |
| "Return a Lisp object read using the minibuffer, unevaluated. | |
| Prompt with PROMPT. If non-nil, optional second arg INITIAL-CONTENTS | |
| is a string to insert in the minibuffer before reading. | |
| \(INITIAL-CONTENTS can also be a cons of a string and an integer. | |
| Such arguments are used as in `read-from-minibuffer'.)" | |
| ;; Used for interactive spec `x'. | |
| (read-from-minibuffer prompt initial-contents minibuffer-local-map | |
| t 'minibuffer-history)) | |
| (defun eval-minibuffer (prompt &optional initial-contents) | |
| "Return value of Lisp expression read using the minibuffer. | |
| Prompt with PROMPT. If non-nil, optional second arg INITIAL-CONTENTS | |
| is a string to insert in the minibuffer before reading. | |
| \(INITIAL-CONTENTS can also be a cons of a string and an integer. | |
| Such arguments are used as in `read-from-minibuffer'.)" | |
| ;; Used for interactive spec `X'. | |
| (eval (read--expression prompt initial-contents))) | |
| (defvar minibuffer-completing-symbol nil | |
| "Non-nil means completing a Lisp symbol in the minibuffer.") | |
| (make-obsolete-variable 'minibuffer-completing-symbol nil "24.1" 'get) | |
| (defvar minibuffer-default nil | |
| "The current default value or list of default values in the minibuffer. | |
| The functions `read-from-minibuffer' and `completing-read' bind | |
| this variable locally.") | |
| (defcustom eval-expression-print-level 4 | |
| "Value for `print-level' while printing value in `eval-expression'. | |
| A value of nil means no limit." | |
| :group 'lisp | |
| :type '(choice (const :tag "No Limit" nil) integer) | |
| :version "21.1") | |
| (defcustom eval-expression-print-length 12 | |
| "Value for `print-length' while printing value in `eval-expression'. | |
| A value of nil means no limit." | |
| :group 'lisp | |
| :type '(choice (const :tag "No Limit" nil) integer) | |
| :version "21.1") | |
| (defcustom eval-expression-debug-on-error t | |
| "If non-nil set `debug-on-error' to t in `eval-expression'. | |
| If nil, don't change the value of `debug-on-error'." | |
| :group 'lisp | |
| :type 'boolean | |
| :version "21.1") | |
| (defcustom eval-expression-print-maximum-character 127 | |
| "The largest integer that will be displayed as a character. | |
| This affects printing by `eval-expression' (via | |
| `eval-expression-print-format')." | |
| :group 'lisp | |
| :type `(choice (const :tag "ASCII characters" 127) | |
| (const :tag "All characters" ,(max-char)) | |
| (integer :tag "Max codepoint to display as character")) | |
| :version "26.1") | |
| (defun eval-expression-print-format (value) | |
| "If VALUE is an integer, return a specially formatted string. | |
| This string will typically look like \" (#o1, #x1, ?\\C-a)\". | |
| If VALUE is not an integer, return nil. | |
| This function is used by commands like `eval-expression' that | |
| display the result of expression evaluation." | |
| (when (integerp value) | |
| (let ((char-string | |
| (and (characterp value) | |
| (<= value eval-expression-print-maximum-character) | |
| (char-displayable-p value) | |
| (prin1-char value)))) | |
| (if char-string | |
| (format " (#o%o, #x%x, %s)" value value char-string) | |
| (format " (#o%o, #x%x)" value value))))) | |
| (defvar eval-expression-minibuffer-setup-hook nil | |
| "Hook run by `eval-expression' when entering the minibuffer.") | |
| (defun read--expression (prompt &optional initial-contents) | |
| (let ((minibuffer-completing-symbol t)) | |
| (minibuffer-with-setup-hook | |
| (lambda () | |
| ;; FIXME: call emacs-lisp-mode (see also | |
| ;; `eldoc--eval-expression-setup')? | |
| (add-hook 'completion-at-point-functions | |
| #'elisp-completion-at-point nil t) | |
| (run-hooks 'eval-expression-minibuffer-setup-hook)) | |
| (read-from-minibuffer prompt initial-contents | |
| read-expression-map t | |
| 'read-expression-history)))) | |
| (defun eval-expression-get-print-arguments (prefix-argument) | |
| "Get arguments for commands that print an expression result. | |
| Returns a list (INSERT-VALUE NO-TRUNCATE CHAR-PRINT-LIMIT) | |
| based on PREFIX-ARG. This function determines the interpretation | |
| of the prefix argument for `eval-expression' and | |
| `eval-last-sexp'." | |
| (let ((num (prefix-numeric-value prefix-argument))) | |
| (list (not (memq prefix-argument '(- nil))) | |
| (= num 0) | |
| (cond ((not (memq prefix-argument '(0 -1 - nil))) nil) | |
| ((= num -1) most-positive-fixnum) | |
| (t eval-expression-print-maximum-character))))) | |
| ;; We define this, rather than making `eval' interactive, | |
| ;; for the sake of completion of names like eval-region, eval-buffer. | |
| (defun eval-expression (exp &optional insert-value no-truncate char-print-limit) | |
| "Evaluate EXP and print value in the echo area. | |
| When called interactively, read an Emacs Lisp expression and | |
| evaluate it. Value is also consed on to front of the variable | |
| `values'. Optional argument INSERT-VALUE non-nil (interactively, | |
| with a non `-' prefix argument) means insert the result into the | |
| current buffer instead of printing it in the echo area. | |
| Normally, this function truncates long output according to the | |
| value of the variables `eval-expression-print-length' and | |
| `eval-expression-print-level'. When NO-TRUNCATE is | |
| non-nil (interactively, with a prefix argument of zero), however, | |
| there is no such truncation. | |
| If the resulting value is an integer, and CHAR-PRINT-LIMIT is | |
| non-nil (interactively, unless given a non-zero prefix argument) | |
| it will be printed in several additional formats (octal, | |
| hexadecimal, and character). The character format is used only | |
| if the value is below CHAR-PRINT-LIMIT (interactively, if the | |
| prefix argument is -1 or the value doesn't exceed | |
| `eval-expression-print-maximum-character'). | |
| Runs the hook `eval-expression-minibuffer-setup-hook' on entering the | |
| minibuffer. | |
| If `eval-expression-debug-on-error' is non-nil, which is the default, | |
| this command arranges for all errors to enter the debugger." | |
| (interactive | |
| (cons (read--expression "Eval: ") | |
| (eval-expression-get-print-arguments current-prefix-arg))) | |
| (if (null eval-expression-debug-on-error) | |
| (push (eval (let ((lexical-binding t)) (macroexpand-all exp)) t) | |
| values) | |
| (let ((old-value (make-symbol "t")) new-value) | |
| ;; Bind debug-on-error to something unique so that we can | |
| ;; detect when evalled code changes it. | |
| (let ((debug-on-error old-value)) | |
| (push (eval (let ((lexical-binding t)) (macroexpand-all exp)) t) | |
| values) | |
| (setq new-value debug-on-error)) | |
| ;; If evalled code has changed the value of debug-on-error, | |
| ;; propagate that change to the global binding. | |
| (unless (eq old-value new-value) | |
| (setq debug-on-error new-value)))) | |
| (let ((print-length (unless no-truncate eval-expression-print-length)) | |
| (print-level (unless no-truncate eval-expression-print-level)) | |
| (eval-expression-print-maximum-character char-print-limit) | |
| (deactivate-mark)) | |
| (let ((out (if insert-value (current-buffer) t))) | |
| (prog1 | |
| (prin1 (car values) out) | |
| (let ((str (and char-print-limit | |
| (eval-expression-print-format (car values))))) | |
| (when str (princ str out))))))) | |
| (defun edit-and-eval-command (prompt command) | |
| "Prompting with PROMPT, let user edit COMMAND and eval result. | |
| COMMAND is a Lisp expression. Let user edit that expression in | |
| the minibuffer, then read and evaluate the result." | |
| (let ((command | |
| (let ((print-level nil) | |
| (minibuffer-history-sexp-flag (1+ (minibuffer-depth)))) | |
| (unwind-protect | |
| (read-from-minibuffer prompt | |
| (prin1-to-string command) | |
| read-expression-map t | |
| 'command-history) | |
| ;; If command was added to command-history as a string, | |
| ;; get rid of that. We want only evaluable expressions there. | |
| (when (stringp (car command-history)) | |
| (pop command-history)))))) | |
| (add-to-history 'command-history command) | |
| (eval command))) | |
| (defun repeat-complex-command (arg) | |
| "Edit and re-evaluate last complex command, or ARGth from last. | |
| A complex command is one that used the minibuffer. | |
| The command is placed in the minibuffer as a Lisp form for editing. | |
| The result is executed, repeating the command as changed. | |
| If the command has been changed or is not the most recent previous | |
| command it is added to the front of the command history. | |
| You can use the minibuffer history commands \ | |
| \\<minibuffer-local-map>\\[next-history-element] and \\[previous-history-element] | |
| to get different commands to edit and resubmit." | |
| (interactive "p") | |
| (let ((elt (nth (1- arg) command-history)) | |
| newcmd) | |
| (if elt | |
| (progn | |
| (setq newcmd | |
| (let ((print-level nil) | |
| (minibuffer-history-position arg) | |
| (minibuffer-history-sexp-flag (1+ (minibuffer-depth)))) | |
| (unwind-protect | |
| (read-from-minibuffer | |
| "Redo: " (prin1-to-string elt) read-expression-map t | |
| (cons 'command-history arg)) | |
| ;; If command was added to command-history as a | |
| ;; string, get rid of that. We want only | |
| ;; evaluable expressions there. | |
| (when (stringp (car command-history)) | |
| (pop command-history))))) | |
| (add-to-history 'command-history newcmd) | |
| (apply #'funcall-interactively | |
| (car newcmd) | |
| (mapcar (lambda (e) (eval e t)) (cdr newcmd)))) | |
| (if command-history | |
| (error "Argument %d is beyond length of command history" arg) | |
| (error "There are no previous complex commands to repeat"))))) | |
| (defvar extended-command-history nil) | |
| (defvar execute-extended-command--last-typed nil) | |
| (defun read-extended-command () | |
| "Read command name to invoke in `execute-extended-command'." | |
| (minibuffer-with-setup-hook | |
| (lambda () | |
| (add-hook 'post-self-insert-hook | |
| (lambda () | |
| (setq execute-extended-command--last-typed | |
| (minibuffer-contents))) | |
| nil 'local) | |
| (set (make-local-variable 'minibuffer-default-add-function) | |
| (lambda () | |
| ;; Get a command name at point in the original buffer | |
| ;; to propose it after M-n. | |
| (with-current-buffer (window-buffer (minibuffer-selected-window)) | |
| (and (commandp (function-called-at-point)) | |
| (format "%S" (function-called-at-point))))))) | |
| ;; Read a string, completing from and restricting to the set of | |
| ;; all defined commands. Don't provide any initial input. | |
| ;; Save the command read on the extended-command history list. | |
| (completing-read | |
| (concat (cond | |
| ((eq current-prefix-arg '-) "- ") | |
| ((and (consp current-prefix-arg) | |
| (eq (car current-prefix-arg) 4)) "C-u ") | |
| ((and (consp current-prefix-arg) | |
| (integerp (car current-prefix-arg))) | |
| (format "%d " (car current-prefix-arg))) | |
| ((integerp current-prefix-arg) | |
| (format "%d " current-prefix-arg))) | |
| ;; This isn't strictly correct if `execute-extended-command' | |
| ;; is bound to anything else (e.g. [menu]). | |
| ;; It could use (key-description (this-single-command-keys)), | |
| ;; but actually a prompt other than "M-x" would be confusing, | |
| ;; because "M-x" is a well-known prompt to read a command | |
| ;; and it serves as a shorthand for "Extended command: ". | |
| "M-x ") | |
| (lambda (string pred action) | |
| (if (and suggest-key-bindings (eq action 'metadata)) | |
| '(metadata | |
| (annotation-function . read-extended-command--annotation) | |
| (category . command)) | |
| (let ((pred | |
| (if (memq action '(nil t)) | |
| ;; Exclude obsolete commands from completions. | |
| (lambda (sym) | |
| (and (funcall pred sym) | |
| (or (equal string (symbol-name sym)) | |
| (not (get sym 'byte-obsolete-info))))) | |
| pred))) | |
| (complete-with-action action obarray string pred)))) | |
| #'commandp t nil 'extended-command-history))) | |
| (defun read-extended-command--annotation (command-name) | |
| (let* ((function (and (stringp command-name) (intern-soft command-name))) | |
| (binding (where-is-internal function overriding-local-map t))) | |
| (when (and binding (not (stringp binding))) | |
| (format " (%s)" (key-description binding))))) | |
| (defcustom suggest-key-bindings t | |
| "Non-nil means show the equivalent key-binding when M-x command has one. | |
| The value can be a length of time to show the message for. | |
| If the value is non-nil and not a number, we wait 2 seconds. | |
| Also see `extended-command-suggest-shorter'. | |
| Equivalent key-bindings are also shown in the completion list of | |
| M-x for all commands that have them." | |
| :group 'keyboard | |
| :type '(choice (const :tag "off" nil) | |
| (integer :tag "time" 2) | |
| (other :tag "on"))) | |
| (defcustom extended-command-suggest-shorter t | |
| "If non-nil, show a shorter M-x invocation when there is one. | |
| Also see `suggest-key-bindings'." | |
| :group 'keyboard | |
| :type 'boolean | |
| :version "26.1") | |
| (defun execute-extended-command--shorter-1 (name length) | |
| (cond | |
| ((zerop length) (list "")) | |
| ((equal name "") nil) | |
| (t | |
| (nconc (mapcar (lambda (s) (concat (substring name 0 1) s)) | |
| (execute-extended-command--shorter-1 | |
| (substring name 1) (1- length))) | |
| (when (string-match "\\`\\(-\\)?[^-]*" name) | |
| (execute-extended-command--shorter-1 | |
| (substring name (match-end 0)) length)))))) | |
| (defun execute-extended-command--shorter (name typed) | |
| (let ((candidates '()) | |
| (max (length typed)) | |
| (len 1) | |
| binding) | |
| (while (and (not binding) | |
| (progn | |
| (unless candidates | |
| (setq len (1+ len)) | |
| (setq candidates (execute-extended-command--shorter-1 | |
| name len))) | |
| ;; Don't show the help message if the binding isn't | |
| ;; significantly shorter than the M-x command the user typed. | |
| (< len (- max 5)))) | |
| (input-pending-p) ;Dummy call to trigger input-processing, bug#23002. | |
| (let ((candidate (pop candidates))) | |
| (when (equal name | |
| (car-safe (completion-try-completion | |
| candidate obarray 'commandp len))) | |
| (setq binding candidate)))) | |
| binding)) | |
| (defun execute-extended-command (prefixarg &optional command-name typed) | |
| ;; Based on Fexecute_extended_command in keyboard.c of Emacs. | |
| ;; Aaron S. Hawley <aaron.s.hawley(at)gmail.com> 2009-08-24 | |
| "Read a command name, then read the arguments and call the command. | |
| To pass a prefix argument to the command you are | |
| invoking, give a prefix argument to `execute-extended-command'." | |
| (declare (interactive-only command-execute)) | |
| ;; FIXME: Remember the actual text typed by the user before completion, | |
| ;; so that we don't later on suggest the same shortening. | |
| (interactive | |
| (let ((execute-extended-command--last-typed nil)) | |
| (list current-prefix-arg | |
| (read-extended-command) | |
| execute-extended-command--last-typed))) | |
| ;; Emacs<24 calling-convention was with a single `prefixarg' argument. | |
| (unless command-name | |
| (let ((current-prefix-arg prefixarg) ; for prompt | |
| (execute-extended-command--last-typed nil)) | |
| (setq command-name (read-extended-command)) | |
| (setq typed execute-extended-command--last-typed))) | |
| (let* ((function (and (stringp command-name) (intern-soft command-name))) | |
| (binding (and suggest-key-bindings | |
| (not executing-kbd-macro) | |
| (where-is-internal function overriding-local-map t)))) | |
| (unless (commandp function) | |
| (error "`%s' is not a valid command name" command-name)) | |
| ;; Some features, such as novice.el, rely on this-command-keys | |
| ;; including M-x COMMAND-NAME RET. | |
| (set--this-command-keys (concat "\M-x" (symbol-name function) "\r")) | |
| (setq this-command function) | |
| ;; Normally `real-this-command' should never be changed, but here we really | |
| ;; want to pretend that M-x <cmd> RET is nothing more than a "key | |
| ;; binding" for <cmd>, so the command the user really wanted to run is | |
| ;; `function' and not `execute-extended-command'. The difference is | |
| ;; visible in cases such as M-x <cmd> RET and then C-x z (bug#11506). | |
| (setq real-this-command function) | |
| (let ((prefix-arg prefixarg)) | |
| (command-execute function 'record)) | |
| ;; If enabled, show which key runs this command. | |
| ;; But first wait, and skip the message if there is input. | |
| (let* ((waited | |
| ;; If this command displayed something in the echo area; | |
| ;; wait a few seconds, then display our suggestion message. | |
| ;; FIXME: Wait *after* running post-command-hook! | |
| ;; FIXME: If execute-extended-command--shorter were | |
| ;; faster, we could compute the result here first too. | |
| (when (and suggest-key-bindings | |
| (or binding | |
| (and extended-command-suggest-shorter typed))) | |
| (sit-for (cond | |
| ((zerop (length (current-message))) 0) | |
| ((numberp suggest-key-bindings) suggest-key-bindings) | |
| (t 2)))))) | |
| (when (and waited (not (consp unread-command-events))) | |
| (unless (or (not extended-command-suggest-shorter) | |
| binding executing-kbd-macro (not (symbolp function)) | |
| (<= (length (symbol-name function)) 2)) | |
| ;; There's no binding for CMD. Let's try and find the shortest | |
| ;; string to use in M-x. | |
| ;; FIXME: Can be slow. Cache it maybe? | |
| (while-no-input | |
| (setq binding (execute-extended-command--shorter | |
| (symbol-name function) typed)))) | |
| (when binding | |
| (with-temp-message | |
| (format-message "You can run the command `%s' with %s" | |
| function | |
| (if (stringp binding) | |
| (concat "M-x " binding " RET") | |
| (key-description binding))) | |
| (sit-for (if (numberp suggest-key-bindings) | |
| suggest-key-bindings | |
| 2)))))))) | |
| (defun command-execute (cmd &optional record-flag keys special) | |
| ;; BEWARE: Called directly from the C code. | |
| "Execute CMD as an editor command. | |
| CMD must be a symbol that satisfies the `commandp' predicate. | |
| Optional second arg RECORD-FLAG non-nil | |
| means unconditionally put this command in the variable `command-history'. | |
| Otherwise, that is done only if an arg is read using the minibuffer. | |
| The argument KEYS specifies the value to use instead of (this-command-keys) | |
| when reading the arguments; if it is nil, (this-command-keys) is used. | |
| The argument SPECIAL, if non-nil, means that this command is executing | |
| a special event, so ignore the prefix argument and don't clear it." | |
| (setq debug-on-next-call nil) | |
| (let ((prefixarg (unless special | |
| ;; FIXME: This should probably be done around | |
| ;; pre-command-hook rather than here! | |
| (prog1 prefix-arg | |
| (setq current-prefix-arg prefix-arg) | |
| (setq prefix-arg nil) | |
| (when current-prefix-arg | |
| (prefix-command-update)))))) | |
| (if (and (symbolp cmd) | |
| (get cmd 'disabled) | |
| disabled-command-function) | |
| ;; FIXME: Weird calling convention! | |
| (run-hooks 'disabled-command-function) | |
| (let ((final cmd)) | |
| (while | |
| (progn | |
| (setq final (indirect-function final)) | |
| (if (autoloadp final) | |
| (setq final (autoload-do-load final cmd))))) | |
| (cond | |
| ((arrayp final) | |
| ;; If requested, place the macro in the command history. For | |
| ;; other sorts of commands, call-interactively takes care of this. | |
| (when record-flag | |
| (add-to-history | |
| 'command-history `(execute-kbd-macro ,final ,prefixarg) nil t)) | |
| (execute-kbd-macro final prefixarg)) | |
| (t | |
| ;; Pass `cmd' rather than `final', for the backtrace's sake. | |
| (prog1 (call-interactively cmd record-flag keys) | |
| (when (and (symbolp cmd) | |
| (get cmd 'byte-obsolete-info) | |
| (not (get cmd 'command-execute-obsolete-warned))) | |
| (put cmd 'command-execute-obsolete-warned t) | |
| (message "%s" (macroexp--obsolete-warning | |
| cmd (get cmd 'byte-obsolete-info) "command")))))))))) | |
| (defvar minibuffer-history nil | |
| "Default minibuffer history list. | |
| This is used for all minibuffer input | |
| except when an alternate history list is specified. | |
| Maximum length of the history list is determined by the value | |
| of `history-length', which see.") | |
| (defvar minibuffer-history-sexp-flag nil | |
| "Control whether history list elements are expressions or strings. | |
| If the value of this variable equals current minibuffer depth, | |
| they are expressions; otherwise they are strings. | |
| \(That convention is designed to do the right thing for | |
| recursive uses of the minibuffer.)") | |
| (setq minibuffer-history-variable 'minibuffer-history) | |
| (setq minibuffer-history-position nil) ;; Defvar is in C code. | |
| (defvar minibuffer-history-search-history nil) | |
| (defvar minibuffer-text-before-history nil | |
| "Text that was in this minibuffer before any history commands. | |
| This is nil if there have not yet been any history commands | |
| in this use of the minibuffer.") | |
| (add-hook 'minibuffer-setup-hook 'minibuffer-history-initialize) | |
| (defun minibuffer-history-initialize () | |
| (setq minibuffer-text-before-history nil)) | |
| (defun minibuffer-avoid-prompt (_new _old) | |
| "A point-motion hook for the minibuffer, that moves point out of the prompt." | |
| (declare (obsolete cursor-intangible-mode "25.1")) | |
| (constrain-to-field nil (point-max))) | |
| (defcustom minibuffer-history-case-insensitive-variables nil | |
| "Minibuffer history variables for which matching should ignore case. | |
| If a history variable is a member of this list, then the | |
| \\[previous-matching-history-element] and \\[next-matching-history-element]\ | |
| commands ignore case when searching it, regardless of `case-fold-search'." | |
| :type '(repeat variable) | |
| :group 'minibuffer) | |
| (defun previous-matching-history-element (regexp n) | |
| "Find the previous history element that matches REGEXP. | |
| \(Previous history elements refer to earlier actions.) | |
| With prefix argument N, search for Nth previous match. | |
| If N is negative, find the next or Nth next match. | |
| Normally, history elements are matched case-insensitively if | |
| `case-fold-search' is non-nil, but an uppercase letter in REGEXP | |
| makes the search case-sensitive. | |
| See also `minibuffer-history-case-insensitive-variables'." | |
| (interactive | |
| (let* ((enable-recursive-minibuffers t) | |
| (regexp (read-from-minibuffer | |
| (format "Previous element matching regexp%s: " | |
| (if minibuffer-history-search-history | |
| (format " (default %s)" | |
| (car minibuffer-history-search-history)) | |
| "")) | |
| nil minibuffer-local-map nil | |
| 'minibuffer-history-search-history | |
| (car minibuffer-history-search-history)))) | |
| ;; Use the last regexp specified, by default, if input is empty. | |
| (list (if (string= regexp "") | |
| (if minibuffer-history-search-history | |
| (car minibuffer-history-search-history) | |
| (user-error "No previous history search regexp")) | |
| regexp) | |
| (prefix-numeric-value current-prefix-arg)))) | |
| (unless (zerop n) | |
| (if (and (zerop minibuffer-history-position) | |
| (null minibuffer-text-before-history)) | |
| (setq minibuffer-text-before-history | |
| (minibuffer-contents-no-properties))) | |
| (let ((history (minibuffer-history-value)) | |
| (case-fold-search | |
| (if (isearch-no-upper-case-p regexp t) ; assume isearch.el is dumped | |
| ;; On some systems, ignore case for file names. | |
| (if (memq minibuffer-history-variable | |
| minibuffer-history-case-insensitive-variables) | |
| t | |
| ;; Respect the user's setting for case-fold-search: | |
| case-fold-search) | |
| nil)) | |
| prevpos | |
| match-string | |
| match-offset | |
| (pos minibuffer-history-position)) | |
| (while (/= n 0) | |
| (setq prevpos pos) | |
| (setq pos (min (max 1 (+ pos (if (< n 0) -1 1))) (length history))) | |
| (when (= pos prevpos) | |
| (user-error (if (= pos 1) | |
| "No later matching history item" | |
| "No earlier matching history item"))) | |
| (setq match-string | |
| (if (eq minibuffer-history-sexp-flag (minibuffer-depth)) | |
| (let ((print-level nil)) | |
| (prin1-to-string (nth (1- pos) history))) | |
| (nth (1- pos) history))) | |
| (setq match-offset | |
| (if (< n 0) | |
| (and (string-match regexp match-string) | |
| (match-end 0)) | |
| (and (string-match (concat ".*\\(" regexp "\\)") match-string) | |
| (match-beginning 1)))) | |
| (when match-offset | |
| (setq n (+ n (if (< n 0) 1 -1))))) | |
| (setq minibuffer-history-position pos) | |
| (goto-char (point-max)) | |
| (delete-minibuffer-contents) | |
| (insert match-string) | |
| (goto-char (+ (minibuffer-prompt-end) match-offset)))) | |
| (if (memq (car (car command-history)) '(previous-matching-history-element | |
| next-matching-history-element)) | |
| (setq command-history (cdr command-history)))) | |
| (defun next-matching-history-element (regexp n) | |
| "Find the next history element that matches REGEXP. | |
| \(The next history element refers to a more recent action.) | |
| With prefix argument N, search for Nth next match. | |
| If N is negative, find the previous or Nth previous match. | |
| Normally, history elements are matched case-insensitively if | |
| `case-fold-search' is non-nil, but an uppercase letter in REGEXP | |
| makes the search case-sensitive." | |
| (interactive | |
| (let* ((enable-recursive-minibuffers t) | |
| (regexp (read-from-minibuffer "Next element matching (regexp): " | |
| nil | |
| minibuffer-local-map | |
| nil | |
| 'minibuffer-history-search-history | |
| (car minibuffer-history-search-history)))) | |
| ;; Use the last regexp specified, by default, if input is empty. | |
| (list (if (string= regexp "") | |
| (if minibuffer-history-search-history | |
| (car minibuffer-history-search-history) | |
| (user-error "No previous history search regexp")) | |
| regexp) | |
| (prefix-numeric-value current-prefix-arg)))) | |
| (previous-matching-history-element regexp (- n))) | |
| (defvar minibuffer-temporary-goal-position nil) | |
| (defvar minibuffer-default-add-function 'minibuffer-default-add-completions | |
| "Function run by `goto-history-element' before consuming default values. | |
| This is useful to dynamically add more elements to the list of default values | |
| when `goto-history-element' reaches the end of this list. | |
| Before calling this function `goto-history-element' sets the variable | |
| `minibuffer-default-add-done' to t, so it will call this function only | |
| once. In special cases, when this function needs to be called more | |
| than once, it can set `minibuffer-default-add-done' to nil explicitly, | |
| overriding the setting of this variable to t in `goto-history-element'.") | |
| (defvar minibuffer-default-add-done nil | |
| "When nil, add more elements to the end of the list of default values. | |
| The value nil causes `goto-history-element' to add more elements to | |
| the list of defaults when it reaches the end of this list. It does | |
| this by calling a function defined by `minibuffer-default-add-function'.") | |
| (make-variable-buffer-local 'minibuffer-default-add-done) | |
| (defun minibuffer-default-add-completions () | |
| "Return a list of all completions without the default value. | |
| This function is used to add all elements of the completion table to | |
| the end of the list of defaults just after the default value." | |
| (let ((def minibuffer-default) | |
| (all (all-completions "" | |
| minibuffer-completion-table | |
| minibuffer-completion-predicate))) | |
| (if (listp def) | |
| (append def all) | |
| (cons def (delete def all))))) | |
| (defun minibuffer-history-value () | |
| "Return the value of the minibuffer input history list. | |
| If `minibuffer-history-variable' points to a buffer-local variable and | |
| the minibuffer is active, return the buffer-local value for the buffer | |
| that was current when the minibuffer was activated." | |
| (buffer-local-value minibuffer-history-variable | |
| (window-buffer (minibuffer-selected-window)))) | |
| (defun goto-history-element (nabs) | |
| "Puts element of the minibuffer history in the minibuffer. | |
| The argument NABS specifies the absolute history position in | |
| descending order, where 0 means the current element and a | |
| positive number N means the Nth previous element. NABS being a | |
| negative number -N means the Nth entry of \"future history.\"" | |
| (interactive "p") | |
| (when (and (not minibuffer-default-add-done) | |
| (functionp minibuffer-default-add-function) | |
| (< nabs (- (if (listp minibuffer-default) | |
| (length minibuffer-default) | |
| 1)))) | |
| (setq minibuffer-default-add-done t | |
| minibuffer-default (funcall minibuffer-default-add-function))) | |
| (let ((minimum (if minibuffer-default | |
| (- (if (listp minibuffer-default) | |
| (length minibuffer-default) | |
| 1)) | |
| 0)) | |
| elt minibuffer-returned-to-present) | |
| (if (and (zerop minibuffer-history-position) | |
| (null minibuffer-text-before-history)) | |
| (setq minibuffer-text-before-history | |
| (minibuffer-contents-no-properties))) | |
| (if (< nabs minimum) | |
| (user-error (if minibuffer-default | |
| "End of defaults; no next item" | |
| "End of history; no default available"))) | |
| (if (> nabs (if (listp (minibuffer-history-value)) | |
| (length (minibuffer-history-value)) | |
| 0)) | |
| (user-error "Beginning of history; no preceding item")) | |
| (unless (memq last-command '(next-history-element | |
| previous-history-element)) | |
| (let ((prompt-end (minibuffer-prompt-end))) | |
| (set (make-local-variable 'minibuffer-temporary-goal-position) | |
| (cond ((<= (point) prompt-end) prompt-end) | |
| ((eobp) nil) | |
| (t (point)))))) | |
| (goto-char (point-max)) | |
| (delete-minibuffer-contents) | |
| (setq minibuffer-history-position nabs) | |
| (cond ((< nabs 0) | |
| (setq elt (if (listp minibuffer-default) | |
| (nth (1- (abs nabs)) minibuffer-default) | |
| minibuffer-default))) | |
| ((= nabs 0) | |
| (setq elt (or minibuffer-text-before-history "")) | |
| (setq minibuffer-returned-to-present t) | |
| (setq minibuffer-text-before-history nil)) | |
| (t (setq elt (nth (1- minibuffer-history-position) | |
| (minibuffer-history-value))))) | |
| (insert | |
| (if (and (eq minibuffer-history-sexp-flag (minibuffer-depth)) | |
| (not minibuffer-returned-to-present)) | |
| (let ((print-level nil)) | |
| (prin1-to-string elt)) | |
| elt)) | |
| (goto-char (or minibuffer-temporary-goal-position (point-max))))) | |
| (defun next-history-element (n) | |
| "Puts next element of the minibuffer history in the minibuffer. | |
| With argument N, it uses the Nth following element. The position | |
| in the history can go beyond the current position and invoke \"future | |
| history.\"" | |
| (interactive "p") | |
| (or (zerop n) | |
| (goto-history-element (- minibuffer-history-position n)))) | |
| (defun previous-history-element (n) | |
| "Puts previous element of the minibuffer history in the minibuffer. | |
| With argument N, it uses the Nth previous element." | |
| (interactive "p") | |
| (or (zerop n) | |
| (goto-history-element (+ minibuffer-history-position n)))) | |
| (defun next-line-or-history-element (&optional arg) | |
| "Move cursor vertically down ARG lines, or to the next history element. | |
| When point moves over the bottom line of multi-line minibuffer, puts ARGth | |
| next element of the minibuffer history in the minibuffer." | |
| (interactive "^p") | |
| (or arg (setq arg 1)) | |
| (let* ((old-point (point)) | |
| ;; Don't add newlines if they have the mode enabled globally. | |
| (next-line-add-newlines nil) | |
| ;; Remember the original goal column of possibly multi-line input | |
| ;; excluding the length of the prompt on the first line. | |
| (prompt-end (minibuffer-prompt-end)) | |
| (old-column (unless (and (eolp) (> (point) prompt-end)) | |
| (if (= (line-number-at-pos) 1) | |
| (max (- (current-column) | |
| (save-excursion | |
| (goto-char (1- prompt-end)) | |
| (current-column))) | |
| 0) | |
| (current-column))))) | |
| (condition-case nil | |
| (with-no-warnings | |
| (next-line arg)) | |
| (end-of-buffer | |
| ;; Restore old position since `line-move-visual' moves point to | |
| ;; the end of the line when it fails to go to the next line. | |
| (goto-char old-point) | |
| (next-history-element arg) | |
| ;; Reset `temporary-goal-column' because a correct value is not | |
| ;; calculated when `next-line' above fails by bumping against | |
| ;; the bottom of the minibuffer (bug#22544). | |
| (setq temporary-goal-column 0) | |
| ;; Restore the original goal column on the last line | |
| ;; of possibly multi-line input. | |
| (goto-char (point-max)) | |
| (when old-column | |
| (if (= (line-number-at-pos) 1) | |
| (move-to-column (+ old-column | |
| (save-excursion | |
| (goto-char (1- (minibuffer-prompt-end))) | |
| (current-column)))) | |
| (move-to-column old-column))))))) | |
| (defun previous-line-or-history-element (&optional arg) | |
| "Move cursor vertically up ARG lines, or to the previous history element. | |
| When point moves over the top line of multi-line minibuffer, puts ARGth | |
| previous element of the minibuffer history in the minibuffer." | |
| (interactive "^p") | |
| (or arg (setq arg 1)) | |
| (let* ((old-point (point)) | |
| ;; Remember the original goal column of possibly multi-line input | |
| ;; excluding the length of the prompt on the first line. | |
| (prompt-end (minibuffer-prompt-end)) | |
| (old-column (unless (and (eolp) (> (point) prompt-end)) | |
| (if (= (line-number-at-pos) 1) | |
| (max (- (current-column) | |
| (save-excursion | |
| (goto-char (1- prompt-end)) | |
| (current-column))) | |
| 0) | |
| (current-column))))) | |
| (condition-case nil | |
| (with-no-warnings | |
| (previous-line arg)) | |
| (beginning-of-buffer | |
| ;; Restore old position since `line-move-visual' moves point to | |
| ;; the beginning of the line when it fails to go to the previous line. | |
| (goto-char old-point) | |
| (previous-history-element arg) | |
| ;; Reset `temporary-goal-column' because a correct value is not | |
| ;; calculated when `previous-line' above fails by bumping against | |
| ;; the top of the minibuffer (bug#22544). | |
| (setq temporary-goal-column 0) | |
| ;; Restore the original goal column on the first line | |
| ;; of possibly multi-line input. | |
| (goto-char (minibuffer-prompt-end)) | |
| (if old-column | |
| (if (= (line-number-at-pos) 1) | |
| (move-to-column (+ old-column | |
| (save-excursion | |
| (goto-char (1- (minibuffer-prompt-end))) | |
| (current-column)))) | |
| (move-to-column old-column)) | |
| ;; Put the cursor at the end of the visual line instead of the | |
| ;; logical line, so the next `previous-line-or-history-element' | |
| ;; would move to the previous history element, not to a possible upper | |
| ;; visual line from the end of logical line in `line-move-visual' mode. | |
| (end-of-visual-line) | |
| ;; Since `end-of-visual-line' puts the cursor at the beginning | |
| ;; of the next visual line, move it one char back to the end | |
| ;; of the first visual line (bug#22544). | |
| (unless (eolp) (backward-char 1))))))) | |
| (defun next-complete-history-element (n) | |
| "Get next history element that completes the minibuffer before the point. | |
| The contents of the minibuffer after the point are deleted and replaced | |
| by the new completion." | |
| (interactive "p") | |
| (let ((point-at-start (point))) | |
| (next-matching-history-element | |
| (concat | |
| "^" (regexp-quote (buffer-substring (minibuffer-prompt-end) (point)))) | |
| n) | |
| ;; next-matching-history-element always puts us at (point-min). | |
| ;; Move to the position we were at before changing the buffer contents. | |
| ;; This is still sensible, because the text before point has not changed. | |
| (goto-char point-at-start))) | |
| (defun previous-complete-history-element (n) | |
| "\ | |
| Get previous history element that completes the minibuffer before the point. | |
| The contents of the minibuffer after the point are deleted and replaced | |
| by the new completion." | |
| (interactive "p") | |
| (next-complete-history-element (- n))) | |
| ;; For compatibility with the old subr of the same name. | |
| (defun minibuffer-prompt-width () | |
| "Return the display width of the minibuffer prompt. | |
| Return 0 if current buffer is not a minibuffer." | |
| ;; Return the width of everything before the field at the end of | |
| ;; the buffer; this should be 0 for normal buffers. | |
| (1- (minibuffer-prompt-end))) | |
| ;; isearch minibuffer history | |
| (add-hook 'minibuffer-setup-hook 'minibuffer-history-isearch-setup) | |
| (defvar minibuffer-history-isearch-message-overlay) | |
| (make-variable-buffer-local 'minibuffer-history-isearch-message-overlay) | |
| (defun minibuffer-history-isearch-setup () | |
| "Set up a minibuffer for using isearch to search the minibuffer history. | |
| Intended to be added to `minibuffer-setup-hook'." | |
| (set (make-local-variable 'isearch-search-fun-function) | |
| 'minibuffer-history-isearch-search) | |
| (set (make-local-variable 'isearch-message-function) | |
| 'minibuffer-history-isearch-message) | |
| (set (make-local-variable 'isearch-wrap-function) | |
| 'minibuffer-history-isearch-wrap) | |
| (set (make-local-variable 'isearch-push-state-function) | |
| 'minibuffer-history-isearch-push-state) | |
| (add-hook 'isearch-mode-end-hook 'minibuffer-history-isearch-end nil t)) | |
| (defun minibuffer-history-isearch-end () | |
| "Clean up the minibuffer after terminating isearch in the minibuffer." | |
| (if minibuffer-history-isearch-message-overlay | |
| (delete-overlay minibuffer-history-isearch-message-overlay))) | |
| (defun minibuffer-history-isearch-search () | |
| "Return the proper search function, for isearch in minibuffer history." | |
| (lambda (string bound noerror) | |
| (let ((search-fun | |
| ;; Use standard functions to search within minibuffer text | |
| (isearch-search-fun-default)) | |
| found) | |
| ;; Avoid lazy-highlighting matches in the minibuffer prompt when | |
| ;; searching forward. Lazy-highlight calls this lambda with the | |
| ;; bound arg, so skip the minibuffer prompt. | |
| (if (and bound isearch-forward (< (point) (minibuffer-prompt-end))) | |
| (goto-char (minibuffer-prompt-end))) | |
| (or | |
| ;; 1. First try searching in the initial minibuffer text | |
| (funcall search-fun string | |
| (if isearch-forward bound (minibuffer-prompt-end)) | |
| noerror) | |
| ;; 2. If the above search fails, start putting next/prev history | |
| ;; elements in the minibuffer successively, and search the string | |
| ;; in them. Do this only when bound is nil (i.e. not while | |
| ;; lazy-highlighting search strings in the current minibuffer text). | |
| (unless bound | |
| (condition-case nil | |
| (progn | |
| (while (not found) | |
| (cond (isearch-forward | |
| (next-history-element 1) | |
| (goto-char (minibuffer-prompt-end))) | |
| (t | |
| (previous-history-element 1) | |
| (goto-char (point-max)))) | |
| (setq isearch-barrier (point) isearch-opoint (point)) | |
| ;; After putting the next/prev history element, search | |
| ;; the string in them again, until next-history-element | |
| ;; or previous-history-element raises an error at the | |
| ;; beginning/end of history. | |
| (setq found (funcall search-fun string | |
| (unless isearch-forward | |
| ;; For backward search, don't search | |
| ;; in the minibuffer prompt | |
| (minibuffer-prompt-end)) | |
| noerror))) | |
| ;; Return point of the new search result | |
| (point)) | |
| ;; Return nil when next(prev)-history-element fails | |
| (error nil))))))) | |
| (defun minibuffer-history-isearch-message (&optional c-q-hack ellipsis) | |
| "Display the minibuffer history search prompt. | |
| If there are no search errors, this function displays an overlay with | |
| the isearch prompt which replaces the original minibuffer prompt. | |
| Otherwise, it displays the standard isearch message returned from | |
| the function `isearch-message'." | |
| (if (not (and (minibufferp) isearch-success (not isearch-error))) | |
| ;; Use standard function `isearch-message' when not in the minibuffer, | |
| ;; or search fails, or has an error (like incomplete regexp). | |
| ;; This function overwrites minibuffer text with isearch message, | |
| ;; so it's possible to see what is wrong in the search string. | |
| (isearch-message c-q-hack ellipsis) | |
| ;; Otherwise, put the overlay with the standard isearch prompt over | |
| ;; the initial minibuffer prompt. | |
| (if (overlayp minibuffer-history-isearch-message-overlay) | |
| (move-overlay minibuffer-history-isearch-message-overlay | |
| (point-min) (minibuffer-prompt-end)) | |
| (setq minibuffer-history-isearch-message-overlay | |
| (make-overlay (point-min) (minibuffer-prompt-end))) | |
| (overlay-put minibuffer-history-isearch-message-overlay 'evaporate t)) | |
| (overlay-put minibuffer-history-isearch-message-overlay | |
| 'display (isearch-message-prefix c-q-hack ellipsis)) | |
| ;; And clear any previous isearch message. | |
| (message ""))) | |
| (defun minibuffer-history-isearch-wrap () | |
| "Wrap the minibuffer history search when search fails. | |
| Move point to the first history element for a forward search, | |
| or to the last history element for a backward search." | |
| ;; When `minibuffer-history-isearch-search' fails on reaching the | |
| ;; beginning/end of the history, wrap the search to the first/last | |
| ;; minibuffer history element. | |
| (if isearch-forward | |
| (goto-history-element (length (minibuffer-history-value))) | |
| (goto-history-element 0)) | |
| (setq isearch-success t) | |
| (goto-char (if isearch-forward (minibuffer-prompt-end) (point-max)))) | |
| (defun minibuffer-history-isearch-push-state () | |
| "Save a function restoring the state of minibuffer history search. | |
| Save `minibuffer-history-position' to the additional state parameter | |
| in the search status stack." | |
| (let ((pos minibuffer-history-position)) | |
| (lambda (cmd) | |
| (minibuffer-history-isearch-pop-state cmd pos)))) | |
| (defun minibuffer-history-isearch-pop-state (_cmd hist-pos) | |
| "Restore the minibuffer history search state. | |
| Go to the history element by the absolute history position HIST-POS." | |
| (goto-history-element hist-pos)) | |
| (add-hook 'minibuffer-setup-hook 'minibuffer-error-initialize) | |
| (defun minibuffer-error-initialize () | |
| "Set up minibuffer error processing." | |
| (setq-local command-error-function 'minibuffer-error-function)) | |
| (defun minibuffer-error-function (data context caller) | |
| "Display error messages in the active minibuffer. | |
| The same as `command-error-default-function' but display error messages | |
| at the end of the minibuffer using `minibuffer-message' to not obscure | |
| the minibuffer contents." | |
| (discard-input) | |
| (ding) | |
| (let ((string (error-message-string data))) | |
| ;; If we know from where the error was signaled, show it in | |
| ;; *Messages*. | |
| (let ((inhibit-message t)) | |
| (message "%s%s" (if caller (format "%s: " caller) "") string)) | |
| ;; Display an error message at the end of the minibuffer. | |
| (minibuffer-message (apply #'propertize (format " [%s%s]" context string) | |
| minibuffer-prompt-properties)))) | |
| ;Put this on C-x u, so we can force that rather than C-_ into startup msg | |
| (define-obsolete-function-alias 'advertised-undo 'undo "23.2") | |
| (defconst undo-equiv-table (make-hash-table :test 'eq :weakness t) | |
| "Table mapping redo records to the corresponding undo one. | |
| A redo record for undo-in-region maps to t. | |
| A redo record for ordinary undo maps to the following (earlier) undo.") | |
| (defvar undo-in-region nil | |
| "Non-nil if `pending-undo-list' is not just a tail of `buffer-undo-list'.") | |
| (defvar undo-no-redo nil | |
| "If t, `undo' doesn't go through redo entries.") | |
| (defvar pending-undo-list nil | |
| "Within a run of consecutive undo commands, list remaining to be undone. | |
| If t, we undid all the way to the end of it.") | |
| (defun undo--last-change-was-undo-p (undo-list) | |
| (while (and (consp undo-list) (eq (car undo-list) nil)) | |
| (setq undo-list (cdr undo-list))) | |
| (gethash undo-list undo-equiv-table)) | |
| (defun undo (&optional arg) | |
| "Undo some previous changes. | |
| Repeat this command to undo more changes. | |
| A numeric ARG serves as a repeat count. | |
| In Transient Mark mode when the mark is active, undo changes only within | |
| the current region. Similarly, when not in Transient Mark mode, just \\[universal-argument] | |
| as an argument limits undo to changes within the current region." | |
| (interactive "*P") | |
| ;; Make last-command indicate for the next command that this was an undo. | |
| ;; That way, another undo will undo more. | |
| ;; If we get to the end of the undo history and get an error, | |
| ;; another undo command will find the undo history empty | |
| ;; and will get another error. To begin undoing the undos, | |
| ;; you must type some other command. | |
| (let* ((modified (buffer-modified-p)) | |
| ;; For an indirect buffer, look in the base buffer for the | |
| ;; auto-save data. | |
| (base-buffer (or (buffer-base-buffer) (current-buffer))) | |
| (recent-save (with-current-buffer base-buffer | |
| (recent-auto-save-p))) | |
| ;; Allow certain commands to inhibit an immediately following | |
| ;; undo-in-region. | |
| (inhibit-region (and (symbolp last-command) | |
| (get last-command 'undo-inhibit-region))) | |
| message) | |
| ;; If we get an error in undo-start, | |
| ;; the next command should not be a "consecutive undo". | |
| ;; So set `this-command' to something other than `undo'. | |
| (setq this-command 'undo-start) | |
| (unless (and (eq last-command 'undo) | |
| (or (eq pending-undo-list t) | |
| ;; If something (a timer or filter?) changed the buffer | |
| ;; since the previous command, don't continue the undo seq. | |
| (undo--last-change-was-undo-p buffer-undo-list))) | |
| (setq undo-in-region | |
| (and (or (region-active-p) (and arg (not (numberp arg)))) | |
| (not inhibit-region))) | |
| (if undo-in-region | |
| (undo-start (region-beginning) (region-end)) | |
| (undo-start)) | |
| ;; get rid of initial undo boundary | |
| (undo-more 1)) | |
| ;; If we got this far, the next command should be a consecutive undo. | |
| (setq this-command 'undo) | |
| ;; Check to see whether we're hitting a redo record, and if | |
| ;; so, ask the user whether she wants to skip the redo/undo pair. | |
| (let ((equiv (gethash pending-undo-list undo-equiv-table))) | |
| (or (eq (selected-window) (minibuffer-window)) | |
| (setq message (format "%s%s" | |
| (if (or undo-no-redo (not equiv)) | |
| "Undo" "Redo") | |
| (if undo-in-region " in region" "")))) | |
| (when (and (consp equiv) undo-no-redo) | |
| ;; The equiv entry might point to another redo record if we have done | |
| ;; undo-redo-undo-redo-... so skip to the very last equiv. | |
| (while (let ((next (gethash equiv undo-equiv-table))) | |
| (if next (setq equiv next)))) | |
| (setq pending-undo-list equiv))) | |
| (undo-more | |
| (if (numberp arg) | |
| (prefix-numeric-value arg) | |
| 1)) | |
| ;; Record the fact that the just-generated undo records come from an | |
| ;; undo operation--that is, they are redo records. | |
| ;; In the ordinary case (not within a region), map the redo | |
| ;; record to the following undos. | |
| ;; I don't know how to do that in the undo-in-region case. | |
| (let ((list buffer-undo-list)) | |
| ;; Strip any leading undo boundaries there might be, like we do | |
| ;; above when checking. | |
| (while (eq (car list) nil) | |
| (setq list (cdr list))) | |
| (puthash list | |
| ;; Prevent identity mapping. This can happen if | |
| ;; consecutive nils are erroneously in undo list. | |
| (if (or undo-in-region (eq list pending-undo-list)) | |
| t | |
| pending-undo-list) | |
| undo-equiv-table)) | |
| ;; Don't specify a position in the undo record for the undo command. | |
| ;; Instead, undoing this should move point to where the change is. | |
| (let ((tail buffer-undo-list) | |
| (prev nil)) | |
| (while (car tail) | |
| (when (integerp (car tail)) | |
| (let ((pos (car tail))) | |
| (if prev | |
| (setcdr prev (cdr tail)) | |
| (setq buffer-undo-list (cdr tail))) | |
| (setq tail (cdr tail)) | |
| (while (car tail) | |
| (if (eq pos (car tail)) | |
| (if prev | |
| (setcdr prev (cdr tail)) | |
| (setq buffer-undo-list (cdr tail))) | |
| (setq prev tail)) | |
| (setq tail (cdr tail))) | |
| (setq tail nil))) | |
| (setq prev tail tail (cdr tail)))) | |
| ;; Record what the current undo list says, | |
| ;; so the next command can tell if the buffer was modified in between. | |
| (and modified (not (buffer-modified-p)) | |
| (with-current-buffer base-buffer | |
| (delete-auto-save-file-if-necessary recent-save))) | |
| ;; Display a message announcing success. | |
| (if message | |
| (message "%s" message)))) | |
| (defun buffer-disable-undo (&optional buffer) | |
| "Make BUFFER stop keeping undo information. | |
| No argument or nil as argument means do this for the current buffer." | |
| (interactive) | |
| (with-current-buffer (if buffer (get-buffer buffer) (current-buffer)) | |
| (setq buffer-undo-list t))) | |
| (defun undo-only (&optional arg) | |
| "Undo some previous changes. | |
| Repeat this command to undo more changes. | |
| A numeric ARG serves as a repeat count. | |
| Contrary to `undo', this will not redo a previous undo." | |
| (interactive "*p") | |
| (let ((undo-no-redo t)) (undo arg))) | |
| (defun undo-redo (&optional arg) | |
| "Undo the last ARG undos." | |
| (interactive "*p") | |
| (cond | |
| ((not (undo--last-change-was-undo-p buffer-undo-list)) | |
| (user-error "No undo to undo")) | |
| (t | |
| (let* ((ul buffer-undo-list) | |
| (new-ul | |
| (let ((undo-in-progress t)) | |
| (while (and (consp ul) (eq (car ul) nil)) | |
| (setq ul (cdr ul))) | |
| (primitive-undo arg ul))) | |
| (new-pul (undo--last-change-was-undo-p new-ul))) | |
| (message "Redo%s" (if undo-in-region " in region" "")) | |
| (setq this-command 'undo) | |
| (setq pending-undo-list new-pul) | |
| (setq buffer-undo-list new-ul))))) | |
| (defvar undo-in-progress nil | |
| "Non-nil while performing an undo. | |
| Some change-hooks test this variable to do something different.") | |
| (defun undo-more (n) | |
| "Undo back N undo-boundaries beyond what was already undone recently. | |
| Call `undo-start' to get ready to undo recent changes, | |
| then call `undo-more' one or more times to undo them." | |
| (or (listp pending-undo-list) | |
| (user-error (concat "No further undo information" | |
| (and undo-in-region " for region")))) | |
| (let ((undo-in-progress t)) | |
| ;; Note: The following, while pulling elements off | |
| ;; `pending-undo-list' will call primitive change functions which | |
| ;; will push more elements onto `buffer-undo-list'. | |
| (setq pending-undo-list (primitive-undo n pending-undo-list)) | |
| (if (null pending-undo-list) | |
| (setq pending-undo-list t)))) | |
| (defun primitive-undo (n list) | |
| "Undo N records from the front of the list LIST. | |
| Return what remains of the list." | |
| ;; This is a good feature, but would make undo-start | |
| ;; unable to do what is expected. | |
| ;;(when (null (car (list))) | |
| ;; ;; If the head of the list is a boundary, it is the boundary | |
| ;; ;; preceding this command. Get rid of it and don't count it. | |
| ;; (setq list (cdr list)))) | |
| (let ((arg n) | |
| ;; In a writable buffer, enable undoing read-only text that is | |
| ;; so because of text properties. | |
| (inhibit-read-only t) | |
| ;; Don't let `intangible' properties interfere with undo. | |
| (inhibit-point-motion-hooks t) | |
| ;; We use oldlist only to check for EQ. ++kfs | |
| (oldlist buffer-undo-list) | |
| (did-apply nil) | |
| (next nil)) | |
| (while (> arg 0) | |
| (while (setq next (pop list)) ;Exit inner loop at undo boundary. | |
| ;; Handle an integer by setting point to that value. | |
| (pcase next | |
| ((pred integerp) (goto-char next)) | |
| ;; Element (t . TIME) records previous modtime. | |
| ;; Preserve any flag of NONEXISTENT_MODTIME_NSECS or | |
| ;; UNKNOWN_MODTIME_NSECS. | |
| (`(t . ,time) | |
| ;; If this records an obsolete save | |
| ;; (not matching the actual disk file) | |
| ;; then don't mark unmodified. | |
| (when (or (equal time (visited-file-modtime)) | |
| (and (consp time) | |
| (equal (list (car time) (cdr time)) | |
| (visited-file-modtime)))) | |
| (when (fboundp 'unlock-buffer) | |
| (unlock-buffer)) | |
| (set-buffer-modified-p nil))) | |
| ;; Element (nil PROP VAL BEG . END) is property change. | |
| (`(nil . ,(or `(,prop ,val ,beg . ,end) pcase--dontcare)) | |
| (when (or (> (point-min) beg) (< (point-max) end)) | |
| (error "Changes to be undone are outside visible portion of buffer")) | |
| (put-text-property beg end prop val)) | |
| ;; Element (BEG . END) means range was inserted. | |
| (`(,(and beg (pred integerp)) . ,(and end (pred integerp))) | |
| ;; (and `(,beg . ,end) `(,(pred integerp) . ,(pred integerp))) | |
| ;; Ideally: `(,(pred integerp beg) . ,(pred integerp end)) | |
| (when (or (> (point-min) beg) (< (point-max) end)) | |
| (error "Changes to be undone are outside visible portion of buffer")) | |
| ;; Set point first thing, so that undoing this undo | |
| ;; does not send point back to where it is now. | |
| (goto-char beg) | |
| (delete-region beg end)) | |
| ;; Element (apply FUN . ARGS) means call FUN to undo. | |
| (`(apply . ,fun-args) | |
| (let ((currbuff (current-buffer))) | |
| (if (integerp (car fun-args)) | |
| ;; Long format: (apply DELTA START END FUN . ARGS). | |
| (pcase-let* ((`(,delta ,start ,end ,fun . ,args) fun-args) | |
| (start-mark (copy-marker start nil)) | |
| (end-mark (copy-marker end t))) | |
| (when (or (> (point-min) start) (< (point-max) end)) | |
| (error "Changes to be undone are outside visible portion of buffer")) | |
| (apply fun args) ;; Use `save-current-buffer'? | |
| ;; Check that the function did what the entry | |
| ;; said it would do. | |
| (unless (and (= start start-mark) | |
| (= (+ delta end) end-mark)) | |
| (error "Changes to be undone by function different from announced")) | |
| (set-marker start-mark nil) | |
| (set-marker end-mark nil)) | |
| (apply fun-args)) | |
| (unless (eq currbuff (current-buffer)) | |
| (error "Undo function switched buffer")) | |
| (setq did-apply t))) | |
| ;; Element (STRING . POS) means STRING was deleted. | |
| (`(,(and string (pred stringp)) . ,(and pos (pred integerp))) | |
| (let ((valid-marker-adjustments nil) | |
| (apos (abs pos))) | |
| (when (or (< apos (point-min)) (> apos (point-max))) | |
| (error "Changes to be undone are outside visible portion of buffer")) | |
| ;; Check that marker adjustments which were recorded | |
| ;; with the (STRING . POS) record are still valid, ie | |
| ;; the markers haven't moved. We check their validity | |
| ;; before reinserting the string so as we don't need to | |
| ;; mind marker insertion-type. | |
| (while (and (markerp (car-safe (car list))) | |
| (integerp (cdr-safe (car list)))) | |
| (let* ((marker-adj (pop list)) | |
| (m (car marker-adj))) | |
| (and (eq (marker-buffer m) (current-buffer)) | |
| (= apos m) | |
| (push marker-adj valid-marker-adjustments)))) | |
| ;; Insert string and adjust point | |
| (if (< pos 0) | |
| (progn | |
| (goto-char (- pos)) | |
| (insert string)) | |
| (goto-char pos) | |
| (insert string) | |
| (goto-char pos)) | |
| ;; Adjust the valid marker adjustments | |
| (dolist (adj valid-marker-adjustments) | |
| ;; Insert might have invalidated some of the markers | |
| ;; via modification hooks. Update only the currently | |
| ;; valid ones (bug#25599). | |
| (if (marker-buffer (car adj)) | |
| (set-marker (car adj) | |
| (- (car adj) (cdr adj))))))) | |
| ;; (MARKER . OFFSET) means a marker MARKER was adjusted by OFFSET. | |
| (`(,(and marker (pred markerp)) . ,(and offset (pred integerp))) | |
| (warn "Encountered %S entry in undo list with no matching (TEXT . POS) entry" | |
| next) | |
| ;; Even though these elements are not expected in the undo | |
| ;; list, adjust them to be conservative for the 24.4 | |
| ;; release. (Bug#16818) | |
| (when (marker-buffer marker) | |
| (set-marker marker | |
| (- marker offset) | |
| (marker-buffer marker)))) | |
| (_ (error "Unrecognized entry in undo list %S" next)))) | |
| (setq arg (1- arg))) | |
| ;; Make sure an apply entry produces at least one undo entry, | |
| ;; so the test in `undo' for continuing an undo series | |
| ;; will work right. | |
| (if (and did-apply | |
| (eq oldlist buffer-undo-list)) | |
| (setq buffer-undo-list | |
| (cons (list 'apply 'cdr nil) buffer-undo-list)))) | |
| list) | |
| ;; Deep copy of a list | |
| (defun undo-copy-list (list) | |
| "Make a copy of undo list LIST." | |
| (mapcar 'undo-copy-list-1 list)) | |
| (defun undo-copy-list-1 (elt) | |
| (if (consp elt) | |
| (cons (car elt) (undo-copy-list-1 (cdr elt))) | |
| elt)) | |
| (defun undo-start (&optional beg end) | |
| "Set `pending-undo-list' to the front of the undo list. | |
| The next call to `undo-more' will undo the most recently made change. | |
| If BEG and END are specified, then undo only elements | |
| that apply to text between BEG and END are used; other undo elements | |
| are ignored. If BEG and END are nil, all undo elements are used." | |
| (if (eq buffer-undo-list t) | |
| (user-error "No undo information in this buffer")) | |
| (setq pending-undo-list | |
| (if (and beg end (not (= beg end))) | |
| (undo-make-selective-list (min beg end) (max beg end)) | |
| buffer-undo-list))) | |
| ;; The positions given in elements of the undo list are the positions | |
| ;; as of the time that element was recorded to undo history. In | |
| ;; general, subsequent buffer edits render those positions invalid in | |
| ;; the current buffer, unless adjusted according to the intervening | |
| ;; undo elements. | |
| ;; | |
| ;; Undo in region is a use case that requires adjustments to undo | |
| ;; elements. It must adjust positions of elements in the region based | |
| ;; on newer elements not in the region so as they may be correctly | |
| ;; applied in the current buffer. undo-make-selective-list | |
| ;; accomplishes this with its undo-deltas list of adjustments. An | |
| ;; example undo history from oldest to newest: | |
| ;; | |
| ;; buf pos: | |
| ;; 123456789 buffer-undo-list undo-deltas | |
| ;; --------- ---------------- ----------- | |
| ;; aaa (1 . 4) (1 . -3) | |
| ;; aaba (3 . 4) N/A (in region) | |
| ;; ccaaba (1 . 3) (1 . -2) | |
| ;; ccaabaddd (7 . 10) (7 . -3) | |
| ;; ccaabdd ("ad" . 6) (6 . 2) | |
| ;; ccaabaddd (6 . 8) (6 . -2) | |
| ;; | |<-- region: "caab", from 2 to 6 | |
| ;; | |
| ;; When the user starts a run of undos in region, | |
| ;; undo-make-selective-list is called to create the full list of in | |
| ;; region elements. Each element is adjusted forward chronologically | |
| ;; through undo-deltas to determine if it is in the region. | |
| ;; | |
| ;; In the above example, the insertion of "b" is (3 . 4) in the | |
| ;; buffer-undo-list. The undo-delta (1 . -2) causes (3 . 4) to become | |
| ;; (5 . 6). The next three undo-deltas cause no adjustment, so (5 | |
| ;; . 6) is assessed as in the region and placed in the selective list. | |
| ;; Notably, the end of region itself adjusts from "2 to 6" to "2 to 5" | |
| ;; due to the selected element. The "b" insertion is the only element | |
| ;; fully in the region, so in this example undo-make-selective-list | |
| ;; returns (nil (5 . 6)). | |
| ;; | |
| ;; The adjustment of the (7 . 10) insertion of "ddd" shows an edge | |
| ;; case. It is adjusted through the undo-deltas: ((6 . 2) (6 . -2)). | |
| ;; Normally an undo-delta of (6 . 2) would cause positions after 6 to | |
| ;; adjust by 2. However, they shouldn't adjust to less than 6, so (7 | |
| ;; . 10) adjusts to (6 . 8) due to the first undo delta. | |
| ;; | |
| ;; More interesting is how to adjust the "ddd" insertion due to the | |
| ;; next undo-delta: (6 . -2), corresponding to reinsertion of "ad". | |
| ;; If the reinsertion was a manual retyping of "ad", then the total | |
| ;; adjustment should be (7 . 10) -> (6 . 8) -> (8 . 10). However, if | |
| ;; the reinsertion was due to undo, one might expect the first "d" | |
| ;; character would again be a part of the "ddd" text, meaning its | |
| ;; total adjustment would be (7 . 10) -> (6 . 8) -> (7 . 10). | |
| ;; | |
| ;; undo-make-selective-list assumes in this situation that "ad" was a | |
| ;; new edit, even if it was inserted because of an undo. | |
| ;; Consequently, if the user undos in region "8 to 10" of the | |
| ;; "ccaabaddd" buffer, they could be surprised that it becomes | |
| ;; "ccaabad", as though the first "d" became detached from the | |
| ;; original "ddd" insertion. This quirk is a FIXME. | |
| (defun undo-make-selective-list (start end) | |
| "Return a list of undo elements for the region START to END. | |
| The elements come from `buffer-undo-list', but we keep only the | |
| elements inside this region, and discard those outside this | |
| region. The elements' positions are adjusted so as the returned | |
| list can be applied to the current buffer." | |
| (let ((ulist buffer-undo-list) | |
| ;; A list of position adjusted undo elements in the region. | |
| (selective-list (list nil)) | |
| ;; A list of undo-deltas for out of region undo elements. | |
| undo-deltas | |
| undo-elt) | |
| (while ulist | |
| (when undo-no-redo | |
| (while (gethash ulist undo-equiv-table) | |
| (setq ulist (gethash ulist undo-equiv-table)))) | |
| (setq undo-elt (car ulist)) | |
| (cond | |
| ((null undo-elt) | |
| ;; Don't put two nils together in the list | |
| (when (car selective-list) | |
| (push nil selective-list))) | |
| ((and (consp undo-elt) (eq (car undo-elt) t)) | |
| ;; This is a "was unmodified" element. Keep it | |
| ;; if we have kept everything thus far. | |
| (when (not undo-deltas) | |
| (push undo-elt selective-list))) | |
| ;; Skip over marker adjustments, instead relying | |
| ;; on finding them after (TEXT . POS) elements | |
| ((markerp (car-safe undo-elt)) | |
| nil) | |
| (t | |
| (let ((adjusted-undo-elt (undo-adjust-elt undo-elt | |
| undo-deltas))) | |
| (if (undo-elt-in-region adjusted-undo-elt start end) | |
| (progn | |
| (setq end (+ end (cdr (undo-delta adjusted-undo-elt)))) | |
| (push adjusted-undo-elt selective-list) | |
| ;; Keep (MARKER . ADJUSTMENT) if their (TEXT . POS) was | |
| ;; kept. primitive-undo may discard them later. | |
| (when (and (stringp (car-safe adjusted-undo-elt)) | |
| (integerp (cdr-safe adjusted-undo-elt))) | |
| (let ((list-i (cdr ulist))) | |
| (while (markerp (car-safe (car list-i))) | |
| (push (pop list-i) selective-list))))) | |
| (let ((delta (undo-delta undo-elt))) | |
| (when (/= 0 (cdr delta)) | |
| (push delta undo-deltas))))))) | |
| (pop ulist)) | |
| (nreverse selective-list))) | |
| (defun undo-elt-in-region (undo-elt start end) | |
| "Determine whether UNDO-ELT falls inside the region START ... END. | |
| If it crosses the edge, we return nil. | |
| Generally this function is not useful for determining | |
| whether (MARKER . ADJUSTMENT) undo elements are in the region, | |
| because markers can be arbitrarily relocated. Instead, pass the | |
| marker adjustment's corresponding (TEXT . POS) element." | |
| (cond ((integerp undo-elt) | |
| (and (>= undo-elt start) | |
| (<= undo-elt end))) | |
| ((eq undo-elt nil) | |
| t) | |
| ((atom undo-elt) | |
| nil) | |
| ((stringp (car undo-elt)) | |
| ;; (TEXT . POSITION) | |
| (and (>= (abs (cdr undo-elt)) start) | |
| (<= (abs (cdr undo-elt)) end))) | |
| ((and (consp undo-elt) (markerp (car undo-elt))) | |
| ;; (MARKER . ADJUSTMENT) | |
| (<= start (car undo-elt) end)) | |
| ((null (car undo-elt)) | |
| ;; (nil PROPERTY VALUE BEG . END) | |
| (let ((tail (nthcdr 3 undo-elt))) | |
| (and (>= (car tail) start) | |
| (<= (cdr tail) end)))) | |
| ((integerp (car undo-elt)) | |
| ;; (BEGIN . END) | |
| (and (>= (car undo-elt) start) | |
| (<= (cdr undo-elt) end))))) | |
| (defun undo-elt-crosses-region (undo-elt start end) | |
| "Test whether UNDO-ELT crosses one edge of that region START ... END. | |
| This assumes we have already decided that UNDO-ELT | |
| is not *inside* the region START...END." | |
| (declare (obsolete nil "25.1")) | |
| (cond ((atom undo-elt) nil) | |
| ((null (car undo-elt)) | |
| ;; (nil PROPERTY VALUE BEG . END) | |
| (let ((tail (nthcdr 3 undo-elt))) | |
| (and (< (car tail) end) | |
| (> (cdr tail) start)))) | |
| ((integerp (car undo-elt)) | |
| ;; (BEGIN . END) | |
| (and (< (car undo-elt) end) | |
| (> (cdr undo-elt) start))))) | |
| (defun undo-adjust-elt (elt deltas) | |
| "Return adjustment of undo element ELT by the undo DELTAS | |
| list." | |
| (pcase elt | |
| ;; POSITION | |
| ((pred integerp) | |
| (undo-adjust-pos elt deltas)) | |
| ;; (BEG . END) | |
| (`(,(and beg (pred integerp)) . ,(and end (pred integerp))) | |
| (undo-adjust-beg-end beg end deltas)) | |
| ;; (TEXT . POSITION) | |
| (`(,(and text (pred stringp)) . ,(and pos (pred integerp))) | |
| (cons text (* (if (< pos 0) -1 1) | |
| (undo-adjust-pos (abs pos) deltas)))) | |
| ;; (nil PROPERTY VALUE BEG . END) | |
| (`(nil . ,(or `(,prop ,val ,beg . ,end) pcase--dontcare)) | |
| `(nil ,prop ,val . ,(undo-adjust-beg-end beg end deltas))) | |
| ;; (apply DELTA START END FUN . ARGS) | |
| ;; FIXME | |
| ;; All others return same elt | |
| (_ elt))) | |
| ;; (BEG . END) can adjust to the same positions, commonly when an | |
| ;; insertion was undone and they are out of region, for example: | |
| ;; | |
| ;; buf pos: | |
| ;; 123456789 buffer-undo-list undo-deltas | |
| ;; --------- ---------------- ----------- | |
| ;; [...] | |
| ;; abbaa (2 . 4) (2 . -2) | |
| ;; aaa ("bb" . 2) (2 . 2) | |
| ;; [...] | |
| ;; | |
| ;; "bb" insertion (2 . 4) adjusts to (2 . 2) because of the subsequent | |
| ;; undo. Further adjustments to such an element should be the same as | |
| ;; for (TEXT . POSITION) elements. The options are: | |
| ;; | |
| ;; 1: POSITION adjusts using <= (use-< nil), resulting in behavior | |
| ;; analogous to marker insertion-type t. | |
| ;; | |
| ;; 2: POSITION adjusts using <, resulting in behavior analogous to | |
| ;; marker insertion-type nil. | |
| ;; | |
| ;; There was no strong reason to prefer one or the other, except that | |
| ;; the first is more consistent with prior undo in region behavior. | |
| (defun undo-adjust-beg-end (beg end deltas) | |
| "Return cons of adjustments to BEG and END by the undo DELTAS | |
| list." | |
| (let ((adj-beg (undo-adjust-pos beg deltas))) | |
| ;; Note: option 2 above would be like (cons (min ...) adj-end) | |
| (cons adj-beg | |
| (max adj-beg (undo-adjust-pos end deltas t))))) | |
| (defun undo-adjust-pos (pos deltas &optional use-<) | |
| "Return adjustment of POS by the undo DELTAS list, comparing | |
| with < or <= based on USE-<." | |
| (dolist (d deltas pos) | |
| (when (if use-< | |
| (< (car d) pos) | |
| (<= (car d) pos)) | |
| (setq pos | |
| ;; Don't allow pos to become less than the undo-delta | |
| ;; position. This edge case is described in the overview | |
| ;; comments. | |
| (max (car d) (- pos (cdr d))))))) | |
| ;; Return the first affected buffer position and the delta for an undo element | |
| ;; delta is defined as the change in subsequent buffer positions if we *did* | |
| ;; the undo. | |
| (defun undo-delta (undo-elt) | |
| (if (consp undo-elt) | |
| (cond ((stringp (car undo-elt)) | |
| ;; (TEXT . POSITION) | |
| (cons (abs (cdr undo-elt)) (length (car undo-elt)))) | |
| ((integerp (car undo-elt)) | |
| ;; (BEGIN . END) | |
| (cons (car undo-elt) (- (car undo-elt) (cdr undo-elt)))) | |
| (t | |
| '(0 . 0))) | |
| '(0 . 0))) | |
| ;;; Default undo-boundary addition | |
| ;; | |
| ;; This section adds a new undo-boundary at either after a command is | |
| ;; called or in some cases on a timer called after a change is made in | |
| ;; any buffer. | |
| (defvar-local undo-auto--last-boundary-cause nil | |
| "Describe the cause of the last undo-boundary. | |
| If `explicit', the last boundary was caused by an explicit call to | |
| `undo-boundary', that is one not called by the code in this | |
| section. | |
| If it is equal to `timer', then the last boundary was inserted | |
| by `undo-auto--boundary-timer'. | |
| If it is equal to `command', then the last boundary was inserted | |
| automatically after a command, that is by the code defined in | |
| this section. | |
| If it is equal to a list, then the last boundary was inserted by | |
| an amalgamating command. The car of the list is the number of | |
| times an amalgamating command has been called, and the cdr are the | |
| buffers that were changed during the last command.") | |
| (defvar undo-auto-current-boundary-timer nil | |
| "Current timer which will run `undo-auto--boundary-timer' or nil. | |
| If set to non-nil, this will effectively disable the timer.") | |
| (defvar undo-auto--this-command-amalgamating nil | |
| "Non-nil if `this-command' should be amalgamated. | |
| This variable is set to nil by `undo-auto--boundaries' and is set | |
| by `undo-auto-amalgamate'." ) | |
| (defun undo-auto--needs-boundary-p () | |
| "Return non-nil if `buffer-undo-list' needs a boundary at the start." | |
| (car-safe buffer-undo-list)) | |
| (defun undo-auto--last-boundary-amalgamating-number () | |
| "Return the number of amalgamating last commands or nil. | |
| Amalgamating commands are, by default, either | |
| `self-insert-command' and `delete-char', but can be any command | |
| that calls `undo-auto-amalgamate'." | |
| (car-safe undo-auto--last-boundary-cause)) | |
| (defun undo-auto--ensure-boundary (cause) | |
| "Add an `undo-boundary' to the current buffer if needed. | |
| REASON describes the reason that the boundary is being added; see | |
| `undo-auto--last-boundary-cause' for more information." | |
| (when (and | |
| (undo-auto--needs-boundary-p)) | |
| (let ((last-amalgamating | |
| (undo-auto--last-boundary-amalgamating-number))) | |
| (undo-boundary) | |
| (setq undo-auto--last-boundary-cause | |
| (if (eq 'amalgamate cause) | |
| (cons | |
| (if last-amalgamating (1+ last-amalgamating) 0) | |
| undo-auto--undoably-changed-buffers) | |
| cause))))) | |
| (defun undo-auto--boundaries (cause) | |
| "Check recently changed buffers and add a boundary if necessary. | |
| REASON describes the reason that the boundary is being added; see | |
| `undo-last-boundary' for more information." | |
| ;; (Bug #23785) All commands should ensure that there is an undo | |
| ;; boundary whether they have changed the current buffer or not. | |
| (when (eq cause 'command) | |
| (add-to-list 'undo-auto--undoably-changed-buffers (current-buffer))) | |
| (dolist (b undo-auto--undoably-changed-buffers) | |
| (when (buffer-live-p b) | |
| (with-current-buffer b | |
| (undo-auto--ensure-boundary cause)))) | |
| (setq undo-auto--undoably-changed-buffers nil)) | |
| (defun undo-auto--boundary-timer () | |
| "Timer function run by `undo-auto-current-boundary-timer'." | |
| (setq undo-auto-current-boundary-timer nil) | |
| (undo-auto--boundaries 'timer)) | |
| (defun undo-auto--boundary-ensure-timer () | |
| "Ensure that the `undo-auto-current-boundary-timer' is set." | |
| (unless undo-auto-current-boundary-timer | |
| (setq undo-auto-current-boundary-timer | |
| (run-at-time 10 nil #'undo-auto--boundary-timer)))) | |
| (defvar undo-auto--undoably-changed-buffers nil | |
| "List of buffers that have changed recently. | |
| This list is maintained by `undo-auto--undoable-change' and | |
| `undo-auto--boundaries' and can be affected by changes to their | |
| default values.") | |
| (defun undo-auto--add-boundary () | |
| "Add an `undo-boundary' in appropriate buffers." | |
| (undo-auto--boundaries | |
| (let ((amal undo-auto--this-command-amalgamating)) | |
| (setq undo-auto--this-command-amalgamating nil) | |
| (if amal | |
| 'amalgamate | |
| 'command)))) | |
| (defun undo-auto-amalgamate () | |
| "Amalgamate undo if necessary. | |
| This function can be called before an amalgamating command. It | |
| removes the previous `undo-boundary' if a series of such calls | |
| have been made. By default `self-insert-command' and | |
| `delete-char' are the only amalgamating commands, although this | |
| function could be called by any command wishing to have this | |
| behavior." | |
| (let ((last-amalgamating-count | |
| (undo-auto--last-boundary-amalgamating-number))) | |
| (setq undo-auto--this-command-amalgamating t) | |
| (when last-amalgamating-count | |
| (if (and (< last-amalgamating-count amalgamating-undo-limit) | |
| (eq this-command last-command)) | |
| ;; Amalgamate all buffers that have changed. | |
| ;; This may be needed for example if some *-change-functions | |
| ;; reflected these changes in some other buffer. | |
| (dolist (b (cdr undo-auto--last-boundary-cause)) | |
| (when (buffer-live-p b) | |
| (with-current-buffer | |
| b | |
| (when (and (consp buffer-undo-list) | |
| ;; `car-safe' doesn't work because | |
| ;; `buffer-undo-list' need not be a list! | |
| (null (car buffer-undo-list))) | |
| ;; The head of `buffer-undo-list' is nil. | |
| (setq buffer-undo-list | |
| (cdr buffer-undo-list)))))) | |
| (setq undo-auto--last-boundary-cause 0))))) | |
| (defun undo-auto--undoable-change () | |
| "Called after every undoable buffer change." | |
| (unless (memq (current-buffer) undo-auto--undoably-changed-buffers) | |
| (let ((bufs undo-auto--undoably-changed-buffers)) | |
| ;; Drop dead buffers from the list, to avoid memory leak in | |
| ;; (while t (with-temp-buffer (setq buffer-undo-list nil) (insert "a"))) | |
| (while bufs | |
| (let ((next (cdr bufs))) | |
| (if (or (buffer-live-p (car bufs)) (null next)) | |
| (setq bufs next) | |
| (setcar bufs (car next)) | |
| (setcdr bufs (cdr next)))))) | |
| (push (current-buffer) undo-auto--undoably-changed-buffers)) | |
| (undo-auto--boundary-ensure-timer)) | |
| ;; End auto-boundary section | |
| (defun undo-amalgamate-change-group (handle) | |
| "Amalgamate changes in change-group since HANDLE. | |
| Remove all undo boundaries between the state of HANDLE and now. | |
| HANDLE is as returned by `prepare-change-group'." | |
| (dolist (elt handle) | |
| (with-current-buffer (car elt) | |
| (setq elt (cdr elt)) | |
| (when (consp buffer-undo-list) | |
| (let ((old-car (car-safe elt)) | |
| (old-cdr (cdr-safe elt))) | |
| (unwind-protect | |
| (progn | |
| ;; Temporarily truncate the undo log at ELT. | |
| (when (consp elt) | |
| (setcar elt t) (setcdr elt nil)) | |
| (when | |
| (or (null elt) ;The undo-log was empty. | |
| ;; `elt' is still in the log: normal case. | |
| (eq elt (last buffer-undo-list)) | |
| ;; `elt' is not in the log any more, but that's because | |
| ;; the log is "all new", so we should remove all | |
| ;; boundaries from it. | |
| (not (eq (last buffer-undo-list) (last old-cdr)))) | |
| (cl-callf (lambda (x) (delq nil x)) | |
| (if (car buffer-undo-list) | |
| buffer-undo-list | |
| ;; Preserve the undo-boundaries at either ends of the | |
| ;; change-groups. | |
| (cdr buffer-undo-list))))) | |
| ;; Reset the modified cons cell ELT to its original content. | |
| (when (consp elt) | |
| (setcar elt old-car) | |
| (setcdr elt old-cdr)))))))) | |
| (defcustom undo-ask-before-discard nil | |
| "If non-nil ask about discarding undo info for the current command. | |
| Normally, Emacs discards the undo info for the current command if | |
| it exceeds `undo-outer-limit'. But if you set this option | |
| non-nil, it asks in the echo area whether to discard the info. | |
| If you answer no, there is a slight risk that Emacs might crash, so | |
| do it only if you really want to undo the command. | |
| This option is mainly intended for debugging. You have to be | |
| careful if you use it for other purposes. Garbage collection is | |
| inhibited while the question is asked, meaning that Emacs might | |
| leak memory. So you should make sure that you do not wait | |
| excessively long before answering the question." | |
| :type 'boolean | |
| :group 'undo | |
| :version "22.1") | |
| (defvar undo-extra-outer-limit nil | |
| "If non-nil, an extra level of size that's ok in an undo item. | |
| We don't ask the user about truncating the undo list until the | |
| current item gets bigger than this amount. | |
| This variable matters only if `undo-ask-before-discard' is non-nil.") | |
| (make-variable-buffer-local 'undo-extra-outer-limit) | |
| ;; When the first undo batch in an undo list is longer than | |
| ;; undo-outer-limit, this function gets called to warn the user that | |
| ;; the undo info for the current command was discarded. Garbage | |
| ;; collection is inhibited around the call, so it had better not do a | |
| ;; lot of consing. | |
| (setq undo-outer-limit-function 'undo-outer-limit-truncate) | |
| (defun undo-outer-limit-truncate (size) | |
| (if undo-ask-before-discard | |
| (when (or (null undo-extra-outer-limit) | |
| (> size undo-extra-outer-limit)) | |
| ;; Don't ask the question again unless it gets even bigger. | |
| ;; This applies, in particular, if the user quits from the question. | |
| ;; Such a quit quits out of GC, but something else will call GC | |
| ;; again momentarily. It will call this function again, | |
| ;; but we don't want to ask the question again. | |
| (setq undo-extra-outer-limit (+ size 50000)) | |
| (if (let (use-dialog-box track-mouse executing-kbd-macro ) | |
| (yes-or-no-p (format-message | |
| "Buffer `%s' undo info is %d bytes long; discard it? " | |
| (buffer-name) size))) | |
| (progn (setq buffer-undo-list nil) | |
| (setq undo-extra-outer-limit nil) | |
| t) | |
| nil)) | |
| (display-warning '(undo discard-info) | |
| (concat | |
| (format-message | |
| "Buffer `%s' undo info was %d bytes long.\n" | |
| (buffer-name) size) | |
| "The undo info was discarded because it exceeded \ | |
| `undo-outer-limit'. | |
| This is normal if you executed a command that made a huge change | |
| to the buffer. In that case, to prevent similar problems in the | |
| future, set `undo-outer-limit' to a value that is large enough to | |
| cover the maximum size of normal changes you expect a single | |
| command to make, but not so large that it might exceed the | |
| maximum memory allotted to Emacs. | |
| If you did not execute any such command, the situation is | |
| probably due to a bug and you should report it. | |
| You can disable the popping up of this buffer by adding the entry | |
| \(undo discard-info) to the user option `warning-suppress-types', | |
| which is defined in the `warnings' library.\n") | |
| :warning) | |
| (setq buffer-undo-list nil) | |
| t)) | |
| (defvar shell-command-history nil | |
| "History list for some commands that read shell commands. | |
| Maximum length of the history list is determined by the value | |
| of `history-length', which see.") | |
| (defvar shell-command-switch (purecopy "-c") | |
| "Switch used to have the shell execute its command line argument.") | |
| (defvar shell-command-default-error-buffer nil | |
| "Buffer name for `shell-command' and `shell-command-on-region' error output. | |
| This buffer is used when `shell-command' or `shell-command-on-region' | |
| is run interactively. A value of nil means that output to stderr and | |
| stdout will be intermixed in the output stream.") | |
| (declare-function mailcap-file-default-commands "mailcap" (files)) | |
| (declare-function dired-get-filename "dired" (&optional localp no-error-if-not-filep)) | |
| (defun minibuffer-default-add-shell-commands () | |
| "Return a list of all commands associated with the current file. | |
| This function is used to add all related commands retrieved by `mailcap' | |
| to the end of the list of defaults just after the default value." | |
| (interactive) | |
| (let* ((filename (if (listp minibuffer-default) | |
| (car minibuffer-default) | |
| minibuffer-default)) | |
| (commands (and filename (require 'mailcap nil t) | |
| (mailcap-file-default-commands (list filename))))) | |
| (setq commands (mapcar (lambda (command) | |
| (concat command " " filename)) | |
| commands)) | |
| (if (listp minibuffer-default) | |
| (append minibuffer-default commands) | |
| (cons minibuffer-default commands)))) | |
| (declare-function shell-completion-vars "shell" ()) | |
| (defvar minibuffer-local-shell-command-map | |
| (let ((map (make-sparse-keymap))) | |
| (set-keymap-parent map minibuffer-local-map) | |
| (define-key map "\t" 'completion-at-point) | |
| map) | |
| "Keymap used for completing shell commands in minibuffer.") | |
| (defun read-shell-command (prompt &optional initial-contents hist &rest args) | |
| "Read a shell command from the minibuffer. | |
| The arguments are the same as the ones of `read-from-minibuffer', | |
| except READ and KEYMAP are missing and HIST defaults | |
| to `shell-command-history'." | |
| (require 'shell) | |
| (minibuffer-with-setup-hook | |
| (lambda () | |
| (shell-completion-vars) | |
| (set (make-local-variable 'minibuffer-default-add-function) | |
| 'minibuffer-default-add-shell-commands)) | |
| (apply #'read-from-minibuffer prompt initial-contents | |
| minibuffer-local-shell-command-map | |
| nil | |
| (or hist 'shell-command-history) | |
| args))) | |
| (defcustom async-shell-command-buffer 'confirm-new-buffer | |
| "What to do when the output buffer is used by another shell command. | |
| This option specifies how to resolve the conflict where a new command | |
| wants to direct its output to the buffer `*Async Shell Command*', | |
| but this buffer is already taken by another running shell command. | |
| The value `confirm-kill-process' is used to ask for confirmation before | |
| killing the already running process and running a new process | |
| in the same buffer, `confirm-new-buffer' for confirmation before running | |
| the command in a new buffer with a name other than the default buffer name, | |
| `new-buffer' for doing the same without confirmation, | |
| `confirm-rename-buffer' for confirmation before renaming the existing | |
| output buffer and running a new command in the default buffer, | |
| `rename-buffer' for doing the same without confirmation." | |
| :type '(choice (const :tag "Confirm killing of running command" | |
| confirm-kill-process) | |
| (const :tag "Confirm creation of a new buffer" | |
| confirm-new-buffer) | |
| (const :tag "Create a new buffer" | |
| new-buffer) | |
| (const :tag "Confirm renaming of existing buffer" | |
| confirm-rename-buffer) | |
| (const :tag "Rename the existing buffer" | |
| rename-buffer)) | |
| :group 'shell | |
| :version "24.3") | |
| (defcustom async-shell-command-display-buffer t | |
| "Whether to display the command buffer immediately. | |
| If t, display the buffer immediately; if nil, wait until there | |
| is output." | |
| :type '(choice (const :tag "Display buffer immediately" | |
| t) | |
| (const :tag "Display buffer on output" | |
| nil)) | |
| :group 'shell | |
| :version "26.1") | |
| (defcustom async-shell-command-width nil | |
| "Number of display columns available for asynchronous shell command output. | |
| If nil, use the shell default number (usually 80 columns). | |
| If a positive integer, tell the shell to use that number of columns for | |
| command output." | |
| :type '(choice (const :tag "Use system limit" nil) | |
| (integer :tag "Fixed width" :value 80)) | |
| :group 'shell | |
| :version "27.1") | |
| (defcustom shell-command-prompt-show-cwd nil | |
| "If non-nil, show current directory when prompting for a shell command. | |
| This affects `shell-command' and `async-shell-command'." | |
| :type 'boolean | |
| :group 'shell | |
| :version "27.1") | |
| (defcustom shell-command-dont-erase-buffer nil | |
| "Control if the output buffer is erased before the command. | |
| A nil value erases the output buffer before execution of the | |
| shell command, except when the output buffer is the current one. | |
| The value `erase' ensures the output buffer is erased before | |
| execution of the shell command. | |
| Other non-nil values prevent the output buffer from being erased and | |
| set the point after execution of the shell command. | |
| The value `beg-last-out' sets point at the beginning of the output, | |
| `end-last-out' sets point at the end of the buffer, `save-point' | |
| restores the buffer position before the command." | |
| :type '(choice | |
| (const :tag "Erase output buffer if not the current one" nil) | |
| (const :tag "Always erase output buffer" erase) | |
| (const :tag "Set point to beginning of last output" beg-last-out) | |
| (const :tag "Set point to end of last output" end-last-out) | |
| (const :tag "Save point" save-point)) | |
| :group 'shell | |
| :version "27.1") | |
| (defvar shell-command-saved-pos nil | |
| "Record of point positions in output buffers after command completion. | |
| The value is an alist whose elements are of the form (BUFFER . POS), | |
| where BUFFER is the output buffer, and POS is the point position | |
| in BUFFER once the command finishes. | |
| This variable is used when `shell-command-dont-erase-buffer' is non-nil.") | |
| (defun shell-command-save-pos-or-erase (&optional output-to-current-buffer) | |
| "Store a buffer position or erase the buffer. | |
| Optional argument OUTPUT-TO-CURRENT-BUFFER, if non-nil, means that the output | |
| of the shell command goes to the caller current buffer. | |
| See `shell-command-dont-erase-buffer'." | |
| (let ((sym shell-command-dont-erase-buffer) | |
| pos) | |
| (setq buffer-read-only nil) | |
| ;; Setting buffer-read-only to nil doesn't suffice | |
| ;; if some text has a non-nil read-only property, | |
| ;; which comint sometimes adds for prompts. | |
| (setq pos | |
| (cond ((eq sym 'save-point) (point)) | |
| ((eq sym 'beg-last-out) (point-max)) | |
| ;;((not sym) | |
| ((or (eq sym 'erase) | |
| (and (null sym) (not output-to-current-buffer))) | |
| (let ((inhibit-read-only t)) | |
| (erase-buffer) nil)))) | |
| (when pos | |
| (goto-char (point-max)) | |
| (push (cons (current-buffer) pos) | |
| shell-command-saved-pos)))) | |
| (defun shell-command-set-point-after-cmd (&optional buffer) | |
| "Set point in BUFFER after command complete. | |
| BUFFER is the output buffer of the command; if nil, then defaults | |
| to the current BUFFER. | |
| Set point to the `cdr' of the element in `shell-command-saved-pos' | |
| whose `car' is BUFFER." | |
| (when shell-command-dont-erase-buffer | |
| (let* ((sym shell-command-dont-erase-buffer) | |
| (buf (or buffer (current-buffer))) | |
| (pos (alist-get buf shell-command-saved-pos))) | |
| (setq shell-command-saved-pos | |
| (assq-delete-all buf shell-command-saved-pos)) | |
| (when (buffer-live-p buf) | |
| (let ((win (car (get-buffer-window-list buf))) | |
| (pmax (with-current-buffer buf (point-max)))) | |
| ;; The first time we run a command in a freshly created buffer | |
| ;; we have not saved positions yet; advance to `point-max', so that | |
| ;; successive commands know where to start. | |
| (unless (and pos (memq sym '(save-point beg-last-out end-last-out))) | |
| (setq pos pmax)) | |
| ;; Set point in the window displaying buf, if any; otherwise | |
| ;; display buf temporary in selected frame and set the point. | |
| (if win | |
| (set-window-point win pos) | |
| (when pos | |
| (with-current-buffer buf (goto-char pos))) | |
| (save-window-excursion | |
| (let ((win (display-buffer | |
| buf | |
| '(nil (inhibit-switch-frame . t))))) | |
| (set-window-point win pos))))))))) | |
| (defun async-shell-command (command &optional output-buffer error-buffer) | |
| "Execute string COMMAND asynchronously in background. | |
| Like `shell-command', but adds `&' at the end of COMMAND | |
| to execute it asynchronously. | |
| The output appears in the buffer `*Async Shell Command*'. | |
| That buffer is in shell mode. | |
| You can configure `async-shell-command-buffer' to specify what to do | |
| when the `*Async Shell Command*' buffer is already taken by another | |
| running shell command. To run COMMAND without displaying the output | |
| in a window you can configure `display-buffer-alist' to use the action | |
| `display-buffer-no-window' for the buffer `*Async Shell Command*'. | |
| In Elisp, you will often be better served by calling `start-process' | |
| directly, since it offers more control and does not impose the use of | |
| a shell (with its need to quote arguments)." | |
| (interactive | |
| (list | |
| (read-shell-command (if shell-command-prompt-show-cwd | |
| (format-message "Async shell command in `%s': " | |
| (abbreviate-file-name | |
| default-directory)) | |
| "Async shell command: ") | |
| nil nil | |
| (let ((filename | |
| (cond | |
| (buffer-file-name) | |
| ((eq major-mode 'dired-mode) | |
| (dired-get-filename nil t))))) | |
| (and filename (file-relative-name filename)))) | |
| current-prefix-arg | |
| shell-command-default-error-buffer)) | |
| (unless (string-match "&[ \t]*\\'" command) | |
| (setq command (concat command " &"))) | |
| (shell-command command output-buffer error-buffer)) | |
| (declare-function comint-output-filter "comint" (process string)) | |
| (defun shell-command (command &optional output-buffer error-buffer) | |
| "Execute string COMMAND in inferior shell; display output, if any. | |
| With prefix argument, insert the COMMAND's output at point. | |
| Interactively, prompt for COMMAND in the minibuffer. | |
| If `shell-command-prompt-show-cwd' is non-nil, show the current | |
| directory in the prompt. | |
| If COMMAND ends in `&', execute it asynchronously. | |
| The output appears in the buffer `*Async Shell Command*'. | |
| That buffer is in shell mode. You can also use | |
| `async-shell-command' that automatically adds `&'. | |
| Otherwise, COMMAND is executed synchronously. The output appears in | |
| the buffer `*Shell Command Output*'. If the output is short enough to | |
| display in the echo area (which is determined by the variables | |
| `resize-mini-windows' and `max-mini-window-height'), it is shown | |
| there, but it is nonetheless available in buffer `*Shell Command | |
| Output*' even though that buffer is not automatically displayed. | |
| To specify a coding system for converting non-ASCII characters | |
| in the shell command output, use \\[universal-coding-system-argument] \ | |
| before this command. | |
| Noninteractive callers can specify coding systems by binding | |
| `coding-system-for-read' and `coding-system-for-write'. | |
| The optional second argument OUTPUT-BUFFER, if non-nil, | |
| says to put the output in some other buffer. | |
| If OUTPUT-BUFFER is a buffer or buffer name, erase that buffer | |
| and insert the output there; a non-nil value of | |
| `shell-command-dont-erase-buffer' prevents the buffer from being | |
| erased. If OUTPUT-BUFFER is not a buffer and not nil, insert the | |
| output in current buffer after point leaving mark after it. This | |
| cannot be done asynchronously. | |
| If the command terminates without error, but generates output, | |
| and you did not specify \"insert it in the current buffer\", | |
| the output can be displayed in the echo area or in its buffer. | |
| If the output is short enough to display in the echo area | |
| \(determined by the variable `max-mini-window-height' if | |
| `resize-mini-windows' is non-nil), it is shown there. | |
| Otherwise, the buffer containing the output is displayed. | |
| If there is output and an error, and you did not specify \"insert it | |
| in the current buffer\", a message about the error goes at the end | |
| of the output. | |
| If the optional third argument ERROR-BUFFER is non-nil, it is a buffer | |
| or buffer name to which to direct the command's standard error output. | |
| If it is nil, error output is mingled with regular output. | |
| In an interactive call, the variable `shell-command-default-error-buffer' | |
| specifies the value of ERROR-BUFFER. | |
| In Elisp, you will often be better served by calling `call-process' or | |
| `start-process' directly, since they offer more control and do not | |
| impose the use of a shell (with its need to quote arguments)." | |
| (interactive | |
| (list | |
| (read-shell-command (if shell-command-prompt-show-cwd | |
| (format-message "Shell command in `%s': " | |
| (abbreviate-file-name | |
| default-directory)) | |
| "Shell command: ") | |
| nil nil | |
| (let ((filename | |
| (cond | |
| (buffer-file-name) | |
| ((eq major-mode 'dired-mode) | |
| (dired-get-filename nil t))))) | |
| (and filename (file-relative-name filename)))) | |
| current-prefix-arg | |
| shell-command-default-error-buffer)) | |
| ;; Look for a handler in case default-directory is a remote file name. | |
| (let ((handler | |
| (find-file-name-handler (directory-file-name default-directory) | |
| 'shell-command))) | |
| (if handler | |
| (funcall handler 'shell-command command output-buffer error-buffer) | |
| (if (and output-buffer | |
| (not (string-match "[ \t]*&[ \t]*\\'" command)) | |
| (or (eq output-buffer (current-buffer)) | |
| (and (stringp output-buffer) (eq (get-buffer output-buffer) (current-buffer))) | |
| (not (or (bufferp output-buffer) (stringp output-buffer))))) ; Bug#39067 | |
| ;; Synchronous command with output in current buffer. | |
| (let ((error-file | |
| (and error-buffer | |
| (make-temp-file | |
| (expand-file-name "scor" | |
| (or small-temporary-file-directory | |
| temporary-file-directory)))))) | |
| (barf-if-buffer-read-only) | |
| (push-mark nil t) | |
| (shell-command-save-pos-or-erase 'output-to-current-buffer) | |
| ;; We do not use -f for csh; we will not support broken use of | |
| ;; .cshrcs. Even the BSD csh manual says to use | |
| ;; "if ($?prompt) exit" before things that are not useful | |
| ;; non-interactively. Besides, if someone wants their other | |
| ;; aliases for shell commands then they can still have them. | |
| (call-process-shell-command command nil (if error-file | |
| (list t error-file) | |
| t)) | |
| (when (and error-file (file-exists-p error-file)) | |
| (when (< 0 (file-attribute-size (file-attributes error-file))) | |
| (with-current-buffer (get-buffer-create error-buffer) | |
| (let ((pos-from-end (- (point-max) (point)))) | |
| (or (bobp) | |
| (insert "\f\n")) | |
| ;; Do no formatting while reading error file, | |
| ;; because that can run a shell command, and we | |
| ;; don't want that to cause an infinite recursion. | |
| (format-insert-file error-file nil) | |
| ;; Put point after the inserted errors. | |
| (goto-char (- (point-max) pos-from-end))) | |
| (display-buffer (current-buffer)))) | |
| (delete-file error-file)) | |
| ;; This is like exchange-point-and-mark, but doesn't | |
| ;; activate the mark. It is cleaner to avoid activation, | |
| ;; even though the command loop would deactivate the mark | |
| ;; because we inserted text. | |
| (goto-char (prog1 (mark t) | |
| (set-marker (mark-marker) (point) | |
| (current-buffer)))) | |
| (shell-command-set-point-after-cmd)) | |
| ;; Output goes in a separate buffer. | |
| ;; Preserve the match data in case called from a program. | |
| ;; FIXME: It'd be ridiculous for an Elisp function to call | |
| ;; shell-command and assume that it won't mess the match-data! | |
| (save-match-data | |
| (if (string-match "[ \t]*&[ \t]*\\'" command) | |
| ;; Command ending with ampersand means asynchronous. | |
| (let* ((buffer (get-buffer-create | |
| (or output-buffer "*Async Shell Command*"))) | |
| (bname (buffer-name buffer)) | |
| (proc (get-buffer-process buffer)) | |
| (directory default-directory)) | |
| ;; Remove the ampersand. | |
| (setq command (substring command 0 (match-beginning 0))) | |
| ;; Ask the user what to do with already running process. | |
| (when proc | |
| (cond | |
| ((eq async-shell-command-buffer 'confirm-kill-process) | |
| ;; If will kill a process, query first. | |
| (if (yes-or-no-p "A command is running in the default buffer. Kill it? ") | |
| (kill-process proc) | |
| (user-error "Shell command in progress"))) | |
| ((eq async-shell-command-buffer 'confirm-new-buffer) | |
| ;; If will create a new buffer, query first. | |
| (if (yes-or-no-p "A command is running in the default buffer. Use a new buffer? ") | |
| (setq buffer (generate-new-buffer bname)) | |
| (user-error "Shell command in progress"))) | |
| ((eq async-shell-command-buffer 'new-buffer) | |
| ;; It will create a new buffer. | |
| (setq buffer (generate-new-buffer bname))) | |
| ((eq async-shell-command-buffer 'confirm-rename-buffer) | |
| ;; If will rename the buffer, query first. | |
| (if (yes-or-no-p "A command is running in the default buffer. Rename it? ") | |
| (progn | |
| (with-current-buffer buffer | |
| (rename-uniquely)) | |
| (setq buffer (get-buffer-create bname))) | |
| (user-error "Shell command in progress"))) | |
| ((eq async-shell-command-buffer 'rename-buffer) | |
| ;; It will rename the buffer. | |
| (with-current-buffer buffer | |
| (rename-uniquely)) | |
| (setq buffer (get-buffer-create bname))))) | |
| (with-current-buffer buffer | |
| (shell-command-save-pos-or-erase) | |
| (setq default-directory directory) | |
| (let ((process-environment | |
| (if (natnump async-shell-command-width) | |
| (cons (format "COLUMNS=%d" async-shell-command-width) | |
| process-environment) | |
| process-environment))) | |
| (setq proc | |
| (start-process-shell-command "Shell" buffer command))) | |
| (setq mode-line-process '(":%s")) | |
| (require 'shell) (shell-mode) | |
| (set-process-sentinel proc #'shell-command-sentinel) | |
| ;; Use the comint filter for proper handling of | |
| ;; carriage motion (see comint-inhibit-carriage-motion). | |
| (set-process-filter proc #'comint-output-filter) | |
| (if async-shell-command-display-buffer | |
| ;; Display buffer immediately. | |
| (display-buffer buffer '(nil (allow-no-window . t))) | |
| ;; Defer displaying buffer until first process output. | |
| ;; Use disposable named advice so that the buffer is | |
| ;; displayed at most once per process lifetime. | |
| (let ((nonce (make-symbol "nonce"))) | |
| (add-function :before (process-filter proc) | |
| (lambda (proc _string) | |
| (let ((buf (process-buffer proc))) | |
| (when (buffer-live-p buf) | |
| (remove-function (process-filter proc) | |
| nonce) | |
| (display-buffer buf)))) | |
| `((name . ,nonce))))))) | |
| ;; Otherwise, command is executed synchronously. | |
| (shell-command-on-region (point) (point) command | |
| output-buffer nil error-buffer))))))) | |
| (defun display-message-or-buffer (message &optional buffer-name action frame) | |
| "Display MESSAGE in the echo area if possible, otherwise in a pop-up buffer. | |
| MESSAGE may be either a string or a buffer. | |
| A pop-up buffer is displayed using `display-buffer' if MESSAGE is too long | |
| for maximum height of the echo area, as defined by `max-mini-window-height' | |
| if `resize-mini-windows' is non-nil. | |
| Returns either the string shown in the echo area, or when a pop-up | |
| buffer is used, the window used to display it. | |
| If MESSAGE is a string, then the optional argument BUFFER-NAME is the | |
| name of the buffer used to display it in the case where a pop-up buffer | |
| is used, defaulting to `*Message*'. In the case where MESSAGE is a | |
| string and it is displayed in the echo area, it is not specified whether | |
| the contents are inserted into the buffer anyway. | |
| Optional arguments ACTION and FRAME are as for `display-buffer', | |
| and are used only if a pop-up buffer is displayed." | |
| (cond ((and (stringp message) (not (string-match "\n" message))) | |
| ;; Trivial case where we can use the echo area | |
| (message "%s" message)) | |
| ((and (stringp message) | |
| (= (string-match "\n" message) (1- (length message)))) | |
| ;; Trivial case where we can just remove single trailing newline | |
| (message "%s" (substring message 0 (1- (length message))))) | |
| (t | |
| ;; General case | |
| (with-current-buffer | |
| (if (bufferp message) | |
| message | |
| (get-buffer-create (or buffer-name "*Message*"))) | |
| (unless (bufferp message) | |
| (erase-buffer) | |
| (insert message)) | |
| (let ((lines | |
| (if (= (buffer-size) 0) | |
| 0 | |
| (count-screen-lines nil nil nil (minibuffer-window))))) | |
| (cond ((= lines 0)) | |
| ((and (or (<= lines 1) | |
| (<= lines | |
| (if resize-mini-windows | |
| (cond ((floatp max-mini-window-height) | |
| (* (frame-height) | |
| max-mini-window-height)) | |
| ((integerp max-mini-window-height) | |
| max-mini-window-height) | |
| (t | |
| 1)) | |
| 1))) | |
| ;; Don't use the echo area if the output buffer is | |
| ;; already displayed in the selected frame. | |
| (not (get-buffer-window (current-buffer)))) | |
| ;; Echo area | |
| (goto-char (point-max)) | |
| (when (bolp) | |
| (backward-char 1)) | |
| (message "%s" (buffer-substring (point-min) (point)))) | |
| (t | |
| ;; Buffer | |
| (goto-char (point-min)) | |
| (display-buffer (current-buffer) action frame)))))))) | |
| ;; We have a sentinel to prevent insertion of a termination message | |
| ;; in the buffer itself, and to set the point in the buffer when | |
| ;; `shell-command-dont-erase-buffer' is non-nil. | |
| (defun shell-command-sentinel (process signal) | |
| (when (memq (process-status process) '(exit signal)) | |
| (shell-command-set-point-after-cmd (process-buffer process)) | |
| (message "%s: %s." | |
| (car (cdr (cdr (process-command process)))) | |
| (substring signal 0 -1)))) | |
| (defun shell-command-on-region (start end command | |
| &optional output-buffer replace | |
| error-buffer display-error-buffer | |
| region-noncontiguous-p) | |
| "Execute string COMMAND in inferior shell with region as input. | |
| Normally display output (if any) in temp buffer `*Shell Command Output*'; | |
| Prefix arg means replace the region with it. Return the exit code of | |
| COMMAND. | |
| To specify a coding system for converting non-ASCII characters | |
| in the input and output to the shell command, use \\[universal-coding-system-argument] | |
| before this command. By default, the input (from the current buffer) | |
| is encoded using coding-system specified by `process-coding-system-alist', | |
| falling back to `default-process-coding-system' if no match for COMMAND | |
| is found in `process-coding-system-alist'. | |
| Noninteractive callers can specify coding systems by binding | |
| `coding-system-for-read' and `coding-system-for-write'. | |
| If the command generates output, the output may be displayed | |
| in the echo area or in a buffer. | |
| If the output is short enough to display in the echo area | |
| \(determined by the variable `max-mini-window-height' if | |
| `resize-mini-windows' is non-nil), it is shown there. | |
| Otherwise it is displayed in the buffer `*Shell Command Output*'. | |
| The output is available in that buffer in both cases. | |
| If there is output and an error, a message about the error | |
| appears at the end of the output. | |
| Optional fourth arg OUTPUT-BUFFER specifies where to put the | |
| command's output. If the value is a buffer or buffer name, | |
| erase that buffer and insert the output there; a non-nil value of | |
| `shell-command-dont-erase-buffer' prevent to erase the buffer. | |
| If the value is nil, use the buffer `*Shell Command Output*'. | |
| Any other non-nil value means to insert the output in the | |
| current buffer after START. | |
| Optional fifth arg REPLACE, if non-nil, means to insert the | |
| output in place of text from START to END, putting point and mark | |
| around it. | |
| Optional sixth arg ERROR-BUFFER, if non-nil, specifies a buffer | |
| or buffer name to which to direct the command's standard error | |
| output. If nil, error output is mingled with regular output. | |
| When called interactively, `shell-command-default-error-buffer' | |
| is used for ERROR-BUFFER. | |
| Optional seventh arg DISPLAY-ERROR-BUFFER, if non-nil, means to | |
| display the error buffer if there were any errors. When called | |
| interactively, this is t." | |
| (interactive (let (string) | |
| (unless (mark) | |
| (user-error "The mark is not set now, so there is no region")) | |
| ;; Do this before calling region-beginning | |
| ;; and region-end, in case subprocess output | |
| ;; relocates them while we are in the minibuffer. | |
| (setq string (read-shell-command "Shell command on region: ")) | |
| ;; call-interactively recognizes region-beginning and | |
| ;; region-end specially, leaving them in the history. | |
| (list (region-beginning) (region-end) | |
| string | |
| current-prefix-arg | |
| current-prefix-arg | |
| shell-command-default-error-buffer | |
| t | |
| (region-noncontiguous-p)))) | |
| (let ((error-file | |
| (if error-buffer | |
| (make-temp-file | |
| (expand-file-name "scor" | |
| (or small-temporary-file-directory | |
| temporary-file-directory))) | |
| nil)) | |
| exit-status) | |
| ;; Unless a single contiguous chunk is selected, operate on multiple chunks. | |
| (if region-noncontiguous-p | |
| (let ((input (concat (funcall region-extract-function 'delete) "\n")) | |
| output) | |
| (with-temp-buffer | |
| (insert input) | |
| (call-process-region (point-min) (point-max) | |
| shell-file-name t t | |
| nil shell-command-switch | |
| command) | |
| (setq output (split-string (buffer-string) "\n"))) | |
| (goto-char start) | |
| (funcall region-insert-function output)) | |
| (if (or replace | |
| (and output-buffer | |
| (not (or (bufferp output-buffer) (stringp output-buffer))))) | |
| ;; Replace specified region with output from command. | |
| (let ((swap (and replace (< start end)))) | |
| ;; Don't muck with mark unless REPLACE says we should. | |
| (goto-char start) | |
| (and replace (push-mark (point) 'nomsg)) | |
| (setq exit-status | |
| (call-shell-region start end command replace | |
| (if error-file | |
| (list t error-file) | |
| t))) | |
| ;; It is rude to delete a buffer that the command is not using. | |
| ;; (let ((shell-buffer (get-buffer "*Shell Command Output*"))) | |
| ;; (and shell-buffer (not (eq shell-buffer (current-buffer))) | |
| ;; (kill-buffer shell-buffer))) | |
| ;; Don't muck with mark unless REPLACE says we should. | |
| (and replace swap (exchange-point-and-mark))) | |
| ;; No prefix argument: put the output in a temp buffer, | |
| ;; replacing its entire contents. | |
| (let ((buffer (get-buffer-create | |
| (or output-buffer "*Shell Command Output*")))) | |
| (set-buffer-major-mode buffer) ; Enable globalized modes (bug#38111) | |
| (unwind-protect | |
| (if (and (eq buffer (current-buffer)) | |
| (or (memq shell-command-dont-erase-buffer '(nil erase)) | |
| (and (not (eq buffer (get-buffer "*Shell Command Output*"))) | |
| (not (region-active-p))))) | |
| ;; If the input is the same buffer as the output, | |
| ;; delete everything but the specified region, | |
| ;; then replace that region with the output. | |
| (progn (setq buffer-read-only nil) | |
| (delete-region (max start end) (point-max)) | |
| (delete-region (point-min) (min start end)) | |
| (setq exit-status | |
| (call-process-region (point-min) (point-max) | |
| shell-file-name t | |
| (if error-file | |
| (list t error-file) | |
| t) | |
| nil shell-command-switch | |
| command))) | |
| ;; Clear the output buffer, then run the command with | |
| ;; output there. | |
| (let ((directory default-directory)) | |
| (with-current-buffer buffer | |
| (if (not output-buffer) | |
| (setq default-directory directory)) | |
| (shell-command-save-pos-or-erase))) | |
| (setq exit-status | |
| (call-shell-region start end command nil | |
| (if error-file | |
| (list buffer error-file) | |
| buffer)))) | |
| ;; Report the output. | |
| (with-current-buffer buffer | |
| (setq mode-line-process | |
| (cond ((null exit-status) | |
| " - Error") | |
| ((stringp exit-status) | |
| (format " - Signal [%s]" exit-status)) | |
| ((not (equal 0 exit-status)) | |
| (format " - Exit [%d]" exit-status))))) | |
| (if (with-current-buffer buffer (> (point-max) (point-min))) | |
| ;; There's some output, display it | |
| (progn | |
| (display-message-or-buffer buffer) | |
| (shell-command-set-point-after-cmd buffer)) | |
| ;; No output; error? | |
| (let ((output | |
| (if (and error-file | |
| (< 0 (file-attribute-size | |
| (file-attributes error-file)))) | |
| (format "some error output%s" | |
| (if shell-command-default-error-buffer | |
| (format " to the \"%s\" buffer" | |
| shell-command-default-error-buffer) | |
| "")) | |
| "no output"))) | |
| (cond ((null exit-status) | |
| (message "(Shell command failed with error)")) | |
| ((equal 0 exit-status) | |
| (message "(Shell command succeeded with %s)" | |
| output)) | |
| ((stringp exit-status) | |
| (message "(Shell command killed by signal %s)" | |
| exit-status)) | |
| (t | |
| (message "(Shell command failed with code %d and %s)" | |
| exit-status output)))) | |
| ;; Don't kill: there might be useful info in the undo-log. | |
| ;; (kill-buffer buffer) | |
| ))))) | |
| (when (and error-file (file-exists-p error-file)) | |
| (if (< 0 (file-attribute-size (file-attributes error-file))) | |
| (with-current-buffer (get-buffer-create error-buffer) | |
| (goto-char (point-max)) | |
| ;; Insert a separator if there's already text here. | |
| (unless (bobp) | |
| (insert "\f\n")) | |
| ;; Do no formatting while reading error file, | |
| ;; because that can run a shell command, and we | |
| ;; don't want that to cause an infinite recursion. | |
| (format-insert-file error-file nil) | |
| (and display-error-buffer | |
| (display-buffer (current-buffer))))) | |
| (delete-file error-file)) | |
| exit-status)) | |
| (defun shell-command-to-string (command) | |
| "Execute shell command COMMAND and return its output as a string." | |
| (with-output-to-string | |
| (with-current-buffer | |
| standard-output | |
| (shell-command command t)))) | |
| (defun process-file (program &optional infile buffer display &rest args) | |
| "Process files synchronously in a separate process that runs PROGRAM. | |
| Similar to `call-process', but may invoke a file name handler based on | |
| `default-directory'. The current working directory of the | |
| subprocess is `default-directory'. | |
| If PROGRAM is a remote file name, it should be processed | |
| by `file-local-name' before passing it to this function. | |
| Handle file names in INFILE and BUFFER normally; this differs | |
| from `call-process', which does not support file name handlers | |
| for INFILE and BUFFER. However, pass ARGS to the process | |
| verbatim without file name handling, as `call-process' does. | |
| Some file name handlers might not support all variants. For | |
| example, they might treat DISPLAY as nil regardless of the actual | |
| value passed." | |
| (let ((fh (find-file-name-handler default-directory 'process-file)) | |
| lc stderr-file) | |
| (unwind-protect | |
| (if fh (apply fh 'process-file program infile buffer display args) | |
| (when infile (setq lc (file-local-copy infile))) | |
| (setq stderr-file (when (and (consp buffer) (stringp (cadr buffer))) | |
| (make-temp-file "emacs"))) | |
| (prog1 | |
| (apply 'call-process program | |
| (or lc infile) | |
| (if stderr-file (list (car buffer) stderr-file) buffer) | |
| display args) | |
| (when stderr-file (copy-file stderr-file (cadr buffer) t)))) | |
| (when stderr-file (delete-file stderr-file)) | |
| (when lc (delete-file lc))))) | |
| (defvar process-file-side-effects t | |
| "Whether a call of `process-file' changes remote files. | |
| By default, this variable is always set to t, meaning that a | |
| call of `process-file' could potentially change any file on a | |
| remote host. When set to nil, a file name handler could optimize | |
| its behavior with respect to remote file attribute caching. | |
| You should only ever change this variable with a let-binding; | |
| never with `setq'.") | |
| (defun start-file-process (name buffer program &rest program-args) | |
| "Start a program in a subprocess. Return the process object for it. | |
| Similar to `start-process', but may invoke a file name handler based on | |
| `default-directory'. See Info node `(elisp)Magic File Names'. | |
| This handler ought to run PROGRAM, perhaps on the local host, | |
| perhaps on a remote host that corresponds to `default-directory'. | |
| In the latter case, the local part of `default-directory', the one | |
| produced from it by `file-local-name', becomes the working directory | |
| of the process on the remote host. | |
| PROGRAM and PROGRAM-ARGS might be file names. They are not | |
| objects of file name handler invocation, so they need to be obtained | |
| by calling `file-local-name', in case they are remote file names. | |
| File name handlers might not support pty association, if PROGRAM is nil." | |
| (let ((fh (find-file-name-handler default-directory 'start-file-process))) | |
| (if fh (apply fh 'start-file-process name buffer program program-args) | |
| (apply 'start-process name buffer program program-args)))) | |
| ;;;; Process menu | |
| (defvar tabulated-list-format) | |
| (defvar tabulated-list-entries) | |
| (defvar tabulated-list-sort-key) | |
| (declare-function tabulated-list-init-header "tabulated-list" ()) | |
| (declare-function tabulated-list-print "tabulated-list" | |
| (&optional remember-pos update)) | |
| (defvar process-menu-query-only nil) | |
| (defvar process-menu-mode-map | |
| (let ((map (make-sparse-keymap))) | |
| (define-key map [?d] 'process-menu-delete-process) | |
| map)) | |
| (define-derived-mode process-menu-mode tabulated-list-mode "Process Menu" | |
| "Major mode for listing the processes called by Emacs." | |
| (setq tabulated-list-format [("Process" 15 t) | |
| ("PID" 7 t) | |
| ("Status" 7 t) | |
| ;; 25 is the length of the long standard buffer | |
| ;; name "*Async Shell Command*<10>" (bug#30016) | |
| ("Buffer" 25 t) | |
| ("TTY" 12 t) | |
| ("Thread" 12 t) | |
| ("Command" 0 t)]) | |
| (make-local-variable 'process-menu-query-only) | |
| (setq tabulated-list-sort-key (cons "Process" nil)) | |
| (add-hook 'tabulated-list-revert-hook 'list-processes--refresh nil t)) | |
| (defun process-menu-delete-process () | |
| "Kill process at point in a `list-processes' buffer." | |
| (interactive) | |
| (let ((pos (point))) | |
| (delete-process (tabulated-list-get-id)) | |
| (revert-buffer) | |
| (goto-char (min pos (point-max))) | |
| (if (eobp) | |
| (forward-line -1) | |
| (beginning-of-line)))) | |
| (defun list-processes--refresh () | |
| "Recompute the list of processes for the Process List buffer. | |
| Also, delete any process that is exited or signaled." | |
| (setq tabulated-list-entries nil) | |
| (dolist (p (process-list)) | |
| (cond ((memq (process-status p) '(exit signal closed)) | |
| (delete-process p)) | |
| ((or (not process-menu-query-only) | |
| (process-query-on-exit-flag p)) | |
| (let* ((buf (process-buffer p)) | |
| (type (process-type p)) | |
| (pid (if (process-id p) (format "%d" (process-id p)) "--")) | |
| (name (process-name p)) | |
| (status (symbol-name (process-status p))) | |
| (buf-label (if (buffer-live-p buf) | |
| `(,(buffer-name buf) | |
| face link | |
| help-echo ,(format-message | |
| "Visit buffer `%s'" | |
| (buffer-name buf)) | |
| follow-link t | |
| process-buffer ,buf | |
| action process-menu-visit-buffer) | |
| "--")) | |
| (tty (or (process-tty-name p) "--")) | |
| (thread | |
| (cond | |
| ((or | |
| (null (process-thread p)) | |
| (not (fboundp 'thread-name))) "--") | |
| ((eq (process-thread p) main-thread) "Main") | |
| ((thread-name (process-thread p))) | |
| (t "--"))) | |
| (cmd | |
| (if (memq type '(network serial)) | |
| (let ((contact (process-contact p t t))) | |
| (if (eq type 'network) | |
| (format "(%s %s)" | |
| (if (plist-get contact :type) | |
| "datagram" | |
| "network") | |
| (if (plist-get contact :server) | |
| (format | |
| "server on %s" | |
| (if (plist-get contact :host) | |
| (format "%s:%s" | |
| (plist-get contact :host) | |
| (plist-get | |
| contact :service)) | |
| (plist-get contact :local))) | |
| (format "connection to %s:%s" | |
| (plist-get contact :host) | |
| (plist-get contact :service)))) | |
| (format "(serial port %s%s)" | |
| (or (plist-get contact :port) "?") | |
| (let ((speed (plist-get contact :speed))) | |
| (if speed | |
| (format " at %s b/s" speed) | |
| ""))))) | |
| (mapconcat 'identity (process-command p) " ")))) | |
| (push (list p (vector name pid status buf-label tty thread cmd)) | |
| tabulated-list-entries))))) | |
| (tabulated-list-init-header)) | |
| (defun process-menu-visit-buffer (button) | |
| (display-buffer (button-get button 'process-buffer))) | |
| (defun list-processes (&optional query-only buffer) | |
| "Display a list of all processes that are Emacs sub-processes. | |
| If optional argument QUERY-ONLY is non-nil, only processes with | |
| the query-on-exit flag set are listed. | |
| Any process listed as exited or signaled is actually eliminated | |
| after the listing is made. | |
| Optional argument BUFFER specifies a buffer to use, instead of | |
| \"*Process List*\". | |
| The return value is always nil. | |
| This function lists only processes that were launched by Emacs. To | |
| see other processes running on the system, use `list-system-processes'." | |
| (interactive) | |
| (or (fboundp 'process-list) | |
| (error "Asynchronous subprocesses are not supported on this system")) | |
| (unless (bufferp buffer) | |
| (setq buffer (get-buffer-create "*Process List*"))) | |
| (with-current-buffer buffer | |
| (process-menu-mode) | |
| (setq process-menu-query-only query-only) | |
| (list-processes--refresh) | |
| (tabulated-list-print)) | |
| (display-buffer buffer) | |
| nil) | |
| ;;;; Prefix commands | |
| (setq prefix-command--needs-update nil) | |
| (setq prefix-command--last-echo nil) | |
| (defun internal-echo-keystrokes-prefix () | |
| ;; BEWARE: Called directly from C code. | |
| ;; If the return value is non-nil, it means we are in the middle of | |
| ;; a command with prefix, such as a command invoked with prefix-arg. | |
| (if (not prefix-command--needs-update) | |
| prefix-command--last-echo | |
| (setq prefix-command--last-echo | |
| (let ((strs nil)) | |
| (run-hook-wrapped 'prefix-command-echo-keystrokes-functions | |
| (lambda (fun) (push (funcall fun) strs))) | |
| (setq strs (delq nil strs)) | |
| (when strs (mapconcat #'identity strs " ")))))) | |
| (defvar prefix-command-echo-keystrokes-functions nil | |
| "Abnormal hook that constructs the description of the current prefix state. | |
| Each function is called with no argument, should return a string or nil.") | |
| (defun prefix-command-update () | |
| "Update state of prefix commands. | |
| Call it whenever you change the \"prefix command state\"." | |
| (setq prefix-command--needs-update t)) | |
| (defvar prefix-command-preserve-state-hook nil | |
| "Normal hook run when a command needs to preserve the prefix.") | |
| (defun prefix-command-preserve-state () | |
| "Pass the current prefix command state to the next command. | |
| Should be called by all prefix commands. | |
| Runs `prefix-command-preserve-state-hook'." | |
| (run-hooks 'prefix-command-preserve-state-hook) | |
| ;; If the current command is a prefix command, we don't want the next (real) | |
| ;; command to have `last-command' set to, say, `universal-argument'. | |
| (setq this-command last-command) | |
| (setq real-this-command real-last-command) | |
| (prefix-command-update)) | |
| (defun reset-this-command-lengths () | |
| (declare (obsolete prefix-command-preserve-state "25.1")) | |
| nil) | |
| ;;;;; The main prefix command. | |
| ;; FIXME: Declaration of `prefix-arg' should be moved here!? | |
| (add-hook 'prefix-command-echo-keystrokes-functions | |
| #'universal-argument--description) | |
| (defun universal-argument--description () | |
| (when prefix-arg | |
| (concat "C-u" | |
| (pcase prefix-arg | |
| ('(-) " -") | |
| (`(,(and (pred integerp) n)) | |
| (let ((str "")) | |
| (while (and (> n 4) (= (mod n 4) 0)) | |
| (setq str (concat str " C-u")) | |
| (setq n (/ n 4))) | |
| (if (= n 4) str (format " %s" prefix-arg)))) | |
| (_ (format " %s" prefix-arg)))))) | |
| (add-hook 'prefix-command-preserve-state-hook | |
| #'universal-argument--preserve) | |
| (defun universal-argument--preserve () | |
| (setq prefix-arg current-prefix-arg)) | |
| (defvar universal-argument-map | |
| (let ((map (make-sparse-keymap)) | |
| (universal-argument-minus | |
| ;; For backward compatibility, minus with no modifiers is an ordinary | |
| ;; command if digits have already been entered. | |
| `(menu-item "" negative-argument | |
| :filter ,(lambda (cmd) | |
| (if (integerp prefix-arg) nil cmd))))) | |
| (define-key map [switch-frame] | |
| (lambda (e) (interactive "e") | |
| (handle-switch-frame e) (universal-argument--mode))) | |
| (define-key map [?\C-u] 'universal-argument-more) | |
| (define-key map [?-] universal-argument-minus) | |
| (define-key map [?0] 'digit-argument) | |
| (define-key map [?1] 'digit-argument) | |
| (define-key map [?2] 'digit-argument) | |
| (define-key map [?3] 'digit-argument) | |
| (define-key map [?4] 'digit-argument) | |
| (define-key map [?5] 'digit-argument) | |
| (define-key map [?6] 'digit-argument) | |
| (define-key map [?7] 'digit-argument) | |
| (define-key map [?8] 'digit-argument) | |
| (define-key map [?9] 'digit-argument) | |
| (define-key map [kp-0] 'digit-argument) | |
| (define-key map [kp-1] 'digit-argument) | |
| (define-key map [kp-2] 'digit-argument) | |
| (define-key map [kp-3] 'digit-argument) | |
| (define-key map [kp-4] 'digit-argument) | |
| (define-key map [kp-5] 'digit-argument) | |
| (define-key map [kp-6] 'digit-argument) | |
| (define-key map [kp-7] 'digit-argument) | |
| (define-key map [kp-8] 'digit-argument) | |
| (define-key map [kp-9] 'digit-argument) | |
| (define-key map [kp-subtract] universal-argument-minus) | |
| map) | |
| "Keymap used while processing \\[universal-argument].") | |
| (defun universal-argument--mode () | |
| (prefix-command-update) | |
| (set-transient-map universal-argument-map nil)) | |
| (defun universal-argument () | |
| "Begin a numeric argument for the following command. | |
| Digits or minus sign following \\[universal-argument] make up the numeric argument. | |
| \\[universal-argument] following the digits or minus sign ends the argument. | |
| \\[universal-argument] without digits or minus sign provides 4 as argument. | |
| Repeating \\[universal-argument] without digits or minus sign | |
| multiplies the argument by 4 each time. | |
| For some commands, just \\[universal-argument] by itself serves as a flag | |
| that is different in effect from any particular numeric argument. | |
| These commands include \\[set-mark-command] and \\[start-kbd-macro]." | |
| (interactive) | |
| (prefix-command-preserve-state) | |
| (setq prefix-arg (list 4)) | |
| (universal-argument--mode)) | |
| (defun universal-argument-more (arg) | |
| ;; A subsequent C-u means to multiply the factor by 4 if we've typed | |
| ;; nothing but C-u's; otherwise it means to terminate the prefix arg. | |
| (interactive "P") | |
| (prefix-command-preserve-state) | |
| (setq prefix-arg (if (consp arg) | |
| (list (* 4 (car arg))) | |
| (if (eq arg '-) | |
| (list -4) | |
| arg))) | |
| (when (consp prefix-arg) (universal-argument--mode))) | |
| (defun negative-argument (arg) | |
| "Begin a negative numeric argument for the next command. | |
| \\[universal-argument] following digits or minus sign ends the argument." | |
| (interactive "P") | |
| (prefix-command-preserve-state) | |
| (setq prefix-arg (cond ((integerp arg) (- arg)) | |
| ((eq arg '-) nil) | |
| (t '-))) | |
| (universal-argument--mode)) | |
| (defun digit-argument (arg) | |
| "Part of the numeric argument for the next command. | |
| \\[universal-argument] following digits or minus sign ends the argument." | |
| (interactive "P") | |
| (prefix-command-preserve-state) | |
| (let* ((char (if (integerp last-command-event) | |
| last-command-event | |
| (get last-command-event 'ascii-character))) | |
| (digit (- (logand char ?\177) ?0))) | |
| (setq prefix-arg (cond ((integerp arg) | |
| (+ (* arg 10) | |
| (if (< arg 0) (- digit) digit))) | |
| ((eq arg '-) | |
| ;; Treat -0 as just -, so that -01 will work. | |
| (if (zerop digit) '- (- digit))) | |
| (t | |
| digit)))) | |
| (universal-argument--mode)) | |
| (defvar universal-async-argument nil | |
| "Non-nil means a command invoked interactively can run asynchronously. | |
| It is run asynchronously only if the command also allows that. | |
| The semantics depend on the command. This variable should not be | |
| set globally, it should be used in let-bindings only.") | |
| (defun universal-async-argument () | |
| "Execute an interactive command asynchronously." | |
| (interactive) | |
| (let* ((universal-async-argument (not universal-async-argument)) | |
| (keyseq (read-key-sequence nil t)) | |
| (cmd (key-binding keyseq)) | |
| prefix) | |
| ;; `read-key-sequence' ignores quit, so make an explicit check. | |
| (if (equal last-input-event (nth 3 (current-input-mode))) | |
| (keyboard-quit)) | |
| (when (memq cmd '(universal-argument digit-argument negative-argument)) | |
| (call-interactively cmd) | |
| ;; Process keys bound in `universal-argument-map'. | |
| (while (progn | |
| (setq keyseq (read-key-sequence nil t) | |
| cmd (key-binding keyseq t)) | |
| (not (eq cmd 'universal-argument-other-key))) | |
| (let ((current-prefix-arg prefix-arg) | |
| ;; Have to bind `last-command-event' here so that | |
| ;; `digit-argument', for instance, can compute the | |
| ;; `prefix-arg'. | |
| (last-command-event (aref keyseq 0))) | |
| (call-interactively cmd))) | |
| ;; This is the final call to `universal-argument-other-key', which | |
| ;; sets the final `prefix-arg'. | |
| (let ((current-prefix-arg prefix-arg)) | |
| (call-interactively cmd)) | |
| ;; Read the command to execute with the given `prefix-arg'. | |
| (setq prefix prefix-arg | |
| keyseq (read-key-sequence nil t) | |
| cmd (key-binding keyseq))) | |
| (let ((current-prefix-arg prefix)) | |
| (message "") | |
| (call-interactively cmd)))) | |
| (define-key ctl-x-map "&" 'universal-async-argument) | |
| (defvar filter-buffer-substring-functions nil | |
| "This variable is a wrapper hook around `buffer-substring--filter'. | |
| \(See `with-wrapper-hook' for details about wrapper hooks.)") | |
| (make-obsolete-variable 'filter-buffer-substring-functions | |
| 'filter-buffer-substring-function "24.4") | |
| (defvar filter-buffer-substring-function #'buffer-substring--filter | |
| "Function to perform the filtering in `filter-buffer-substring'. | |
| The function is called with the same 3 arguments (BEG END DELETE) | |
| that `filter-buffer-substring' received. It should return the | |
| buffer substring between BEG and END, after filtering. If DELETE is | |
| non-nil, it should delete the text between BEG and END from the buffer.") | |
| (defvar buffer-substring-filters nil | |
| "List of filter functions for `buffer-substring--filter'. | |
| Each function must accept a single argument, a string, and return a string. | |
| The buffer substring is passed to the first function in the list, | |
| and the return value of each function is passed to the next. | |
| As a special convention, point is set to the start of the buffer text | |
| being operated on (i.e., the first argument of `buffer-substring--filter') | |
| before these functions are called.") | |
| (make-obsolete-variable 'buffer-substring-filters | |
| 'filter-buffer-substring-function "24.1") | |
| (defun filter-buffer-substring (beg end &optional delete) | |
| "Return the buffer substring between BEG and END, after filtering. | |
| If DELETE is non-nil, delete the text between BEG and END from the buffer. | |
| This calls the function that `filter-buffer-substring-function' specifies | |
| \(passing the same three arguments that it received) to do the work, | |
| and returns whatever it does. The default function does no filtering, | |
| unless a hook has been set. | |
| Use `filter-buffer-substring' instead of `buffer-substring', | |
| `buffer-substring-no-properties', or `delete-and-extract-region' when | |
| you want to allow filtering to take place. For example, major or minor | |
| modes can use `filter-buffer-substring-function' to exclude text properties | |
| that are special to a buffer, and should not be copied into other buffers." | |
| (funcall filter-buffer-substring-function beg end delete)) | |
| (defun buffer-substring--filter (beg end &optional delete) | |
| "Default function to use for `filter-buffer-substring-function'. | |
| Its arguments and return value are as specified for `filter-buffer-substring'. | |
| Also respects the obsolete wrapper hook `filter-buffer-substring-functions' | |
| \(see `with-wrapper-hook' for details about wrapper hooks), | |
| and the abnormal hook `buffer-substring-filters'. | |
| No filtering is done unless a hook says to." | |
| (subr--with-wrapper-hook-no-warnings | |
| filter-buffer-substring-functions (beg end delete) | |
| (cond | |
| ((or delete buffer-substring-filters) | |
| (save-excursion | |
| (goto-char beg) | |
| (let ((string (if delete (delete-and-extract-region beg end) | |
| (buffer-substring beg end)))) | |
| (dolist (filter buffer-substring-filters) | |
| (setq string (funcall filter string))) | |
| string))) | |
| (t | |
| (buffer-substring beg end))))) | |
| ;;;; Window system cut and paste hooks. | |
| (defvar interprogram-cut-function #'gui-select-text | |
| "Function to call to make a killed region available to other programs. | |
| Most window systems provide a facility for cutting and pasting | |
| text between different programs, such as the clipboard on X and | |
| MS-Windows, or the pasteboard on Nextstep/Mac OS. | |
| This variable holds a function that Emacs calls whenever text is | |
| put in the kill ring, to make the new kill available to other | |
| programs. The function takes one argument, TEXT, which is a | |
| string containing the text that should be made available.") | |
| (defvar interprogram-paste-function #'gui-selection-value | |
| "Function to call to get text cut from other programs. | |
| Most window systems provide a facility for cutting and pasting | |
| text between different programs, such as the clipboard on X and | |
| MS-Windows, or the pasteboard on Nextstep/Mac OS. | |
| This variable holds a function that Emacs calls to obtain text | |
| that other programs have provided for pasting. The function is | |
| called with no arguments. If no other program has provided text | |
| to paste, the function should return nil (in which case the | |
| caller, usually `current-kill', should use the top of the Emacs | |
| kill ring). If another program has provided text to paste, the | |
| function should return that text as a string (in which case the | |
| caller should put this string in the kill ring as the latest | |
| kill). | |
| The function may also return a list of strings if the window | |
| system supports multiple selections. The first string will be | |
| used as the pasted text, but the other will be placed in the kill | |
| ring for easy access via `yank-pop'. | |
| Note that the function should return a string only if a program | |
| other than Emacs has provided a string for pasting; if Emacs | |
| provided the most recent string, the function should return nil. | |
| If it is difficult to tell whether Emacs or some other program | |
| provided the current string, it is probably good enough to return | |
| nil if the string is equal (according to `string=') to the last | |
| text Emacs provided.") | |
| ;;;; The kill ring data structure. | |
| (defvar kill-ring nil | |
| "List of killed text sequences. | |
| Since the kill ring is supposed to interact nicely with cut-and-paste | |
| facilities offered by window systems, use of this variable should | |
| interact nicely with `interprogram-cut-function' and | |
| `interprogram-paste-function'. The functions `kill-new', | |
| `kill-append', and `current-kill' are supposed to implement this | |
| interaction; you may want to use them instead of manipulating the kill | |
| ring directly.") | |
| (defcustom kill-ring-max 60 | |
| "Maximum length of kill ring before oldest elements are thrown away." | |
| :type 'integer | |
| :group 'killing) | |
| (defvar kill-ring-yank-pointer nil | |
| "The tail of the kill ring whose car is the last thing yanked.") | |
| (defcustom save-interprogram-paste-before-kill nil | |
| "Save existing clipboard text into kill ring before replacing it. | |
| A non-nil value ensures that Emacs kill operations do not | |
| irrevocably overwrite existing clipboard text by saving it to the | |
| `kill-ring' prior to the kill. Such text can subsequently be | |
| retrieved via \\[yank] \\[yank-pop]." | |
| :type 'boolean | |
| :group 'killing | |
| :version "23.2") | |
| (defcustom kill-do-not-save-duplicates nil | |
| "If non-nil, don't add a string to `kill-ring' if it duplicates the last one. | |
| The comparison is done using `equal-including-properties'." | |
| :type 'boolean | |
| :group 'killing | |
| :version "23.2") | |
| (defun kill-new (string &optional replace) | |
| "Make STRING the latest kill in the kill ring. | |
| Set `kill-ring-yank-pointer' to point to it. | |
| If `interprogram-cut-function' is non-nil, apply it to STRING. | |
| Optional second argument REPLACE non-nil means that STRING will replace | |
| the front of the kill ring, rather than being added to the list. | |
| When `save-interprogram-paste-before-kill' and `interprogram-paste-function' | |
| are non-nil, save the interprogram paste string(s) into `kill-ring' before | |
| STRING. | |
| When the yank handler has a non-nil PARAM element, the original STRING | |
| argument is not used by `insert-for-yank'. However, since Lisp code | |
| may access and use elements from the kill ring directly, the STRING | |
| argument should still be a \"useful\" string for such uses." | |
| (unless (and kill-do-not-save-duplicates | |
| ;; Due to text properties such as 'yank-handler that | |
| ;; can alter the contents to yank, comparison using | |
| ;; `equal' is unsafe. | |
| (equal-including-properties string (car kill-ring))) | |
| (if (fboundp 'menu-bar-update-yank-menu) | |
| (menu-bar-update-yank-menu string (and replace (car kill-ring))))) | |
| (when save-interprogram-paste-before-kill | |
| (let ((interprogram-paste (and interprogram-paste-function | |
| (funcall interprogram-paste-function)))) | |
| (when interprogram-paste | |
| (dolist (s (if (listp interprogram-paste) | |
| ;; Use `reverse' to avoid modifying external data. | |
| (reverse interprogram-paste) | |
| (list interprogram-paste))) | |
| (unless (and kill-do-not-save-duplicates | |
| (equal-including-properties s (car kill-ring))) | |
| (push s kill-ring)))))) | |
| (unless (and kill-do-not-save-duplicates | |
| (equal-including-properties string (car kill-ring))) | |
| (if (and replace kill-ring) | |
| (setcar kill-ring string) | |
| (let ((history-delete-duplicates nil)) | |
| (add-to-history 'kill-ring string kill-ring-max t)))) | |
| (setq kill-ring-yank-pointer kill-ring) | |
| (if interprogram-cut-function | |
| (funcall interprogram-cut-function string))) | |
| ;; It has been argued that this should work like `self-insert-command' | |
| ;; which merges insertions in `buffer-undo-list' in groups of 20 | |
| ;; (hard-coded in `undo-auto-amalgamate'). | |
| (defcustom kill-append-merge-undo nil | |
| "Amalgamate appending kills with the last kill for undo. | |
| When non-nil, appending or prepending text to the last kill makes | |
| \\[undo] restore both pieces of text simultaneously." | |
| :type 'boolean | |
| :group 'killing | |
| :version "25.1") | |
| (defun kill-append (string before-p) | |
| "Append STRING to the end of the latest kill in the kill ring. | |
| If BEFORE-P is non-nil, prepend STRING to the kill instead. | |
| If `interprogram-cut-function' is non-nil, call it with the | |
| resulting kill. | |
| If `kill-append-merge-undo' is non-nil, remove the last undo | |
| boundary in the current buffer." | |
| (let ((cur (car kill-ring))) | |
| (kill-new (if before-p (concat string cur) (concat cur string)) | |
| (or (string= cur "") | |
| (null (get-text-property 0 'yank-handler cur))))) | |
| (when (and kill-append-merge-undo (not buffer-read-only)) | |
| (let ((prev buffer-undo-list) | |
| (next (cdr buffer-undo-list))) | |
| ;; Find the next undo boundary. | |
| (while (car next) | |
| (pop next) | |
| (pop prev)) | |
| ;; Remove this undo boundary. | |
| (when prev | |
| (setcdr prev (cdr next)))))) | |
| (defcustom yank-pop-change-selection nil | |
| "Whether rotating the kill ring changes the window system selection. | |
| If non-nil, whenever the kill ring is rotated (usually via the | |
| `yank-pop' command), Emacs also calls `interprogram-cut-function' | |
| to copy the new kill to the window system selection." | |
| :type 'boolean | |
| :group 'killing | |
| :version "23.1") | |
| (defun current-kill (n &optional do-not-move) | |
| "Rotate the yanking point by N places, and then return that kill. | |
| If N is zero and `interprogram-paste-function' is set to a | |
| function that returns a string or a list of strings, and if that | |
| function doesn't return nil, then that string (or list) is added | |
| to the front of the kill ring and the string (or first string in | |
| the list) is returned as the latest kill. | |
| If N is not zero, and if `yank-pop-change-selection' is | |
| non-nil, use `interprogram-cut-function' to transfer the | |
| kill at the new yank point into the window system selection. | |
| If optional arg DO-NOT-MOVE is non-nil, then don't actually | |
| move the yanking point; just return the Nth kill forward." | |
| (let ((interprogram-paste (and (= n 0) | |
| interprogram-paste-function | |
| (funcall interprogram-paste-function)))) | |
| (if interprogram-paste | |
| (progn | |
| ;; Disable the interprogram cut function when we add the new | |
| ;; text to the kill ring, so Emacs doesn't try to own the | |
| ;; selection, with identical text. | |
| ;; Also disable the interprogram paste function, so that | |
| ;; `kill-new' doesn't call it repeatedly. | |
| (let ((interprogram-cut-function nil) | |
| (interprogram-paste-function nil)) | |
| (if (listp interprogram-paste) | |
| ;; Use `reverse' to avoid modifying external data. | |
| (mapc #'kill-new (reverse interprogram-paste)) | |
| (kill-new interprogram-paste))) | |
| (car kill-ring)) | |
| (or kill-ring (error "Kill ring is empty")) | |
| (let ((ARGth-kill-element | |
| (nthcdr (mod (- n (length kill-ring-yank-pointer)) | |
| (length kill-ring)) | |
| kill-ring))) | |
| (unless do-not-move | |
| (setq kill-ring-yank-pointer ARGth-kill-element) | |
| (when (and yank-pop-change-selection | |
| (> n 0) | |
| interprogram-cut-function) | |
| (funcall interprogram-cut-function (car ARGth-kill-element)))) | |
| (car ARGth-kill-element))))) | |
| ;;;; Commands for manipulating the kill ring. | |
| (defcustom kill-read-only-ok nil | |
| "Non-nil means don't signal an error for killing read-only text." | |
| :type 'boolean | |
| :group 'killing) | |
| (defun kill-region (beg end &optional region) | |
| "Kill (\"cut\") text between point and mark. | |
| This deletes the text from the buffer and saves it in the kill ring. | |
| The command \\[yank] can retrieve it from there. | |
| \(If you want to save the region without killing it, use \\[kill-ring-save].) | |
| If you want to append the killed region to the last killed text, | |
| use \\[append-next-kill] before \\[kill-region]. | |
| Any command that calls this function is a \"kill command\". | |
| If the previous command was also a kill command, | |
| the text killed this time appends to the text killed last time | |
| to make one entry in the kill ring. | |
| The killed text is filtered by `filter-buffer-substring' before it is | |
| saved in the kill ring, so the actual saved text might be different | |
| from what was killed. | |
| If the buffer is read-only, Emacs will beep and refrain from deleting | |
| the text, but put the text in the kill ring anyway. This means that | |
| you can use the killing commands to copy text from a read-only buffer. | |
| Lisp programs should use this function for killing text. | |
| (To delete text, use `delete-region'.) | |
| Supply two arguments, character positions BEG and END indicating the | |
| stretch of text to be killed. If the optional argument REGION is | |
| non-nil, the function ignores BEG and END, and kills the current | |
| region instead." | |
| ;; Pass mark first, then point, because the order matters when | |
| ;; calling `kill-append'. | |
| (interactive (list (mark) (point) 'region)) | |
| (unless (and beg end) | |
| (user-error "The mark is not set now, so there is no region")) | |
| (condition-case nil | |
| (let ((string (if region | |
| (funcall region-extract-function 'delete) | |
| (filter-buffer-substring beg end 'delete)))) | |
| (when string ;STRING is nil if BEG = END | |
| ;; Add that string to the kill ring, one way or another. | |
| (if (eq last-command 'kill-region) | |
| (kill-append string (< end beg)) | |
| (kill-new string))) | |
| (when (or string (eq last-command 'kill-region)) | |
| (setq this-command 'kill-region)) | |
| (setq deactivate-mark t) | |
| nil) | |
| ((buffer-read-only text-read-only) | |
| ;; The code above failed because the buffer, or some of the characters | |
| ;; in the region, are read-only. | |
| ;; We should beep, in case the user just isn't aware of this. | |
| ;; However, there's no harm in putting | |
| ;; the region's text in the kill ring, anyway. | |
| (copy-region-as-kill beg end region) | |
| ;; Set this-command now, so it will be set even if we get an error. | |
| (setq this-command 'kill-region) | |
| ;; This should barf, if appropriate, and give us the correct error. | |
| (if kill-read-only-ok | |
| (progn (message "Read only text copied to kill ring") nil) | |
| ;; Signal an error if the buffer is read-only. | |
| (barf-if-buffer-read-only) | |
| ;; If the buffer isn't read-only, the text is. | |
| (signal 'text-read-only (list (current-buffer))))))) | |
| ;; copy-region-as-kill no longer sets this-command, because it's confusing | |
| ;; to get two copies of the text when the user accidentally types M-w and | |
| ;; then corrects it with the intended C-w. | |
| (defun copy-region-as-kill (beg end &optional region) | |
| "Save the region as if killed, but don't kill it. | |
| In Transient Mark mode, deactivate the mark. | |
| If `interprogram-cut-function' is non-nil, also save the text for a window | |
| system cut and paste. | |
| The copied text is filtered by `filter-buffer-substring' before it is | |
| saved in the kill ring, so the actual saved text might be different | |
| from what was in the buffer. | |
| When called from Lisp, save in the kill ring the stretch of text | |
| between BEG and END, unless the optional argument REGION is | |
| non-nil, in which case ignore BEG and END, and save the current | |
| region instead. | |
| This command's old key binding has been given to `kill-ring-save'." | |
| ;; Pass mark first, then point, because the order matters when | |
| ;; calling `kill-append'. | |
| (interactive (list (mark) (point) | |
| (prefix-numeric-value current-prefix-arg))) | |
| (let ((str (if region | |
| (funcall region-extract-function nil) | |
| (filter-buffer-substring beg end)))) | |
| (if (eq last-command 'kill-region) | |
| (kill-append str (< end beg)) | |
| (kill-new str))) | |
| (setq deactivate-mark t) | |
| nil) | |
| (defun kill-ring-save (beg end &optional region) | |
| "Save the region as if killed, but don't kill it. | |
| In Transient Mark mode, deactivate the mark. | |
| If `interprogram-cut-function' is non-nil, also save the text for a window | |
| system cut and paste. | |
| If you want to append the killed line to the last killed text, | |
| use \\[append-next-kill] before \\[kill-ring-save]. | |
| The copied text is filtered by `filter-buffer-substring' before it is | |
| saved in the kill ring, so the actual saved text might be different | |
| from what was in the buffer. | |
| When called from Lisp, save in the kill ring the stretch of text | |
| between BEG and END, unless the optional argument REGION is | |
| non-nil, in which case ignore BEG and END, and save the current | |
| region instead. | |
| This command is similar to `copy-region-as-kill', except that it gives | |
| visual feedback indicating the extent of the region being copied." | |
| ;; Pass mark first, then point, because the order matters when | |
| ;; calling `kill-append'. | |
| (interactive (list (mark) (point) | |
| (prefix-numeric-value current-prefix-arg))) | |
| (copy-region-as-kill beg end region) | |
| ;; This use of called-interactively-p is correct because the code it | |
| ;; controls just gives the user visual feedback. | |
| (if (called-interactively-p 'interactive) | |
| (indicate-copied-region))) | |
| (defun indicate-copied-region (&optional message-len) | |
| "Indicate that the region text has been copied interactively. | |
| If the mark is visible in the selected window, blink the cursor | |
| between point and mark if there is currently no active region | |
| highlighting. | |
| If the mark lies outside the selected window, display an | |
| informative message containing a sample of the copied text. The | |
| optional argument MESSAGE-LEN, if non-nil, specifies the length | |
| of this sample text; it defaults to 40." | |
| (let ((mark (mark t)) | |
| (point (point)) | |
| ;; Inhibit quitting so we can make a quit here | |
| ;; look like a C-g typed as a command. | |
| (inhibit-quit t)) | |
| (if (pos-visible-in-window-p mark (selected-window)) | |
| ;; Swap point-and-mark quickly so as to show the region that | |
| ;; was selected. Don't do it if the region is highlighted. | |
| (unless (and (region-active-p) | |
| (face-background 'region)) | |
| ;; Swap point and mark. | |
| (set-marker (mark-marker) (point) (current-buffer)) | |
| (goto-char mark) | |
| (sit-for blink-matching-delay) | |
| ;; Swap back. | |
| (set-marker (mark-marker) mark (current-buffer)) | |
| (goto-char point) | |
| ;; If user quit, deactivate the mark | |
| ;; as C-g would as a command. | |
| (and quit-flag (region-active-p) | |
| (deactivate-mark))) | |
| (let ((len (min (abs (- mark point)) | |
| (or message-len 40)))) | |
| (if (< point mark) | |
| ;; Don't say "killed"; that is misleading. | |
| (message "Saved text until \"%s\"" | |
| (buffer-substring-no-properties (- mark len) mark)) | |
| (message "Saved text from \"%s\"" | |
| (buffer-substring-no-properties mark (+ mark len)))))))) | |
| (defun append-next-kill (&optional interactive) | |
| "Cause following command, if it kills, to add to previous kill. | |
| If the next command kills forward from point, the kill is | |
| appended to the previous killed text. If the command kills | |
| backward, the kill is prepended. Kill commands that act on the | |
| region, such as `kill-region', are regarded as killing forward if | |
| point is after mark, and killing backward if point is before | |
| mark. | |
| If the next command is not a kill command, `append-next-kill' has | |
| no effect. | |
| The argument is used for internal purposes; do not supply one." | |
| (interactive "p") | |
| ;; We don't use (interactive-p), since that breaks kbd macros. | |
| (if interactive | |
| (progn | |
| (setq this-command 'kill-region) | |
| (message "If the next command is a kill, it will append")) | |
| (setq last-command 'kill-region))) | |
| (defvar bidi-directional-controls-chars "\x202a-\x202e\x2066-\x2069" | |
| "Character set that matches bidirectional formatting control characters.") | |
| (defvar bidi-directional-non-controls-chars "^\x202a-\x202e\x2066-\x2069" | |
| "Character set that matches any character except bidirectional controls.") | |
| (defun squeeze-bidi-context-1 (from to category replacement) | |
| "A subroutine of `squeeze-bidi-context'. | |
| FROM and TO should be markers, CATEGORY and REPLACEMENT should be strings." | |
| (let ((pt (copy-marker from)) | |
| (limit (copy-marker to)) | |
| (old-pt 0) | |
| lim1) | |
| (setq lim1 limit) | |
| (goto-char pt) | |
| (while (< pt limit) | |
| (if (> pt old-pt) | |
| (move-marker lim1 | |
| (save-excursion | |
| ;; L and R categories include embedding and | |
| ;; override controls, but we don't want to | |
| ;; replace them, because that might change | |
| ;; the visual order. Likewise with PDF and | |
| ;; isolate controls. | |
| (+ pt (skip-chars-forward | |
| bidi-directional-non-controls-chars | |
| limit))))) | |
| ;; Replace any run of non-RTL characters by a single LRM. | |
| (if (null (re-search-forward category lim1 t)) | |
| ;; No more characters of CATEGORY, we are done. | |
| (setq pt limit) | |
| (replace-match replacement nil t) | |
| (move-marker pt (point))) | |
| (setq old-pt pt) | |
| ;; Skip directional controls, if any. | |
| (move-marker | |
| pt (+ pt (skip-chars-forward bidi-directional-controls-chars limit)))))) | |
| (defun squeeze-bidi-context (from to) | |
| "Replace characters between FROM and TO while keeping bidi context. | |
| This function replaces the region of text with as few characters | |
| as possible, while preserving the effect that region will have on | |
| bidirectional display before and after the region." | |
| (let ((start (set-marker (make-marker) | |
| (if (> from 0) from (+ (point-max) from)))) | |
| (end (set-marker (make-marker) to)) | |
| ;; This is for when they copy text with read-only text | |
| ;; properties. | |
| (inhibit-read-only t)) | |
| (if (null (marker-position end)) | |
| (setq end (point-max-marker))) | |
| ;; Replace each run of non-RTL characters with a single LRM. | |
| (squeeze-bidi-context-1 start end "\\CR+" "\x200e") | |
| ;; Replace each run of non-LTR characters with a single RLM. Note | |
| ;; that the \cR category includes both the Arabic Letter (AL) and | |
| ;; R characters; here we ignore the distinction between them, | |
| ;; because that distinction affects only Arabic Number (AN) | |
| ;; characters, which are weak and don't affect the reordering. | |
| (squeeze-bidi-context-1 start end "\\CL+" "\x200f"))) | |
| (defun line-substring-with-bidi-context (start end &optional no-properties) | |
| "Return buffer text between START and END with its bidi context. | |
| START and END are assumed to belong to the same physical line | |
| of buffer text. This function prepends and appends to the text | |
| between START and END bidi control characters that preserve the | |
| visual order of that text when it is inserted at some other place." | |
| (if (or (< start (point-min)) | |
| (> end (point-max))) | |
| (signal 'args-out-of-range (list (current-buffer) start end))) | |
| (let ((buf (current-buffer)) | |
| substr para-dir from to) | |
| (save-excursion | |
| (goto-char start) | |
| (setq para-dir (current-bidi-paragraph-direction)) | |
| (setq from (line-beginning-position) | |
| to (line-end-position)) | |
| (goto-char from) | |
| ;; If we don't have any mixed directional characters in the | |
| ;; entire line, we can just copy the substring without adding | |
| ;; any context. | |
| (if (or (looking-at-p "\\CR*$") | |
| (looking-at-p "\\CL*$")) | |
| (setq substr (if no-properties | |
| (buffer-substring-no-properties start end) | |
| (buffer-substring start end))) | |
| (setq substr | |
| (with-temp-buffer | |
| (if no-properties | |
| (insert-buffer-substring-no-properties buf from to) | |
| (insert-buffer-substring buf from to)) | |
| (squeeze-bidi-context 1 (1+ (- start from))) | |
| (squeeze-bidi-context (- end to) nil) | |
| (buffer-substring 1 (point-max))))) | |
| ;; Wrap the string in LRI/RLI..PDI pair to achieve 2 effects: | |
| ;; (1) force the string to have the same base embedding | |
| ;; direction as the paragraph direction at the source, no matter | |
| ;; what is the paragraph direction at destination; and (2) avoid | |
| ;; affecting the visual order of the surrounding text at | |
| ;; destination if there are characters of different | |
| ;; directionality there. | |
| (concat (if (eq para-dir 'left-to-right) "\x2066" "\x2067") | |
| substr "\x2069")))) | |
| (defun buffer-substring-with-bidi-context (start end &optional no-properties) | |
| "Return portion of current buffer between START and END with bidi context. | |
| This function works similar to `buffer-substring', but it prepends and | |
| appends to the text bidi directional control characters necessary to | |
| preserve the visual appearance of the text if it is inserted at another | |
| place. This is useful when the buffer substring includes bidirectional | |
| text and control characters that cause non-trivial reordering on display. | |
| If copied verbatim, such text can have a very different visual appearance, | |
| and can also change the visual appearance of the surrounding text at the | |
| destination of the copy. | |
| Optional argument NO-PROPERTIES, if non-nil, means copy the text without | |
| the text properties." | |
| (let (line-end substr) | |
| (if (or (< start (point-min)) | |
| (> end (point-max))) | |
| (signal 'args-out-of-range (list (current-buffer) start end))) | |
| (save-excursion | |
| (goto-char start) | |
| (setq line-end (min end (line-end-position))) | |
| (while (< start end) | |
| (setq substr | |
| (concat substr | |
| (if substr "\n" "") | |
| (line-substring-with-bidi-context start line-end | |
| no-properties))) | |
| (forward-line 1) | |
| (setq start (point)) | |
| (setq line-end (min end (line-end-position)))) | |
| substr))) | |
| ;; Yanking. | |
| (defcustom yank-handled-properties | |
| '((font-lock-face . yank-handle-font-lock-face-property) | |
| (category . yank-handle-category-property)) | |
| "List of special text property handling conditions for yanking. | |
| Each element should have the form (PROP . FUN), where PROP is a | |
| property symbol and FUN is a function. When the `yank' command | |
| inserts text into the buffer, it scans the inserted text for | |
| stretches of text that have `eq' values of the text property | |
| PROP; for each such stretch of text, FUN is called with three | |
| arguments: the property's value in that text, and the start and | |
| end positions of the text. | |
| This is done prior to removing the properties specified by | |
| `yank-excluded-properties'." | |
| :group 'killing | |
| :type '(repeat (cons (symbol :tag "property symbol") | |
| function)) | |
| :version "24.3") | |
| ;; This is actually used in subr.el but defcustom does not work there. | |
| (defcustom yank-excluded-properties | |
| '(category field follow-link fontified font-lock-face help-echo | |
| intangible invisible keymap local-map mouse-face read-only | |
| yank-handler) | |
| "Text properties to discard when yanking. | |
| The value should be a list of text properties to discard or t, | |
| which means to discard all text properties. | |
| See also `yank-handled-properties'." | |
| :type '(choice (const :tag "All" t) (repeat symbol)) | |
| :group 'killing | |
| :version "24.3") | |
| (defvar yank-window-start nil) | |
| (defvar yank-undo-function nil | |
| "If non-nil, function used by `yank-pop' to delete last stretch of yanked text. | |
| Function is called with two parameters, START and END corresponding to | |
| the value of the mark and point; it is guaranteed that START <= END. | |
| Normally set from the UNDO element of a yank-handler; see `insert-for-yank'.") | |
| (defun yank-pop (&optional arg) | |
| "Replace just-yanked stretch of killed text with a different stretch. | |
| This command is allowed only immediately after a `yank' or a | |
| `yank-pop'. At such a time, the region contains a stretch of | |
| reinserted previously-killed text. `yank-pop' deletes that text | |
| and inserts in its place a different stretch of killed text by | |
| traversing the value of the `kill-ring' variable. | |
| With no argument, the previous kill is inserted. | |
| With argument N, insert the Nth previous kill. | |
| If N is negative, this is a more recent kill. | |
| The sequence of kills wraps around, so that after the oldest one | |
| comes the newest one. | |
| This command honors the `yank-handled-properties' and | |
| `yank-excluded-properties' variables, and the `yank-handler' text | |
| property, in the way that `yank' does." | |
| (interactive "*p") | |
| (if (not (eq last-command 'yank)) | |
| (user-error "Previous command was not a yank")) | |
| (setq this-command 'yank) | |
| (unless arg (setq arg 1)) | |
| (let ((inhibit-read-only t) | |
| (before (< (point) (mark t)))) | |
| (if before | |
| (funcall (or yank-undo-function 'delete-region) (point) (mark t)) | |
| (funcall (or yank-undo-function 'delete-region) (mark t) (point))) | |
| (setq yank-undo-function nil) | |
| (set-marker (mark-marker) (point) (current-buffer)) | |
| (insert-for-yank (current-kill arg)) | |
| ;; Set the window start back where it was in the yank command, | |
| ;; if possible. | |
| (set-window-start (selected-window) yank-window-start t) | |
| (if before | |
| ;; This is like exchange-point-and-mark, but doesn't activate the mark. | |
| ;; It is cleaner to avoid activation, even though the command | |
| ;; loop would deactivate the mark because we inserted text. | |
| (goto-char (prog1 (mark t) | |
| (set-marker (mark-marker) (point) (current-buffer)))))) | |
| nil) | |
| (defun yank (&optional arg) | |
| "Reinsert (\"paste\") the last stretch of killed text. | |
| More precisely, reinsert the most recent kill, which is the | |
| stretch of killed text most recently killed OR yanked. Put point | |
| at the end, and set mark at the beginning without activating it. | |
| With just \\[universal-argument] as argument, put point at beginning, and mark at end. | |
| With argument N, reinsert the Nth most recent kill. | |
| This command honors the `yank-handled-properties' and | |
| `yank-excluded-properties' variables, and the `yank-handler' text | |
| property, as described below. | |
| Properties listed in `yank-handled-properties' are processed, | |
| then those listed in `yank-excluded-properties' are discarded. | |
| If STRING has a non-nil `yank-handler' property anywhere, the | |
| normal insert behavior is altered, and instead, for each contiguous | |
| segment of STRING that has a given value of the `yank-handler' | |
| property, that value is used as follows: | |
| The value of a `yank-handler' property must be a list of one to four | |
| elements, of the form (FUNCTION PARAM NOEXCLUDE UNDO). | |
| FUNCTION, if non-nil, should be a function of one argument (the | |
| object to insert); FUNCTION is called instead of `insert'. | |
| PARAM, if present and non-nil, is passed to FUNCTION (to be handled | |
| in whatever way is appropriate; e.g. if FUNCTION is `yank-rectangle', | |
| PARAM may be a list of strings to insert as a rectangle). If PARAM | |
| is nil, then the current segment of STRING is used. | |
| If NOEXCLUDE is present and non-nil, the normal removal of | |
| `yank-excluded-properties' is not performed; instead FUNCTION is | |
| responsible for the removal. This may be necessary if FUNCTION | |
| adjusts point before or after inserting the object. | |
| UNDO, if present and non-nil, should be a function to be called | |
| by `yank-pop' to undo the insertion of the current PARAM. It is | |
| given two arguments, the start and end of the region. FUNCTION | |
| may set `yank-undo-function' to override UNDO. | |
| See also the command `yank-pop' (\\[yank-pop])." | |
| (interactive "*P") | |
| (setq yank-window-start (window-start)) | |
| ;; If we don't get all the way thru, make last-command indicate that | |
| ;; for the following command. | |
| (setq this-command t) | |
| (push-mark) | |
| (insert-for-yank (current-kill (cond | |
| ((listp arg) 0) | |
| ((eq arg '-) -2) | |
| (t (1- arg))))) | |
| (if (consp arg) | |
| ;; This is like exchange-point-and-mark, but doesn't activate the mark. | |
| ;; It is cleaner to avoid activation, even though the command | |
| ;; loop would deactivate the mark because we inserted text. | |
| (goto-char (prog1 (mark t) | |
| (set-marker (mark-marker) (point) (current-buffer))))) | |
| ;; If we do get all the way thru, make this-command indicate that. | |
| (if (eq this-command t) | |
| (setq this-command 'yank)) | |
| nil) | |
| (defun rotate-yank-pointer (arg) | |
| "Rotate the yanking point in the kill ring. | |
| With ARG, rotate that many kills forward (or backward, if negative)." | |
| (interactive "p") | |
| (current-kill arg)) | |
| ;; Some kill commands. | |
| ;; Internal subroutine of delete-char | |
| (defun kill-forward-chars (arg) | |
| (if (listp arg) (setq arg (car arg))) | |
| (if (eq arg '-) (setq arg -1)) | |
| (kill-region (point) (+ (point) arg))) | |
| ;; Internal subroutine of backward-delete-char | |
| (defun kill-backward-chars (arg) | |
| (if (listp arg) (setq arg (car arg))) | |
| (if (eq arg '-) (setq arg -1)) | |
| (kill-region (point) (- (point) arg))) | |
| (defcustom backward-delete-char-untabify-method 'untabify | |
| "The method for untabifying when deleting backward. | |
| Can be `untabify' -- turn a tab to many spaces, then delete one space; | |
| `hungry' -- delete all whitespace, both tabs and spaces; | |
| `all' -- delete all whitespace, including tabs, spaces and newlines; | |
| nil -- just delete one character." | |
| :type '(choice (const untabify) (const hungry) (const all) (const nil)) | |
| :version "20.3" | |
| :group 'killing) | |
| (defun backward-delete-char-untabify (arg &optional killp) | |
| "Delete characters backward, changing tabs into spaces. | |
| The exact behavior depends on `backward-delete-char-untabify-method'. | |
| Delete ARG chars, and kill (save in kill ring) if KILLP is non-nil. | |
| Interactively, ARG is the prefix arg (default 1) | |
| and KILLP is t if a prefix arg was specified." | |
| (interactive "*p\nP") | |
| (when (eq backward-delete-char-untabify-method 'untabify) | |
| (let ((count arg)) | |
| (save-excursion | |
| (while (and (> count 0) (not (bobp))) | |
| (if (= (preceding-char) ?\t) | |
| (let ((col (current-column))) | |
| (forward-char -1) | |
| (setq col (- col (current-column))) | |
| (insert-char ?\s col) | |
| (delete-char 1))) | |
| (forward-char -1) | |
| (setq count (1- count)))))) | |
| (let* ((skip (cond ((eq backward-delete-char-untabify-method 'hungry) " \t") | |
| ((eq backward-delete-char-untabify-method 'all) | |
| " \t\n\r"))) | |
| (n (if skip | |
| (let* ((oldpt (point)) | |
| (wh (- oldpt (save-excursion | |
| (skip-chars-backward skip) | |
| (constrain-to-field nil oldpt))))) | |
| (+ arg (if (zerop wh) 0 (1- wh)))) | |
| arg))) | |
| ;; Avoid warning about delete-backward-char | |
| (with-no-warnings (delete-backward-char n killp)))) | |
| (defun zap-to-char (arg char) | |
| "Kill up to and including ARGth occurrence of CHAR. | |
| Case is ignored if `case-fold-search' is non-nil in the current buffer. | |
| Goes backward if ARG is negative; error if CHAR not found. | |
| See also `zap-up-to-char'." | |
| (interactive (list (prefix-numeric-value current-prefix-arg) | |
| (read-char-from-minibuffer "Zap to char: " | |
| nil 'read-char-history))) | |
| ;; Avoid "obsolete" warnings for translation-table-for-input. | |
| (with-no-warnings | |
| (if (char-table-p translation-table-for-input) | |
| (setq char (or (aref translation-table-for-input char) char)))) | |
| (kill-region (point) (progn | |
| (search-forward (char-to-string char) nil nil arg) | |
| (point)))) | |
| ;; kill-line and its subroutines. | |
| (defcustom kill-whole-line nil | |
| "If non-nil, `kill-line' with no arg at start of line kills the whole line." | |
| :type 'boolean | |
| :group 'killing) | |
| (defun kill-line (&optional arg) | |
| "Kill the rest of the current line; if no nonblanks there, kill thru newline. | |
| With prefix argument ARG, kill that many lines from point. | |
| Negative arguments kill lines backward. | |
| With zero argument, kills the text before point on the current line. | |
| When calling from a program, nil means \"no arg\", | |
| a number counts as a prefix arg. | |
| To kill a whole line, when point is not at the beginning, type \ | |
| \\[move-beginning-of-line] \\[kill-line] \\[kill-line]. | |
| If `show-trailing-whitespace' is non-nil, this command will just | |
| kill the rest of the current line, even if there are no nonblanks | |
| there. | |
| If option `kill-whole-line' is non-nil, then this command kills the whole line | |
| including its terminating newline, when used at the beginning of a line | |
| with no argument. As a consequence, you can always kill a whole line | |
| by typing \\[move-beginning-of-line] \\[kill-line]. | |
| If you want to append the killed line to the last killed text, | |
| use \\[append-next-kill] before \\[kill-line]. | |
| If the buffer is read-only, Emacs will beep and refrain from deleting | |
| the line, but put the line in the kill ring anyway. This means that | |
| you can use this command to copy text from a read-only buffer. | |
| \(If the variable `kill-read-only-ok' is non-nil, then this won't | |
| even beep.)" | |
| (interactive "P") | |
| (kill-region (point) | |
| ;; It is better to move point to the other end of the kill | |
| ;; before killing. That way, in a read-only buffer, point | |
| ;; moves across the text that is copied to the kill ring. | |
| ;; The choice has no effect on undo now that undo records | |
| ;; the value of point from before the command was run. | |
| (progn | |
| (if arg | |
| (forward-visible-line (prefix-numeric-value arg)) | |
| (if (eobp) | |
| (signal 'end-of-buffer nil)) | |
| (let ((end | |
| (save-excursion | |
| (end-of-visible-line) (point)))) | |
| (if (or (save-excursion | |
| ;; If trailing whitespace is visible, | |
| ;; don't treat it as nothing. | |
| (unless show-trailing-whitespace | |
| (skip-chars-forward " \t" end)) | |
| (= (point) end)) | |
| (and kill-whole-line (bolp))) | |
| (forward-visible-line 1) | |
| (goto-char end)))) | |
| (point)))) | |
| (defun kill-whole-line (&optional arg) | |
| "Kill current line. | |
| With prefix ARG, kill that many lines starting from the current line. | |
| If ARG is negative, kill backward. Also kill the preceding newline. | |
| \(This is meant to make \\[repeat] work well with negative arguments.) | |
| If ARG is zero, kill current line but exclude the trailing newline." | |
| (interactive "p") | |
| (or arg (setq arg 1)) | |
| (if (and (> arg 0) (eobp) (save-excursion (forward-visible-line 0) (eobp))) | |
| (signal 'end-of-buffer nil)) | |
| (if (and (< arg 0) (bobp) (save-excursion (end-of-visible-line) (bobp))) | |
| (signal 'beginning-of-buffer nil)) | |
| (unless (eq last-command 'kill-region) | |
| (kill-new "") | |
| (setq last-command 'kill-region)) | |
| (cond ((zerop arg) | |
| ;; We need to kill in two steps, because the previous command | |
| ;; could have been a kill command, in which case the text | |
| ;; before point needs to be prepended to the current kill | |
| ;; ring entry and the text after point appended. Also, we | |
| ;; need to use save-excursion to avoid copying the same text | |
| ;; twice to the kill ring in read-only buffers. | |
| (save-excursion | |
| (kill-region (point) (progn (forward-visible-line 0) (point)))) | |
| (kill-region (point) (progn (end-of-visible-line) (point)))) | |
| ((< arg 0) | |
| (save-excursion | |
| (kill-region (point) (progn (end-of-visible-line) (point)))) | |
| (kill-region (point) | |
| (progn (forward-visible-line (1+ arg)) | |
| (unless (bobp) (backward-char)) | |
| (point)))) | |
| (t | |
| (save-excursion | |
| (kill-region (point) (progn (forward-visible-line 0) (point)))) | |
| (kill-region (point) | |
| (progn (forward-visible-line arg) (point)))))) | |
| (defun forward-visible-line (arg) | |
| "Move forward by ARG lines, ignoring currently invisible newlines only. | |
| If ARG is negative, move backward -ARG lines. | |
| If ARG is zero, move to the beginning of the current line." | |
| (condition-case nil | |
| (if (> arg 0) | |
| (progn | |
| (while (> arg 0) | |
| (or (zerop (forward-line 1)) | |
| (signal 'end-of-buffer nil)) | |
| ;; If the newline we just skipped is invisible, | |
| ;; don't count it. | |
| (if (invisible-p (1- (point))) | |
| (setq arg (1+ arg))) | |
| (setq arg (1- arg))) | |
| ;; If invisible text follows, and it is a number of complete lines, | |
| ;; skip it. | |
| (let ((opoint (point))) | |
| (while (and (not (eobp)) | |
| (invisible-p (point))) | |
| (goto-char | |
| (if (get-text-property (point) 'invisible) | |
| (or (next-single-property-change (point) 'invisible) | |
| (point-max)) | |
| (next-overlay-change (point))))) | |
| (unless (bolp) | |
| (goto-char opoint)))) | |
| (let ((first t)) | |
| (while (or first (<= arg 0)) | |
| (if first | |
| (beginning-of-line) | |
| (or (zerop (forward-line -1)) | |
| (signal 'beginning-of-buffer nil))) | |
| ;; If the newline we just moved to is invisible, | |
| ;; don't count it. | |
| (unless (bobp) | |
| (unless (invisible-p (1- (point))) | |
| (setq arg (1+ arg)))) | |
| (setq first nil)) | |
| ;; If invisible text follows, and it is a number of complete lines, | |
| ;; skip it. | |
| (let ((opoint (point))) | |
| (while (and (not (bobp)) | |
| (invisible-p (1- (point)))) | |
| (goto-char | |
| (if (get-text-property (1- (point)) 'invisible) | |
| (or (previous-single-property-change (point) 'invisible) | |
| (point-min)) | |
| (previous-overlay-change (point))))) | |
| (unless (bolp) | |
| (goto-char opoint))))) | |
| ((beginning-of-buffer end-of-buffer) | |
| nil))) | |
| (defun end-of-visible-line () | |
| "Move to end of current visible line." | |
| (end-of-line) | |
| ;; If the following character is currently invisible, | |
| ;; skip all characters with that same `invisible' property value, | |
| ;; then find the next newline. | |
| (while (and (not (eobp)) | |
| (save-excursion | |
| (skip-chars-forward "^\n") | |
| (invisible-p (point)))) | |
| (skip-chars-forward "^\n") | |
| (if (get-text-property (point) 'invisible) | |
| (goto-char (or (next-single-property-change (point) 'invisible) | |
| (point-max))) | |
| (goto-char (next-overlay-change (point)))) | |
| (end-of-line))) | |
| (defun kill-current-buffer () | |
| "Kill the current buffer. | |
| When called in the minibuffer, get out of the minibuffer | |
| using `abort-recursive-edit'. | |
| This is like `kill-this-buffer', but it doesn't have to be invoked | |
| via the menu bar, and pays no attention to the menu-bar's frame." | |
| (interactive) | |
| (let ((frame (selected-frame))) | |
| (if (and (frame-live-p frame) | |
| (not (window-minibuffer-p (frame-selected-window frame)))) | |
| (kill-buffer (current-buffer)) | |
| (abort-recursive-edit)))) | |
| (defun insert-buffer (buffer) | |
| "Insert after point the contents of BUFFER. | |
| Puts mark after the inserted text. | |
| BUFFER may be a buffer or a buffer name." | |
| (declare (interactive-only insert-buffer-substring)) | |
| (interactive | |
| (list | |
| (progn | |
| (barf-if-buffer-read-only) | |
| (read-buffer "Insert buffer: " | |
| (if (eq (selected-window) (next-window)) | |
| (other-buffer (current-buffer)) | |
| (window-buffer (next-window))) | |
| t)))) | |
| (push-mark | |
| (save-excursion | |
| (insert-buffer-substring (get-buffer buffer)) | |
| (point))) | |
| nil) | |
| (defun append-to-buffer (buffer start end) | |
| "Append to specified BUFFER the text of the region. | |
| The text is inserted into that buffer before its point. | |
| BUFFER can be a buffer or the name of a buffer; this | |
| function will create BUFFER if it doesn't already exist. | |
| When calling from a program, give three arguments: | |
| BUFFER (or buffer name), START and END. | |
| START and END specify the portion of the current buffer to be copied." | |
| (interactive | |
| (list (read-buffer "Append to buffer: " (other-buffer (current-buffer) t)) | |
| (region-beginning) (region-end))) | |
| (let* ((oldbuf (current-buffer)) | |
| (append-to (get-buffer-create buffer)) | |
| (windows (get-buffer-window-list append-to t t)) | |
| point) | |
| (save-excursion | |
| (with-current-buffer append-to | |
| (setq point (point)) | |
| (barf-if-buffer-read-only) | |
| (insert-buffer-substring oldbuf start end) | |
| (dolist (window windows) | |
| (when (= (window-point window) point) | |
| (set-window-point window (point)))))))) | |
| (defun prepend-to-buffer (buffer start end) | |
| "Prepend to specified BUFFER the text of the region. | |
| The text is inserted into that buffer after its point. | |
| BUFFER can be a buffer or the name of a buffer; this | |
| function will create BUFFER if it doesn't already exist. | |
| When calling from a program, give three arguments: | |
| BUFFER (or buffer name), START and END. | |
| START and END specify the portion of the current buffer to be copied." | |
| (interactive "BPrepend to buffer: \nr") | |
| (let ((oldbuf (current-buffer))) | |
| (with-current-buffer (get-buffer-create buffer) | |
| (barf-if-buffer-read-only) | |
| (save-excursion | |
| (insert-buffer-substring oldbuf start end))))) | |
| (defun copy-to-buffer (buffer start end) | |
| "Copy to specified BUFFER the text of the region. | |
| The text is inserted into that buffer, replacing existing text there. | |
| BUFFER can be a buffer or the name of a buffer; this | |
| function will create BUFFER if it doesn't already exist. | |
| When calling from a program, give three arguments: | |
| BUFFER (or buffer name), START and END. | |
| START and END specify the portion of the current buffer to be copied." | |
| (interactive "BCopy to buffer: \nr") | |
| (let ((oldbuf (current-buffer))) | |
| (with-current-buffer (get-buffer-create buffer) | |
| (barf-if-buffer-read-only) | |
| (erase-buffer) | |
| (save-excursion | |
| (insert-buffer-substring oldbuf start end))))) | |
| (define-error 'mark-inactive (purecopy "The mark is not active now")) | |
| (defvar activate-mark-hook nil | |
| "Hook run when the mark becomes active. | |
| It is also run at the end of a command, if the mark is active and | |
| it is possible that the region may have changed.") | |
| (defvar deactivate-mark-hook nil | |
| "Hook run when the mark becomes inactive.") | |
| (defun mark (&optional force) | |
| "Return this buffer's mark value as integer, or nil if never set. | |
| In Transient Mark mode, this function signals an error if | |
| the mark is not active. However, if `mark-even-if-inactive' is non-nil, | |
| or the argument FORCE is non-nil, it disregards whether the mark | |
| is active, and returns an integer or nil in the usual way. | |
| If you are using this in an editing command, you are most likely making | |
| a mistake; see the documentation of `set-mark'." | |
| (if (or force (not transient-mark-mode) mark-active mark-even-if-inactive) | |
| (marker-position (mark-marker)) | |
| (signal 'mark-inactive nil))) | |
| ;; Behind display-selections-p. | |
| (defun deactivate-mark (&optional force) | |
| "Deactivate the mark. | |
| If Transient Mark mode is disabled, this function normally does | |
| nothing; but if FORCE is non-nil, it deactivates the mark anyway. | |
| Deactivating the mark sets `mark-active' to nil, updates the | |
| primary selection according to `select-active-regions', and runs | |
| `deactivate-mark-hook'. | |
| If Transient Mark mode was temporarily enabled, reset the value | |
| of the variable `transient-mark-mode'; if this causes Transient | |
| Mark mode to be disabled, don't change `mark-active' to nil or | |
| run `deactivate-mark-hook'." | |
| (when (or (region-active-p) force) | |
| (when (and (if (eq select-active-regions 'only) | |
| (eq (car-safe transient-mark-mode) 'only) | |
| select-active-regions) | |
| (region-active-p) | |
| (display-selections-p)) | |
| ;; The var `saved-region-selection', if non-nil, is the text in | |
| ;; the region prior to the last command modifying the buffer. | |
| ;; Set the selection to that, or to the current region. | |
| (cond (saved-region-selection | |
| (if (gui-backend-selection-owner-p 'PRIMARY) | |
| (gui-set-selection 'PRIMARY saved-region-selection)) | |
| (setq saved-region-selection nil)) | |
| ;; If another program has acquired the selection, region | |
| ;; deactivation should not clobber it (Bug#11772). | |
| ((and (/= (region-beginning) (region-end)) | |
| (or (gui-backend-selection-owner-p 'PRIMARY) | |
| (null (gui-backend-selection-exists-p 'PRIMARY)))) | |
| (gui-set-selection 'PRIMARY | |
| (funcall region-extract-function nil))))) | |
| (when mark-active (force-mode-line-update)) ;Refresh toolbar (bug#16382). | |
| (cond | |
| ((eq (car-safe transient-mark-mode) 'only) | |
| (setq transient-mark-mode (cdr transient-mark-mode)) | |
| (if (eq transient-mark-mode (default-value 'transient-mark-mode)) | |
| (kill-local-variable 'transient-mark-mode))) | |
| ((eq transient-mark-mode 'lambda) | |
| (kill-local-variable 'transient-mark-mode))) | |
| (setq mark-active nil) | |
| (run-hooks 'deactivate-mark-hook) | |
| (redisplay--update-region-highlight (selected-window)))) | |
| (defun activate-mark (&optional no-tmm) | |
| "Activate the mark. | |
| If NO-TMM is non-nil, leave `transient-mark-mode' alone." | |
| (when (mark t) | |
| (unless (region-active-p) | |
| (force-mode-line-update) ;Refresh toolbar (bug#16382). | |
| (setq mark-active t) | |
| (unless (or transient-mark-mode no-tmm) | |
| (setq-local transient-mark-mode 'lambda)) | |
| (run-hooks 'activate-mark-hook)))) | |
| (defun set-mark (pos) | |
| "Set this buffer's mark to POS. Don't use this function! | |
| That is to say, don't use this function unless you want | |
| the user to see that the mark has moved, and you want the previous | |
| mark position to be lost. | |
| Normally, when a new mark is set, the old one should go on the stack. | |
| This is why most applications should use `push-mark', not `set-mark'. | |
| Novice Emacs Lisp programmers often try to use the mark for the wrong | |
| purposes. The mark saves a location for the user's convenience. | |
| Most editing commands should not alter the mark. | |
| To remember a location for internal use in the Lisp program, | |
| store it in a Lisp variable. Example: | |
| (let ((beg (point))) (forward-line 1) (delete-region beg (point)))." | |
| (if pos | |
| (progn | |
| (set-marker (mark-marker) pos (current-buffer)) | |
| (activate-mark 'no-tmm)) | |
| ;; Normally we never clear mark-active except in Transient Mark mode. | |
| ;; But when we actually clear out the mark value too, we must | |
| ;; clear mark-active in any mode. | |
| (deactivate-mark t) | |
| ;; `deactivate-mark' sometimes leaves mark-active non-nil, but | |
| ;; it should never be nil if the mark is nil. | |
| (setq mark-active nil) | |
| (set-marker (mark-marker) nil))) | |
| (defun save-mark-and-excursion--save () | |
| (cons | |
| (let ((mark (mark-marker))) | |
| (and (marker-position mark) (copy-marker mark))) | |
| mark-active)) | |
| (defun save-mark-and-excursion--restore (saved-mark-info) | |
| (let ((saved-mark (car saved-mark-info)) | |
| (omark (marker-position (mark-marker))) | |
| (nmark nil) | |
| (saved-mark-active (cdr saved-mark-info))) | |
| ;; Mark marker | |
| (if (null saved-mark) | |
| (set-marker (mark-marker) nil) | |
| (setf nmark (marker-position saved-mark)) | |
| (set-marker (mark-marker) nmark) | |
| (set-marker saved-mark nil)) | |
| ;; Mark active | |
| (let ((cur-mark-active mark-active)) | |
| (setq mark-active saved-mark-active) | |
| ;; If mark is active now, and either was not active or was at a | |
| ;; different place, run the activate hook. | |
| (if saved-mark-active | |
| (when (or (not cur-mark-active) | |
| (not (eq omark nmark))) | |
| (run-hooks 'activate-mark-hook)) | |
| ;; If mark has ceased to be active, run deactivate hook. | |
| (when cur-mark-active | |
| (run-hooks 'deactivate-mark-hook)))))) | |
| (defmacro save-mark-and-excursion (&rest body) | |
| "Like `save-excursion', but also save and restore the mark state. | |
| This macro does what `save-excursion' did before Emacs 25.1." | |
| (declare (indent 0) (debug t)) | |
| (let ((saved-marker-sym (make-symbol "saved-marker"))) | |
| `(let ((,saved-marker-sym (save-mark-and-excursion--save))) | |
| (unwind-protect | |
| (save-excursion ,@body) | |
| (save-mark-and-excursion--restore ,saved-marker-sym))))) | |
| (defcustom use-empty-active-region nil | |
| "Whether \"region-aware\" commands should act on empty regions. | |
| If nil, region-aware commands treat the empty region as inactive. | |
| If non-nil, region-aware commands treat the region as active as | |
| long as the mark is active, even if the region is empty. | |
| Region-aware commands are those that act on the region if it is | |
| active and Transient Mark mode is enabled, and on the text near | |
| point otherwise." | |
| :type 'boolean | |
| :version "23.1" | |
| :group 'editing-basics) | |
| (defun use-region-p () | |
| "Return t if the region is active and it is appropriate to act on it. | |
| This is used by commands that act specially on the region under | |
| Transient Mark mode. | |
| The return value is t if Transient Mark mode is enabled and the | |
| mark is active; furthermore, if `use-empty-active-region' is nil, | |
| the region must not be empty. Otherwise, the return value is nil. | |
| For some commands, it may be appropriate to ignore the value of | |
| `use-empty-active-region'; in that case, use `region-active-p'." | |
| (and (region-active-p) | |
| (or use-empty-active-region (> (region-end) (region-beginning))) | |
| t)) | |
| (defun region-active-p () | |
| "Return t if Transient Mark mode is enabled and the mark is active. | |
| Some commands act specially on the region when Transient Mark | |
| mode is enabled. Usually, such commands should use | |
| `use-region-p' instead of this function, because `use-region-p' | |
| also checks the value of `use-empty-active-region'." | |
| (and transient-mark-mode mark-active | |
| ;; FIXME: Somehow we sometimes end up with mark-active non-nil but | |
| ;; without the mark being set (e.g. bug#17324). We really should fix | |
| ;; that problem, but in the mean time, let's make sure we don't say the | |
| ;; region is active when there's no mark. | |
| (progn (cl-assert (mark)) t))) | |
| (defun region-bounds () | |
| "Return the boundaries of the region. | |
| Value is a list of one or more cons cells of the form (START . END). | |
| It will have more than one cons cell when the region is non-contiguous, | |
| see `region-noncontiguous-p' and `extract-rectangle-bounds'." | |
| (funcall region-extract-function 'bounds)) | |
| (defun region-noncontiguous-p () | |
| "Return non-nil if the region contains several pieces. | |
| An example is a rectangular region handled as a list of | |
| separate contiguous regions for each line." | |
| (cdr (region-bounds))) | |
| (defvar redisplay-unhighlight-region-function | |
| (lambda (rol) (when (overlayp rol) (delete-overlay rol)))) | |
| (defvar redisplay-highlight-region-function | |
| (lambda (start end window rol) | |
| (if (not (overlayp rol)) | |
| (let ((nrol (make-overlay start end))) | |
| (funcall redisplay-unhighlight-region-function rol) | |
| (overlay-put nrol 'window window) | |
| (overlay-put nrol 'face 'region) | |
| ;; Normal priority so that a large region doesn't hide all the | |
| ;; overlays within it, but high secondary priority so that if it | |
| ;; ends/starts in the middle of a small overlay, that small overlay | |
| ;; won't hide the region's boundaries. | |
| (overlay-put nrol 'priority '(nil . 100)) | |
| nrol) | |
| (unless (and (eq (overlay-buffer rol) (current-buffer)) | |
| (eq (overlay-start rol) start) | |
| (eq (overlay-end rol) end)) | |
| (move-overlay rol start end (current-buffer))) | |
| rol)) | |
| "Function to move the region-highlight overlay. | |
| This function is called with four parameters, START, END, WINDOW | |
| and OVERLAY. If OVERLAY is nil, a new overlay is created. In | |
| any case, the overlay is adjusted to reflect the other three | |
| parameters. | |
| The overlay is returned by the function.") | |
| (defun redisplay--update-region-highlight (window) | |
| (let ((rol (window-parameter window 'internal-region-overlay))) | |
| (if (not (and (region-active-p) | |
| (or highlight-nonselected-windows | |
| (eq window (selected-window)) | |
| (and (window-minibuffer-p) | |
| (eq window (minibuffer-selected-window)))))) | |
| (funcall redisplay-unhighlight-region-function rol) | |
| (let* ((pt (window-point window)) | |
| (mark (mark)) | |
| (start (min pt mark)) | |
| (end (max pt mark)) | |
| (new | |
| (funcall redisplay-highlight-region-function | |
| start end window rol))) | |
| (unless (equal new rol) | |
| (set-window-parameter window 'internal-region-overlay | |
| new)))))) | |
| (defvar pre-redisplay-functions (list #'redisplay--update-region-highlight) | |
| "Hook run just before redisplay. | |
| It is called in each window that is to be redisplayed. It takes one argument, | |
| which is the window that will be redisplayed. When run, the `current-buffer' | |
| is set to the buffer displayed in that window.") | |
| (defun redisplay--pre-redisplay-functions (windows) | |
| (with-demoted-errors "redisplay--pre-redisplay-functions: %S" | |
| (if (null windows) | |
| (with-current-buffer (window-buffer (selected-window)) | |
| (run-hook-with-args 'pre-redisplay-functions (selected-window))) | |
| (dolist (win (if (listp windows) windows (window-list-1 nil nil t))) | |
| (with-current-buffer (window-buffer win) | |
| (run-hook-with-args 'pre-redisplay-functions win)))))) | |
| (add-function :before pre-redisplay-function | |
| #'redisplay--pre-redisplay-functions) | |
| (defvar-local mark-ring nil | |
| "The list of former marks of the current buffer, most recent first.") | |
| (put 'mark-ring 'permanent-local t) | |
| (defcustom mark-ring-max 16 | |
| "Maximum size of mark ring. Start discarding off end if gets this big." | |
| :type 'integer | |
| :group 'editing-basics) | |
| (defvar global-mark-ring nil | |
| "The list of saved global marks, most recent first.") | |
| (defcustom global-mark-ring-max 16 | |
| "Maximum size of global mark ring. \ | |
| Start discarding off end if gets this big." | |
| :type 'integer | |
| :group 'editing-basics) | |
| (defun pop-to-mark-command () | |
| "Jump to mark, and pop a new position for mark off the ring. | |
| \(Does not affect global mark ring)." | |
| (interactive) | |
| (if (null (mark t)) | |
| (user-error "No mark set in this buffer") | |
| (if (= (point) (mark t)) | |
| (message "Mark popped")) | |
| (goto-char (mark t)) | |
| (pop-mark))) | |
| (defun push-mark-command (arg &optional nomsg) | |
| "Set mark at where point is. | |
| If no prefix ARG and mark is already set there, just activate it. | |
| Display `Mark set' unless the optional second arg NOMSG is non-nil." | |
| (interactive "P") | |
| (let ((mark (mark t))) | |
| (if (or arg (null mark) (/= mark (point))) | |
| (push-mark nil nomsg t) | |
| (activate-mark 'no-tmm) | |
| (unless nomsg | |
| (message "Mark activated"))))) | |
| (defcustom set-mark-command-repeat-pop nil | |
| "Non-nil means repeating \\[set-mark-command] after popping mark pops it again. | |
| That means that C-u \\[set-mark-command] \\[set-mark-command] | |
| will pop the mark twice, and | |
| C-u \\[set-mark-command] \\[set-mark-command] \\[set-mark-command] | |
| will pop the mark three times. | |
| A value of nil means \\[set-mark-command]'s behavior does not change | |
| after C-u \\[set-mark-command]." | |
| :type 'boolean | |
| :group 'editing-basics) | |
| (defun set-mark-command (arg) | |
| "Set the mark where point is, and activate it; or jump to the mark. | |
| Setting the mark also alters the region, which is the text | |
| between point and mark; this is the closest equivalent in | |
| Emacs to what some editors call the \"selection\". | |
| With no prefix argument, set the mark at point, and push the | |
| old mark position on local mark ring. Also push the new mark on | |
| global mark ring, if the previous mark was set in another buffer. | |
| When Transient Mark Mode is off, immediately repeating this | |
| command activates `transient-mark-mode' temporarily. | |
| With prefix argument (e.g., \\[universal-argument] \\[set-mark-command]), \ | |
| jump to the mark, and set the mark from | |
| position popped off the local mark ring (this does not affect the global | |
| mark ring). Use \\[pop-global-mark] to jump to a mark popped off the global | |
| mark ring (see `pop-global-mark'). | |
| If `set-mark-command-repeat-pop' is non-nil, repeating | |
| the \\[set-mark-command] command with no prefix argument pops the next position | |
| off the local (or global) mark ring and jumps there. | |
| With \\[universal-argument] \\[universal-argument] as prefix | |
| argument, unconditionally set mark where point is, even if | |
| `set-mark-command-repeat-pop' is non-nil. | |
| Novice Emacs Lisp programmers often try to use the mark for the wrong | |
| purposes. See the documentation of `set-mark' for more information." | |
| (interactive "P") | |
| (cond ((eq transient-mark-mode 'lambda) | |
| (kill-local-variable 'transient-mark-mode)) | |
| ((eq (car-safe transient-mark-mode) 'only) | |
| (deactivate-mark))) | |
| (cond | |
| ((and (consp arg) (> (prefix-numeric-value arg) 4)) | |
| (push-mark-command nil)) | |
| ((not (eq this-command 'set-mark-command)) | |
| (if arg | |
| (pop-to-mark-command) | |
| (push-mark-command t))) | |
| ((and set-mark-command-repeat-pop | |
| (eq last-command 'pop-global-mark) | |
| (not arg)) | |
| (setq this-command 'pop-global-mark) | |
| (pop-global-mark)) | |
| ((or (and set-mark-command-repeat-pop | |
| (eq last-command 'pop-to-mark-command)) | |
| arg) | |
| (setq this-command 'pop-to-mark-command) | |
| (pop-to-mark-command)) | |
| ((eq last-command 'set-mark-command) | |
| (if (region-active-p) | |
| (progn | |
| (deactivate-mark) | |
| (message "Mark deactivated")) | |
| (activate-mark) | |
| (message "Mark activated"))) | |
| (t | |
| (push-mark-command nil)))) | |
| (defun push-mark (&optional location nomsg activate) | |
| "Set mark at LOCATION (point, by default) and push old mark on mark ring. | |
| If the last global mark pushed was not in the current buffer, | |
| also push LOCATION on the global mark ring. | |
| Display `Mark set' unless the optional second arg NOMSG is non-nil. | |
| Novice Emacs Lisp programmers often try to use the mark for the wrong | |
| purposes. See the documentation of `set-mark' for more information. | |
| In Transient Mark mode, activate mark if optional third arg ACTIVATE non-nil." | |
| (when (mark t) | |
| (let ((old (nth mark-ring-max mark-ring)) | |
| (history-delete-duplicates nil)) | |
| (add-to-history 'mark-ring (copy-marker (mark-marker)) mark-ring-max t) | |
| (when old | |
| (set-marker old nil)))) | |
| (set-marker (mark-marker) (or location (point)) (current-buffer)) | |
| ;; Don't push the mark on the global mark ring if the last global | |
| ;; mark pushed was in this same buffer. | |
| (unless (and global-mark-ring | |
| (eq (marker-buffer (car global-mark-ring)) (current-buffer))) | |
| (let ((old (nth global-mark-ring-max global-mark-ring)) | |
| (history-delete-duplicates nil)) | |
| (add-to-history | |
| 'global-mark-ring (copy-marker (mark-marker)) global-mark-ring-max t) | |
| (when old | |
| (set-marker old nil)))) | |
| (or nomsg executing-kbd-macro (> (minibuffer-depth) 0) | |
| (message "Mark set")) | |
| (if (or activate (not transient-mark-mode)) | |
| (set-mark (mark t))) | |
| nil) | |
| (defun pop-mark () | |
| "Pop off mark ring into the buffer's actual mark. | |
| Does not set point. Does nothing if mark ring is empty." | |
| (when mark-ring | |
| (setq mark-ring (nconc mark-ring (list (copy-marker (mark-marker))))) | |
| (set-marker (mark-marker) (car mark-ring)) | |
| (set-marker (car mark-ring) nil) | |
| (unless (mark t) (ding)) | |
| (pop mark-ring)) | |
| (deactivate-mark)) | |
| (define-obsolete-function-alias | |
| 'exchange-dot-and-mark 'exchange-point-and-mark "23.3") | |
| (defun exchange-point-and-mark (&optional arg) | |
| "Put the mark where point is now, and point where the mark is now. | |
| This command works even when the mark is not active, | |
| and it reactivates the mark. | |
| If Transient Mark mode is on, a prefix ARG deactivates the mark | |
| if it is active, and otherwise avoids reactivating it. If | |
| Transient Mark mode is off, a prefix ARG enables Transient Mark | |
| mode temporarily." | |
| (interactive "P") | |
| (let ((omark (mark t)) | |
| (temp-highlight (eq (car-safe transient-mark-mode) 'only))) | |
| (if (null omark) | |
| (user-error "No mark set in this buffer")) | |
| (set-mark (point)) | |
| (goto-char omark) | |
| (cond (temp-highlight | |
| (setq-local transient-mark-mode (cons 'only transient-mark-mode))) | |
| ((xor arg (not (region-active-p))) | |
| (deactivate-mark)) | |
| (t (activate-mark))) | |
| nil)) | |
| (defcustom shift-select-mode t | |
| "When non-nil, shifted motion keys activate the mark momentarily. | |
| While the mark is activated in this way, any shift-translated point | |
| motion key extends the region, and if Transient Mark mode was off, it | |
| is temporarily turned on. Furthermore, the mark will be deactivated | |
| by any subsequent point motion key that was not shift-translated, or | |
| by any action that normally deactivates the mark in Transient Mark mode. | |
| See `this-command-keys-shift-translated' for the meaning of | |
| shift-translation." | |
| :type 'boolean | |
| :group 'editing-basics) | |
| (defun handle-shift-selection () | |
| "Activate/deactivate mark depending on invocation thru shift translation. | |
| This function is called by `call-interactively' when a command | |
| with a `^' character in its `interactive' spec is invoked, before | |
| running the command itself. | |
| If `shift-select-mode' is enabled and the command was invoked | |
| through shift translation, set the mark and activate the region | |
| temporarily, unless it was already set in this way. See | |
| `this-command-keys-shift-translated' for the meaning of shift | |
| translation. | |
| Otherwise, if the region has been activated temporarily, | |
| deactivate it, and restore the variable `transient-mark-mode' to | |
| its earlier value." | |
| (cond ((and shift-select-mode this-command-keys-shift-translated) | |
| (unless (and mark-active | |
| (eq (car-safe transient-mark-mode) 'only)) | |
| (setq-local transient-mark-mode | |
| (cons 'only | |
| (unless (eq transient-mark-mode 'lambda) | |
| transient-mark-mode))) | |
| (push-mark nil nil t))) | |
| ((eq (car-safe transient-mark-mode) 'only) | |
| (setq transient-mark-mode (cdr transient-mark-mode)) | |
| (if (eq transient-mark-mode (default-value 'transient-mark-mode)) | |
| (kill-local-variable 'transient-mark-mode)) | |
| (deactivate-mark)))) | |
| (define-minor-mode transient-mark-mode | |
| "Toggle Transient Mark mode. | |
| Transient Mark mode is a global minor mode. When enabled, the | |
| region is highlighted with the `region' face whenever the mark | |
| is active. The mark is \"deactivated\" after certain non-motion | |
| commands, including those that change the text in the buffer, and | |
| during shift or mouse selection by any unshifted cursor motion | |
| command (see Info node `Shift Selection' for more details). | |
| You can also deactivate the mark by typing \\[keyboard-quit] or | |
| \\[keyboard-escape-quit]. | |
| Many commands change their behavior when Transient Mark mode is | |
| in effect and the mark is active, by acting on the region instead | |
| of their usual default part of the buffer's text. Examples of | |
| such commands include \\[comment-dwim], \\[flush-lines], \\[keep-lines], | |
| \\[query-replace], \\[query-replace-regexp], \\[ispell], and \\[undo]. | |
| To see the documentation of commands that are sensitive to the | |
| Transient Mark mode, invoke \\[apropos-documentation] and type \"transient\" | |
| or \"mark.*active\" at the prompt." | |
| :global t | |
| ;; It's defined in C/cus-start, this stops the d-m-m macro defining it again. | |
| :variable (default-value 'transient-mark-mode)) | |
| (defvar widen-automatically t | |
| "Non-nil means it is ok for commands to call `widen' when they want to. | |
| Some commands will do this in order to go to positions outside | |
| the current accessible part of the buffer. | |
| If `widen-automatically' is nil, these commands will do something else | |
| as a fallback, and won't change the buffer bounds.") | |
| (defvar non-essential nil | |
| "Whether the currently executing code is performing an essential task. | |
| This variable should be non-nil only when running code that should not | |
| disturb the user. E.g., it can be used to prevent Tramp from prompting | |
| the user for a password when we are simply scanning a set of files in the | |
| background or displaying possible completions before the user even asked | |
| for it.") | |
| (defun pop-global-mark () | |
| "Pop off global mark ring and jump to the top location." | |
| (interactive) | |
| ;; Pop entries that refer to non-existent buffers. | |
| (while (and global-mark-ring (not (marker-buffer (car global-mark-ring)))) | |
| (setq global-mark-ring (cdr global-mark-ring))) | |
| (or global-mark-ring | |
| (error "No global mark set")) | |
| (let* ((marker (car global-mark-ring)) | |
| (buffer (marker-buffer marker)) | |
| (position (marker-position marker))) | |
| (setq global-mark-ring (nconc (cdr global-mark-ring) | |
| (list (car global-mark-ring)))) | |
| (set-buffer buffer) | |
| (or (and (>= position (point-min)) | |
| (<= position (point-max))) | |
| (if widen-automatically | |
| (widen) | |
| (error "Global mark position is outside accessible part of buffer"))) | |
| (goto-char position) | |
| (switch-to-buffer buffer))) | |
| (defcustom next-line-add-newlines nil | |
| "If non-nil, `next-line' inserts newline to avoid `end of buffer' error." | |
| :type 'boolean | |
| :version "21.1" | |
| :group 'editing-basics) | |
| (defun next-line (&optional arg try-vscroll) | |
| "Move cursor vertically down ARG lines. | |
| Interactively, vscroll tall lines if `auto-window-vscroll' is enabled. | |
| Non-interactively, use TRY-VSCROLL to control whether to vscroll tall | |
| lines: if either `auto-window-vscroll' or TRY-VSCROLL is nil, this | |
| function will not vscroll. | |
| ARG defaults to 1. | |
| If there is no character in the target line exactly under the current column, | |
| the cursor is positioned after the character in that line that spans this | |
| column, or at the end of the line if it is not long enough. | |
| If there is no line in the buffer after this one, behavior depends on the | |
| value of `next-line-add-newlines'. If non-nil, it inserts a newline character | |
| to create a line, and moves the cursor to that line. Otherwise it moves the | |
| cursor to the end of the buffer. | |
| If the variable `line-move-visual' is non-nil, this command moves | |
| by display lines. Otherwise, it moves by buffer lines, without | |
| taking variable-width characters or continued lines into account. | |
| See \\[next-logical-line] for a command that always moves by buffer lines. | |
| The command \\[set-goal-column] can be used to create | |
| a semipermanent goal column for this command. | |
| Then instead of trying to move exactly vertically (or as close as possible), | |
| this command moves to the specified goal column (or as close as possible). | |
| The goal column is stored in the variable `goal-column', which is nil | |
| when there is no goal column. Note that setting `goal-column' | |
| overrides `line-move-visual' and causes this command to move by buffer | |
| lines rather than by display lines." | |
| (declare (interactive-only forward-line)) | |
| (interactive "^p\np") | |
| (or arg (setq arg 1)) | |
| (if (and next-line-add-newlines (= arg 1)) | |
| (if (save-excursion (end-of-line) (eobp)) | |
| ;; When adding a newline, don't expand an abbrev. | |
| (let ((abbrev-mode nil)) | |
| (end-of-line) | |
| (insert (if use-hard-newlines hard-newline "\n"))) | |
| (line-move arg nil nil try-vscroll)) | |
| (if (called-interactively-p 'interactive) | |
| (condition-case err | |
| (line-move arg nil nil try-vscroll) | |
| ((beginning-of-buffer end-of-buffer) | |
| (signal (car err) (cdr err)))) | |
| (line-move arg nil nil try-vscroll))) | |
| nil) | |
| (defun previous-line (&optional arg try-vscroll) | |
| "Move cursor vertically up ARG lines. | |
| Interactively, vscroll tall lines if `auto-window-vscroll' is enabled. | |
| Non-interactively, use TRY-VSCROLL to control whether to vscroll tall | |
| lines: if either `auto-window-vscroll' or TRY-VSCROLL is nil, this | |
| function will not vscroll. | |
| ARG defaults to 1. | |
| If there is no character in the target line exactly over the current column, | |
| the cursor is positioned after the character in that line that spans this | |
| column, or at the end of the line if it is not long enough. | |
| If the variable `line-move-visual' is non-nil, this command moves | |
| by display lines. Otherwise, it moves by buffer lines, without | |
| taking variable-width characters or continued lines into account. | |
| See \\[previous-logical-line] for a command that always moves by buffer lines. | |
| The command \\[set-goal-column] can be used to create | |
| a semipermanent goal column for this command. | |
| Then instead of trying to move exactly vertically (or as close as possible), | |
| this command moves to the specified goal column (or as close as possible). | |
| The goal column is stored in the variable `goal-column', which is nil | |
| when there is no goal column. Note that setting `goal-column' | |
| overrides `line-move-visual' and causes this command to move by buffer | |
| lines rather than by display lines." | |
| (declare (interactive-only | |
| "use `forward-line' with negative argument instead.")) | |
| (interactive "^p\np") | |
| (or arg (setq arg 1)) | |
| (if (called-interactively-p 'interactive) | |
| (condition-case err | |
| (line-move (- arg) nil nil try-vscroll) | |
| ((beginning-of-buffer end-of-buffer) | |
| (signal (car err) (cdr err)))) | |
| (line-move (- arg) nil nil try-vscroll)) | |
| nil) | |
| (defcustom track-eol nil | |
| "Non-nil means vertical motion starting at end of line keeps to ends of lines. | |
| This means moving to the end of each line moved onto. | |
| The beginning of a blank line does not count as the end of a line. | |
| This has no effect when the variable `line-move-visual' is non-nil." | |
| :type 'boolean | |
| :group 'editing-basics) | |
| (defcustom goal-column nil | |
| "Semipermanent goal column for vertical motion, as set by \\[set-goal-column], or nil. | |
| A non-nil setting overrides the variable `line-move-visual', which see." | |
| :type '(choice integer | |
| (const :tag "None" nil)) | |
| :group 'editing-basics) | |
| (make-variable-buffer-local 'goal-column) | |
| (defvar temporary-goal-column 0 | |
| "Current goal column for vertical motion. | |
| It is the column where point was at the start of the current run | |
| of vertical motion commands. | |
| When moving by visual lines via the function `line-move-visual', it is a cons | |
| cell (COL . HSCROLL), where COL is the x-position, in pixels, | |
| divided by the default column width, and HSCROLL is the number of | |
| columns by which window is scrolled from left margin. | |
| When the `track-eol' feature is doing its job, the value is | |
| `most-positive-fixnum'.") | |
| (defcustom line-move-ignore-invisible t | |
| "Non-nil means commands that move by lines ignore invisible newlines. | |
| When this option is non-nil, \\[next-line], \\[previous-line], \\[move-end-of-line], and \\[move-beginning-of-line] behave | |
| as if newlines that are invisible didn't exist, and count | |
| only visible newlines. Thus, moving across 2 newlines | |
| one of which is invisible will be counted as a one-line move. | |
| Also, a non-nil value causes invisible text to be ignored when | |
| counting columns for the purposes of keeping point in the same | |
| column by \\[next-line] and \\[previous-line]. | |
| Outline mode sets this." | |
| :type 'boolean | |
| :group 'editing-basics) | |
| (defcustom line-move-visual t | |
| "When non-nil, `line-move' moves point by visual lines. | |
| This movement is based on where the cursor is displayed on the | |
| screen, instead of relying on buffer contents alone. It takes | |
| into account variable-width characters and line continuation. | |
| If nil, `line-move' moves point by logical lines. | |
| A non-nil setting of `goal-column' overrides the value of this variable | |
| and forces movement by logical lines. | |
| A window that is horizontally scrolled also forces movement by logical | |
| lines." | |
| :type 'boolean | |
| :group 'editing-basics | |
| :version "23.1") | |
| ;; Used only if display-graphic-p. | |
| (declare-function font-info "font.c" (name &optional frame)) | |
| (defun default-font-height () | |
| "Return the height in pixels of the current buffer's default face font. | |
| If the default font is remapped (see `face-remapping-alist'), the | |
| function returns the height of the remapped face. | |
| This function uses the definition of the default face for the currently | |
| selected frame." | |
| (let ((default-font (face-font 'default))) | |
| (cond | |
| ((and (display-multi-font-p) | |
| ;; Avoid calling font-info if the frame's default font was | |
| ;; not changed since the frame was created. That's because | |
| ;; font-info is expensive for some fonts, see bug #14838. | |
| (not (string= (frame-parameter nil 'font) default-font))) | |
| (aref (font-info default-font) 3)) | |
| (t (frame-char-height))))) | |
| (defun default-font-width () | |
| "Return the width in pixels of the current buffer's default face font. | |
| If the default font is remapped (see `face-remapping-alist'), the | |
| function returns the width of the remapped face. | |
| This function uses the definition of the default face for the currently | |
| selected frame." | |
| (let ((default-font (face-font 'default))) | |
| (cond | |
| ((and (display-multi-font-p) | |
| ;; Avoid calling font-info if the frame's default font was | |
| ;; not changed since the frame was created. That's because | |
| ;; font-info is expensive for some fonts, see bug #14838. | |
| (not (string= (frame-parameter nil 'font) default-font))) | |
| (let* ((info (font-info (face-font 'default))) | |
| (width (aref info 11))) | |
| (if (> width 0) | |
| width | |
| (aref info 10)))) | |
| (t (frame-char-width))))) | |
| (defun default-line-height () | |
| "Return the pixel height of current buffer's default-face text line. | |
| The value includes `line-spacing', if any, defined for the buffer | |
| or the frame. | |
| This function uses the definition of the default face for the currently | |
| selected frame." | |
| (let ((dfh (default-font-height)) | |
| (lsp (if (display-graphic-p) | |
| (or line-spacing | |
| (default-value 'line-spacing) | |
| (frame-parameter nil 'line-spacing) | |
| 0) | |
| 0))) | |
| (if (floatp lsp) | |
| (setq lsp (truncate (* (frame-char-height) lsp)))) | |
| (+ dfh lsp))) | |
| (defun window-screen-lines () | |
| "Return the number of screen lines in the text area of the selected window. | |
| This is different from `window-text-height' in that this function counts | |
| lines in units of the height of the font used by the default face displayed | |
| in the window, not in units of the frame's default font, and also accounts | |
| for `line-spacing', if any, defined for the window's buffer or frame. | |
| The value is a floating-point number." | |
| (let ((edges (window-inside-pixel-edges)) | |
| (dlh (default-line-height))) | |
| (/ (float (- (nth 3 edges) (nth 1 edges))) dlh))) | |
| ;; Returns non-nil if partial move was done. | |
| (defun line-move-partial (arg noerror &optional _to-end) | |
| (if (< arg 0) | |
| ;; Move backward (up). | |
| ;; If already vscrolled, reduce vscroll | |
| (let ((vs (window-vscroll nil t)) | |
| (dlh (default-line-height))) | |
| (when (> vs dlh) | |
| (set-window-vscroll nil (- vs dlh) t))) | |
| ;; Move forward (down). | |
| (let* ((lh (window-line-height -1)) | |
| (rowh (car lh)) | |
| (vpos (nth 1 lh)) | |
| (ypos (nth 2 lh)) | |
| (rbot (nth 3 lh)) | |
| (this-lh (window-line-height)) | |
| (this-height (car this-lh)) | |
| (this-ypos (nth 2 this-lh)) | |
| (dlh (default-line-height)) | |
| (wslines (window-screen-lines)) | |
| (edges (window-inside-pixel-edges)) | |
| (winh (- (nth 3 edges) (nth 1 edges) 1)) | |
| py vs last-line) | |
| (if (> (mod wslines 1.0) 0.0) | |
| (setq wslines (round (+ wslines 0.5)))) | |
| (when (or (null lh) | |
| (>= rbot dlh) | |
| (<= ypos (- dlh)) | |
| (null this-lh) | |
| (<= this-ypos (- dlh))) | |
| (unless lh | |
| (let ((wend (pos-visible-in-window-p t nil t))) | |
| (setq rbot (nth 3 wend) | |
| rowh (nth 4 wend) | |
| vpos (nth 5 wend)))) | |
| (unless this-lh | |
| (let ((wstart (pos-visible-in-window-p nil nil t))) | |
| (setq this-ypos (nth 2 wstart) | |
| this-height (nth 4 wstart)))) | |
| (setq py | |
| (or (nth 1 this-lh) | |
| (let ((ppos (posn-at-point)) | |
| col-row) | |
| (setq col-row (posn-actual-col-row ppos)) | |
| (if col-row | |
| (- (cdr col-row) (window-vscroll)) | |
| (cdr (posn-col-row ppos)))))) | |
| ;; VPOS > 0 means the last line is only partially visible. | |
| ;; But if the part that is visible is at least as tall as the | |
| ;; default font, that means the line is actually fully | |
| ;; readable, and something like line-spacing is hidden. So in | |
| ;; that case we accept the last line in the window as still | |
| ;; visible, and consider the margin as starting one line | |
| ;; later. | |
| (if (and vpos (> vpos 0)) | |
| (if (and rowh | |
| (>= rowh (default-font-height)) | |
| (< rowh dlh)) | |
| (setq last-line (min (- wslines scroll-margin) vpos)) | |
| (setq last-line (min (- wslines scroll-margin 1) (1- vpos))))) | |
| (cond | |
| ;; If last line of window is fully visible, and vscrolling | |
| ;; more would make this line invisible, move forward. | |
| ((and (or (< (setq vs (window-vscroll nil t)) dlh) | |
| (null this-height) | |
| (<= this-height dlh)) | |
| (or (null rbot) (= rbot 0))) | |
| nil) | |
| ;; If cursor is not in the bottom scroll margin, and the | |
| ;; current line is not too tall, move forward. | |
| ((and (or (null this-height) (<= this-height winh)) | |
| vpos | |
| (> vpos 0) | |
| (< py last-line)) | |
| nil) | |
| ;; When already vscrolled, we vscroll some more if we can, | |
| ;; or clear vscroll and move forward at end of tall image. | |
| ((> vs 0) | |
| (when (or (and rbot (> rbot 0)) | |
| (and this-height (> this-height dlh))) | |
| (set-window-vscroll nil (+ vs dlh) t))) | |
| ;; If cursor just entered the bottom scroll margin, move forward, | |
| ;; but also optionally vscroll one line so redisplay won't recenter. | |
| ((and vpos | |
| (> vpos 0) | |
| (= py last-line)) | |
| ;; Don't vscroll if the partially-visible line at window | |
| ;; bottom is not too tall (a.k.a. "just one more text | |
| ;; line"): in that case, we do want redisplay to behave | |
| ;; normally, i.e. recenter or whatever. | |
| ;; | |
| ;; Note: ROWH + RBOT from the value returned by | |
| ;; pos-visible-in-window-p give the total height of the | |
| ;; partially-visible glyph row at the end of the window. As | |
| ;; we are dealing with floats, we disregard sub-pixel | |
| ;; discrepancies between that and DLH. | |
| (if (and rowh rbot (>= (- (+ rowh rbot) winh) 1)) | |
| (set-window-vscroll nil dlh t)) | |
| (line-move-1 arg noerror) | |
| t) | |
| ;; If there are lines above the last line, scroll-up one line. | |
| ((and vpos (> vpos 0)) | |
| (scroll-up 1) | |
| t) | |
| ;; Finally, start vscroll. | |
| (t | |
| (set-window-vscroll nil dlh t))))))) | |
| ;; This is like line-move-1 except that it also performs | |
| ;; vertical scrolling of tall images if appropriate. | |
| ;; That is not really a clean thing to do, since it mixes | |
| ;; scrolling with cursor motion. But so far we don't have | |
| ;; a cleaner solution to the problem of making C-n do something | |
| ;; useful given a tall image. | |
| (defun line-move (arg &optional noerror _to-end try-vscroll) | |
| "Move forward ARG lines. | |
| If NOERROR, don't signal an error if we can't move ARG lines. | |
| TO-END is unused. | |
| TRY-VSCROLL controls whether to vscroll tall lines: if either | |
| `auto-window-vscroll' or TRY-VSCROLL is nil, this function will | |
| not vscroll." | |
| (if noninteractive | |
| (line-move-1 arg noerror) | |
| (unless (and auto-window-vscroll try-vscroll | |
| ;; Only vscroll for single line moves | |
| (= (abs arg) 1) | |
| ;; Under scroll-conservatively, the display engine | |
| ;; does this better. | |
| (zerop scroll-conservatively) | |
| ;; But don't vscroll in a keyboard macro. | |
| (not defining-kbd-macro) | |
| (not executing-kbd-macro) | |
| (line-move-partial arg noerror)) | |
| (set-window-vscroll nil 0 t) | |
| (if (and line-move-visual | |
| ;; Display-based column are incompatible with goal-column. | |
| (not goal-column) | |
| ;; When the text in the window is scrolled to the left, | |
| ;; display-based motion doesn't make sense (because each | |
| ;; logical line occupies exactly one screen line). | |
| (not (> (window-hscroll) 0)) | |
| ;; Likewise when the text _was_ scrolled to the left | |
| ;; when the current run of vertical motion commands | |
| ;; started. | |
| (not (and (memq last-command | |
| `(next-line previous-line ,this-command)) | |
| auto-hscroll-mode | |
| (numberp temporary-goal-column) | |
| (>= temporary-goal-column | |
| (- (window-width) hscroll-margin))))) | |
| (prog1 (line-move-visual arg noerror) | |
| ;; If we moved into a tall line, set vscroll to make | |
| ;; scrolling through tall images more smooth. | |
| (let ((lh (line-pixel-height)) | |
| (edges (window-inside-pixel-edges)) | |
| (dlh (default-line-height)) | |
| winh) | |
| (setq winh (- (nth 3 edges) (nth 1 edges) 1)) | |
| (if (and (< arg 0) | |
| (< (point) (window-start)) | |
| (> lh winh)) | |
| (set-window-vscroll | |
| nil | |
| (- lh dlh) t)))) | |
| (line-move-1 arg noerror))))) | |
| ;; Display-based alternative to line-move-1. | |
| ;; Arg says how many lines to move. The value is t if we can move the | |
| ;; specified number of lines. | |
| (defun line-move-visual (arg &optional noerror) | |
| "Move ARG lines forward. | |
| If NOERROR, don't signal an error if we can't move that many lines." | |
| (let ((opoint (point)) | |
| (hscroll (window-hscroll)) | |
| (lnum-width (line-number-display-width t)) | |
| target-hscroll) | |
| ;; Check if the previous command was a line-motion command, or if | |
| ;; we were called from some other command. | |
| (if (and (consp temporary-goal-column) | |
| (memq last-command `(next-line previous-line ,this-command))) | |
| ;; If so, there's no need to reset `temporary-goal-column', | |
| ;; but we may need to hscroll. | |
| (if (or (/= (cdr temporary-goal-column) hscroll) | |
| (> (cdr temporary-goal-column) 0)) | |
| (setq target-hscroll (cdr temporary-goal-column))) | |
| ;; Otherwise, we should reset `temporary-goal-column'. | |
| (let ((posn (posn-at-point)) | |
| x-pos) | |
| (cond | |
| ;; Handle the `overflow-newline-into-fringe' case | |
| ;; (left-fringe is for the R2L case): | |
| ((memq (nth 1 posn) '(right-fringe left-fringe)) | |
| (setq temporary-goal-column (cons (window-width) hscroll))) | |
| ((car (posn-x-y posn)) | |
| (setq x-pos (- (car (posn-x-y posn)) lnum-width)) | |
| ;; In R2L lines, the X pixel coordinate is measured from the | |
| ;; left edge of the window, but columns are still counted | |
| ;; from the logical-order beginning of the line, i.e. from | |
| ;; the right edge in this case. We need to adjust for that. | |
| (if (eq (current-bidi-paragraph-direction) 'right-to-left) | |
| (setq x-pos (- (window-body-width nil t) 1 x-pos))) | |
| (setq temporary-goal-column | |
| (cons (/ (float x-pos) | |
| (frame-char-width)) | |
| hscroll))) | |
| (executing-kbd-macro | |
| ;; When we move beyond the first/last character visible in | |
| ;; the window, posn-at-point will return nil, so we need to | |
| ;; approximate the goal column as below. | |
| (setq temporary-goal-column | |
| (mod (current-column) (window-text-width))))))) | |
| (if target-hscroll | |
| (set-window-hscroll (selected-window) target-hscroll)) | |
| ;; vertical-motion can move more than it was asked to if it moves | |
| ;; across display strings with newlines. We don't want to ring | |
| ;; the bell and announce beginning/end of buffer in that case. | |
| (or (and (or (and (>= arg 0) | |
| (>= (vertical-motion | |
| (cons (or goal-column | |
| (if (consp temporary-goal-column) | |
| (car temporary-goal-column) | |
| temporary-goal-column)) | |
| arg)) | |
| arg)) | |
| (and (< arg 0) | |
| (<= (vertical-motion | |
| (cons (or goal-column | |
| (if (consp temporary-goal-column) | |
| (car temporary-goal-column) | |
| temporary-goal-column)) | |
| arg)) | |
| arg))) | |
| (or (>= arg 0) | |
| (/= (point) opoint) | |
| ;; If the goal column lies on a display string, | |
| ;; `vertical-motion' advances the cursor to the end | |
| ;; of the string. For arg < 0, this can cause the | |
| ;; cursor to get stuck. (Bug#3020). | |
| (= (vertical-motion arg) arg))) | |
| (unless noerror | |
| (signal (if (< arg 0) 'beginning-of-buffer 'end-of-buffer) | |
| nil))))) | |
| ;; This is the guts of next-line and previous-line. | |
| ;; Arg says how many lines to move. | |
| ;; The value is t if we can move the specified number of lines. | |
| (defun line-move-1 (arg &optional noerror _to-end) | |
| ;; Don't run any point-motion hooks, and disregard intangibility, | |
| ;; for intermediate positions. | |
| (let ((inhibit-point-motion-hooks t) | |
| (opoint (point)) | |
| (orig-arg arg)) | |
| (if (consp temporary-goal-column) | |
| (setq temporary-goal-column (+ (car temporary-goal-column) | |
| (cdr temporary-goal-column)))) | |
| (unwind-protect | |
| (progn | |
| (if (not (memq last-command '(next-line previous-line))) | |
| (setq temporary-goal-column | |
| (if (and track-eol (eolp) | |
| ;; Don't count beg of empty line as end of line | |
| ;; unless we just did explicit end-of-line. | |
| (or (not (bolp)) (eq last-command 'move-end-of-line))) | |
| most-positive-fixnum | |
| (current-column)))) | |
| (if (not (or (integerp selective-display) | |
| line-move-ignore-invisible)) | |
| ;; Use just newline characters. | |
| ;; Set ARG to 0 if we move as many lines as requested. | |
| (or (if (> arg 0) | |
| (progn (if (> arg 1) (forward-line (1- arg))) | |
| ;; This way of moving forward ARG lines | |
| ;; verifies that we have a newline after the last one. | |
| ;; It doesn't get confused by intangible text. | |
| (end-of-line) | |
| (if (zerop (forward-line 1)) | |
| (setq arg 0))) | |
| (and (zerop (forward-line arg)) | |
| (bolp) | |
| (setq arg 0))) | |
| (unless noerror | |
| (signal (if (< arg 0) | |
| 'beginning-of-buffer | |
| 'end-of-buffer) | |
| nil))) | |
| ;; Move by arg lines, but ignore invisible ones. | |
| (let (done) | |
| (while (and (> arg 0) (not done)) | |
| ;; If the following character is currently invisible, | |
| ;; skip all characters with that same `invisible' property value. | |
| (while (and (not (eobp)) (invisible-p (point))) | |
| (goto-char (next-char-property-change (point)))) | |
| ;; Move a line. | |
| ;; We don't use `end-of-line', since we want to escape | |
| ;; from field boundaries occurring exactly at point. | |
| (goto-char (constrain-to-field | |
| (let ((inhibit-field-text-motion t)) | |
| (line-end-position)) | |
| (point) t t | |
| 'inhibit-line-move-field-capture)) | |
| ;; If there's no invisibility here, move over the newline. | |
| (cond | |
| ((eobp) | |
| (if (not noerror) | |
| (signal 'end-of-buffer nil) | |
| (setq done t))) | |
| ((and (> arg 1) ;; Use vertical-motion for last move | |
| (not (integerp selective-display)) | |
| (not (invisible-p (point)))) | |
| ;; We avoid vertical-motion when possible | |
| ;; because that has to fontify. | |
| (forward-line 1)) | |
| ;; Otherwise move a more sophisticated way. | |
| ((zerop (vertical-motion 1)) | |
| (if (not noerror) | |
| (signal 'end-of-buffer nil) | |
| (setq done t)))) | |
| (unless done | |
| (setq arg (1- arg)))) | |
| ;; The logic of this is the same as the loop above, | |
| ;; it just goes in the other direction. | |
| (while (and (< arg 0) (not done)) | |
| ;; For completely consistency with the forward-motion | |
| ;; case, we should call beginning-of-line here. | |
| ;; However, if point is inside a field and on a | |
| ;; continued line, the call to (vertical-motion -1) | |
| ;; below won't move us back far enough; then we return | |
| ;; to the same column in line-move-finish, and point | |
| ;; gets stuck -- cyd | |
| (forward-line 0) | |
| (cond | |
| ((bobp) | |
| (if (not noerror) | |
| (signal 'beginning-of-buffer nil) | |
| (setq done t))) | |
| ((and (< arg -1) ;; Use vertical-motion for last move | |
| (not (integerp selective-display)) | |
| (not (invisible-p (1- (point))))) | |
| (forward-line -1)) | |
| ((zerop (vertical-motion -1)) | |
| (if (not noerror) | |
| (signal 'beginning-of-buffer nil) | |
| (setq done t)))) | |
| (unless done | |
| (setq arg (1+ arg)) | |
| (while (and ;; Don't move over previous invis lines | |
| ;; if our target is the middle of this line. | |
| (or (zerop (or goal-column temporary-goal-column)) | |
| (< arg 0)) | |
| (not (bobp)) (invisible-p (1- (point)))) | |
| (goto-char (previous-char-property-change (point)))))))) | |
| ;; This is the value the function returns. | |
| (= arg 0)) | |
| (cond ((> arg 0) | |
| ;; If we did not move down as far as desired, at least go | |
| ;; to end of line. Be sure to call point-entered and | |
| ;; point-left-hooks. | |
| (let* ((npoint (prog1 (line-end-position) | |
| (goto-char opoint))) | |
| (inhibit-point-motion-hooks nil)) | |
| (goto-char npoint))) | |
| ((< arg 0) | |
| ;; If we did not move up as far as desired, | |
| ;; at least go to beginning of line. | |
| (let* ((npoint (prog1 (line-beginning-position) | |
| (goto-char opoint))) | |
| (inhibit-point-motion-hooks nil)) | |
| (goto-char npoint))) | |
| (t | |
| (line-move-finish (or goal-column temporary-goal-column) | |
| opoint (> orig-arg 0))))))) | |
| (defun line-move-finish (column opoint forward) | |
| (let ((repeat t)) | |
| (while repeat | |
| ;; Set REPEAT to t to repeat the whole thing. | |
| (setq repeat nil) | |
| (let (new | |
| (old (point)) | |
| (line-beg (line-beginning-position)) | |
| (line-end | |
| ;; Compute the end of the line | |
| ;; ignoring effectively invisible newlines. | |
| (save-excursion | |
| ;; Like end-of-line but ignores fields. | |
| (skip-chars-forward "^\n") | |
| (while (and (not (eobp)) (invisible-p (point))) | |
| (goto-char (next-char-property-change (point))) | |
| (skip-chars-forward "^\n")) | |
| (point)))) | |
| ;; Move to the desired column. | |
| (if (and line-move-visual | |
| (not (or truncate-lines truncate-partial-width-windows))) | |
| ;; Under line-move-visual, goal-column should be | |
| ;; interpreted in units of the frame's canonical character | |
| ;; width, which is exactly what vertical-motion does. | |
| (vertical-motion (cons column 0)) | |
| (line-move-to-column (truncate column))) | |
| ;; Corner case: suppose we start out in a field boundary in | |
| ;; the middle of a continued line. When we get to | |
| ;; line-move-finish, point is at the start of a new *screen* | |
| ;; line but the same text line; then line-move-to-column would | |
| ;; move us backwards. Test using C-n with point on the "x" in | |
| ;; (insert "a" (propertize "x" 'field t) (make-string 89 ?y)) | |
| (and forward | |
| (< (point) old) | |
| (goto-char old)) | |
| (setq new (point)) | |
| ;; Process intangibility within a line. | |
| ;; With inhibit-point-motion-hooks bound to nil, a call to | |
| ;; goto-char moves point past intangible text. | |
| ;; However, inhibit-point-motion-hooks controls both the | |
| ;; intangibility and the point-entered/point-left hooks. The | |
| ;; following hack avoids calling the point-* hooks | |
| ;; unnecessarily. Note that we move *forward* past intangible | |
| ;; text when the initial and final points are the same. | |
| (goto-char new) | |
| (let ((inhibit-point-motion-hooks nil)) | |
| (goto-char new) | |
| ;; If intangibility moves us to a different (later) place | |
| ;; in the same line, use that as the destination. | |
| (if (<= (point) line-end) | |
| (setq new (point)) | |
| ;; If that position is "too late", | |
| ;; try the previous allowable position. | |
| ;; See if it is ok. | |
| (backward-char) | |
| (if (if forward | |
| ;; If going forward, don't accept the previous | |
| ;; allowable position if it is before the target line. | |
| (< line-beg (point)) | |
| ;; If going backward, don't accept the previous | |
| ;; allowable position if it is still after the target line. | |
| (<= (point) line-end)) | |
| (setq new (point)) | |
| ;; As a last resort, use the end of the line. | |
| (setq new line-end)))) | |
| ;; Now move to the updated destination, processing fields | |
| ;; as well as intangibility. | |
| (goto-char opoint) | |
| (let ((inhibit-point-motion-hooks nil)) | |
| (goto-char | |
| ;; Ignore field boundaries if the initial and final | |
| ;; positions have the same `field' property, even if the | |
| ;; fields are non-contiguous. This seems to be "nicer" | |
| ;; behavior in many situations. | |
| (if (eq (get-char-property new 'field) | |
| (get-char-property opoint 'field)) | |
| new | |
| (constrain-to-field new opoint t t | |
| 'inhibit-line-move-field-capture)))) | |
| ;; If all this moved us to a different line, | |
| ;; retry everything within that new line. | |
| (when (or (< (point) line-beg) (> (point) line-end)) | |
| ;; Repeat the intangibility and field processing. | |
| (setq repeat t)))))) | |
| (defun line-move-to-column (col) | |
| "Try to find column COL, considering invisibility. | |
| This function works only in certain cases, | |
| because what we really need is for `move-to-column' | |
| and `current-column' to be able to ignore invisible text." | |
| (if (zerop col) | |
| (beginning-of-line) | |
| (move-to-column col)) | |
| (when (and line-move-ignore-invisible | |
| (not (bolp)) (invisible-p (1- (point)))) | |
| (let ((normal-location (point)) | |
| (normal-column (current-column))) | |
| ;; If the following character is currently invisible, | |
| ;; skip all characters with that same `invisible' property value. | |
| (while (and (not (eobp)) | |
| (invisible-p (point))) | |
| (goto-char (next-char-property-change (point)))) | |
| ;; Have we advanced to a larger column position? | |
| (if (> (current-column) normal-column) | |
| ;; We have made some progress towards the desired column. | |
| ;; See if we can make any further progress. | |
| (line-move-to-column (+ (current-column) (- col normal-column))) | |
| ;; Otherwise, go to the place we originally found | |
| ;; and move back over invisible text. | |
| ;; that will get us to the same place on the screen | |
| ;; but with a more reasonable buffer position. | |
| (goto-char normal-location) | |
| (let ((line-beg | |
| ;; We want the real line beginning, so it's consistent | |
| ;; with bolp below, otherwise we might infloop. | |
| (let ((inhibit-field-text-motion t)) | |
| (line-beginning-position)))) | |
| (while (and (not (bolp)) (invisible-p (1- (point)))) | |
| (goto-char (previous-char-property-change (point) line-beg)))))))) | |
| (defun move-end-of-line (arg) | |
| "Move point to end of current line as displayed. | |
| With argument ARG not nil or 1, move forward ARG - 1 lines first. | |
| If point reaches the beginning or end of buffer, it stops there. | |
| To ignore the effects of the `intangible' text or overlay | |
| property, bind `inhibit-point-motion-hooks' to t. | |
| If there is an image in the current line, this function | |
| disregards newlines that are part of the text on which the image | |
| rests." | |
| (interactive "^p") | |
| (or arg (setq arg 1)) | |
| (let (done) | |
| (while (not done) | |
| (let ((newpos | |
| (save-excursion | |
| (let ((goal-column 0) | |
| (line-move-visual nil)) | |
| (and (line-move arg t) | |
| ;; With bidi reordering, we may not be at bol, | |
| ;; so make sure we are. | |
| (skip-chars-backward "^\n") | |
| (not (bobp)) | |
| (progn | |
| (while (and (not (bobp)) (invisible-p (1- (point)))) | |
| (goto-char (previous-single-char-property-change | |
| (point) 'invisible))) | |
| (backward-char 1))) | |
| (point))))) | |
| (goto-char newpos) | |
| (if (and (> (point) newpos) | |
| (eq (preceding-char) ?\n)) | |
| (backward-char 1) | |
| (if (and (> (point) newpos) (not (eobp)) | |
| (not (eq (following-char) ?\n))) | |
| ;; If we skipped something intangible and now we're not | |
| ;; really at eol, keep going. | |
| (setq arg 1) | |
| (setq done t))))))) | |
| (defun move-beginning-of-line (arg) | |
| "Move point to beginning of current line as displayed. | |
| \(If there's an image in the line, this disregards newlines | |
| that are part of the text that the image rests on.) | |
| With argument ARG not nil or 1, move forward ARG - 1 lines first. | |
| If point reaches the beginning or end of buffer, it stops there. | |
| \(But if the buffer doesn't end in a newline, it stops at the | |
| beginning of the last line.) | |
| To ignore intangibility, bind `inhibit-point-motion-hooks' to t." | |
| (interactive "^p") | |
| (or arg (setq arg 1)) | |
| (let ((orig (point)) | |
| first-vis first-vis-field-value) | |
| ;; Move by lines, if ARG is not 1 (the default). | |
| (if (/= arg 1) | |
| (let ((line-move-visual nil)) | |
| (line-move (1- arg) t))) | |
| ;; Move to beginning-of-line, ignoring fields and invisible text. | |
| (skip-chars-backward "^\n") | |
| (while (and (not (bobp)) (invisible-p (1- (point)))) | |
| (goto-char (previous-char-property-change (point))) | |
| (skip-chars-backward "^\n")) | |
| ;; Now find first visible char in the line. | |
| (while (and (< (point) orig) (invisible-p (point))) | |
| (goto-char (next-char-property-change (point) orig))) | |
| (setq first-vis (point)) | |
| ;; See if fields would stop us from reaching FIRST-VIS. | |
| (setq first-vis-field-value | |
| (constrain-to-field first-vis orig (/= arg 1) t nil)) | |
| (goto-char (if (/= first-vis-field-value first-vis) | |
| ;; If yes, obey them. | |
| first-vis-field-value | |
| ;; Otherwise, move to START with attention to fields. | |
| ;; (It is possible that fields never matter in this case.) | |
| (constrain-to-field (point) orig | |
| (/= arg 1) t nil))))) | |
| ;; Many people have said they rarely use this feature, and often type | |
| ;; it by accident. Maybe it shouldn't even be on a key. | |
| (put 'set-goal-column 'disabled t) | |
| (defun set-goal-column (arg) | |
| "Set the current horizontal position as a goal for \\[next-line] and \\[previous-line]. | |
| Those commands will move to this position in the line moved to | |
| rather than trying to keep the same horizontal position. | |
| With a non-nil argument ARG, clears out the goal column | |
| so that \\[next-line] and \\[previous-line] resume vertical motion. | |
| The goal column is stored in the variable `goal-column'. | |
| This is a buffer-local setting." | |
| (interactive "P") | |
| (if arg | |
| (progn | |
| (setq goal-column nil) | |
| (message "No goal column")) | |
| (setq goal-column (current-column)) | |
| ;; The older method below can be erroneous if `set-goal-column' is bound | |
| ;; to a sequence containing % | |
| ;;(message (substitute-command-keys | |
| ;;"Goal column %d (use \\[set-goal-column] with an arg to unset it)") | |
| ;;goal-column) | |
| (message "%s" | |
| (concat | |
| (format "Goal column %d " goal-column) | |
| (substitute-command-keys | |
| "(use \\[set-goal-column] with an arg to unset it)"))) | |
| ) | |
| nil) | |
| ;;; Editing based on visual lines, as opposed to logical lines. | |
| (defun end-of-visual-line (&optional n) | |
| "Move point to end of current visual line. | |
| With argument N not nil or 1, move forward N - 1 visual lines first. | |
| If point reaches the beginning or end of buffer, it stops there. | |
| To ignore intangibility, bind `inhibit-point-motion-hooks' to t." | |
| (interactive "^p") | |
| (or n (setq n 1)) | |
| (if (/= n 1) | |
| (let ((line-move-visual t)) | |
| (line-move (1- n) t))) | |
| ;; Unlike `move-beginning-of-line', `move-end-of-line' doesn't | |
| ;; constrain to field boundaries, so we don't either. | |
| (vertical-motion (cons (window-width) 0))) | |
| (defun beginning-of-visual-line (&optional n) | |
| "Move point to beginning of current visual line. | |
| With argument N not nil or 1, move forward N - 1 visual lines first. | |
| If point reaches the beginning or end of buffer, it stops there. | |
| \(But if the buffer doesn't end in a newline, it stops at the | |
| beginning of the last visual line.) | |
| To ignore intangibility, bind `inhibit-point-motion-hooks' to t." | |
| (interactive "^p") | |
| (or n (setq n 1)) | |
| (let ((opoint (point))) | |
| (if (/= n 1) | |
| (let ((line-move-visual t)) | |
| (line-move (1- n) t))) | |
| (vertical-motion 0) | |
| ;; Constrain to field boundaries, like `move-beginning-of-line'. | |
| (goto-char (constrain-to-field (point) opoint (/= n 1))))) | |
| (defun kill-visual-line (&optional arg) | |
| "Kill the rest of the visual line. | |
| With prefix argument ARG, kill that many visual lines from point. | |
| If ARG is negative, kill visual lines backward. | |
| If ARG is zero, kill the text before point on the current visual | |
| line. | |
| If you want to append the killed line to the last killed text, | |
| use \\[append-next-kill] before \\[kill-line]. | |
| If the buffer is read-only, Emacs will beep and refrain from deleting | |
| the line, but put the line in the kill ring anyway. This means that | |
| you can use this command to copy text from a read-only buffer. | |
| \(If the variable `kill-read-only-ok' is non-nil, then this won't | |
| even beep.)" | |
| (interactive "P") | |
| ;; Like in `kill-line', it's better to move point to the other end | |
| ;; of the kill before killing. | |
| (let ((opoint (point)) | |
| (kill-whole-line (and kill-whole-line (bolp)))) | |
| (if arg | |
| (vertical-motion (prefix-numeric-value arg)) | |
| (end-of-visual-line 1) | |
| (if (= (point) opoint) | |
| (vertical-motion 1) | |
| ;; Skip any trailing whitespace at the end of the visual line. | |
| ;; We used to do this only if `show-trailing-whitespace' is | |
| ;; nil, but that's wrong; the correct thing would be to check | |
| ;; whether the trailing whitespace is highlighted. But, it's | |
| ;; OK to just do this unconditionally. | |
| (skip-chars-forward " \t"))) | |
| (kill-region opoint (if (and kill-whole-line (= (following-char) ?\n)) | |
| (1+ (point)) | |
| (point))))) | |
| (defun next-logical-line (&optional arg try-vscroll) | |
| "Move cursor vertically down ARG lines. | |
| This is identical to `next-line', except that it always moves | |
| by logical lines instead of visual lines, ignoring the value of | |
| the variable `line-move-visual'." | |
| (interactive "^p\np") | |
| (let ((line-move-visual nil)) | |
| (with-no-warnings | |
| (next-line arg try-vscroll)))) | |
| (defun previous-logical-line (&optional arg try-vscroll) | |
| "Move cursor vertically up ARG lines. | |
| This is identical to `previous-line', except that it always moves | |
| by logical lines instead of visual lines, ignoring the value of | |
| the variable `line-move-visual'." | |
| (interactive "^p\np") | |
| (let ((line-move-visual nil)) | |
| (with-no-warnings | |
| (previous-line arg try-vscroll)))) | |
| (defgroup visual-line nil | |
| "Editing based on visual lines." | |
| :group 'convenience | |
| :version "23.1") | |
| (defvar visual-line-mode-map | |
| (let ((map (make-sparse-keymap))) | |
| (define-key map [remap kill-line] 'kill-visual-line) | |
| (define-key map [remap move-beginning-of-line] 'beginning-of-visual-line) | |
| (define-key map [remap move-end-of-line] 'end-of-visual-line) | |
| ;; These keybindings interfere with xterm function keys. Are | |
| ;; there any other suitable bindings? | |
| ;; (define-key map "\M-[" 'previous-logical-line) | |
| ;; (define-key map "\M-]" 'next-logical-line) | |
| map)) | |
| (defcustom visual-line-fringe-indicators '(nil nil) | |
| "How fringe indicators are shown for wrapped lines in `visual-line-mode'. | |
| The value should be a list of the form (LEFT RIGHT), where LEFT | |
| and RIGHT are symbols representing the bitmaps to display, to | |
| indicate wrapped lines, in the left and right fringes respectively. | |
| See also `fringe-indicator-alist'. | |
| The default is not to display fringe indicators for wrapped lines. | |
| This variable does not affect fringe indicators displayed for | |
| other purposes." | |
| :type '(list (choice (const :tag "Hide left indicator" nil) | |
| (const :tag "Left curly arrow" left-curly-arrow) | |
| (symbol :tag "Other bitmap")) | |
| (choice (const :tag "Hide right indicator" nil) | |
| (const :tag "Right curly arrow" right-curly-arrow) | |
| (symbol :tag "Other bitmap"))) | |
| :set (lambda (symbol value) | |
| (dolist (buf (buffer-list)) | |
| (with-current-buffer buf | |
| (when (and (boundp 'visual-line-mode) | |
| (symbol-value 'visual-line-mode)) | |
| (setq fringe-indicator-alist | |
| (cons (cons 'continuation value) | |
| (assq-delete-all | |
| 'continuation | |
| (copy-tree fringe-indicator-alist))))))) | |
| (set-default symbol value))) | |
| (defvar visual-line--saved-state nil) | |
| (define-minor-mode visual-line-mode | |
| "Toggle visual line based editing (Visual Line mode) in the current buffer. | |
| When Visual Line mode is enabled, `word-wrap' is turned on in | |
| this buffer, and simple editing commands are redefined to act on | |
| visual lines, not logical lines. See Info node `Visual Line | |
| Mode' for details." | |
| :keymap visual-line-mode-map | |
| :group 'visual-line | |
| :lighter " Wrap" | |
| (if visual-line-mode | |
| (progn | |
| (set (make-local-variable 'visual-line--saved-state) nil) | |
| ;; Save the local values of some variables, to be restored if | |
| ;; visual-line-mode is turned off. | |
| (dolist (var '(line-move-visual truncate-lines | |
| truncate-partial-width-windows | |
| word-wrap fringe-indicator-alist)) | |
| (if (local-variable-p var) | |
| (push (cons var (symbol-value var)) | |
| visual-line--saved-state))) | |
| (set (make-local-variable 'line-move-visual) t) | |
| (set (make-local-variable 'truncate-partial-width-windows) nil) | |
| (setq truncate-lines nil | |
| word-wrap t | |
| fringe-indicator-alist | |
| (cons (cons 'continuation visual-line-fringe-indicators) | |
| fringe-indicator-alist))) | |
| (kill-local-variable 'line-move-visual) | |
| (kill-local-variable 'word-wrap) | |
| (kill-local-variable 'truncate-lines) | |
| (kill-local-variable 'truncate-partial-width-windows) | |
| (kill-local-variable 'fringe-indicator-alist) | |
| (dolist (saved visual-line--saved-state) | |
| (set (make-local-variable (car saved)) (cdr saved))) | |
| (kill-local-variable 'visual-line--saved-state))) | |
| (defun turn-on-visual-line-mode () | |
| (visual-line-mode 1)) | |
| (define-globalized-minor-mode global-visual-line-mode | |
| visual-line-mode turn-on-visual-line-mode) | |
| (defun transpose-chars (arg) | |
| "Interchange characters around point, moving forward one character. | |
| With prefix arg ARG, effect is to take character before point | |
| and drag it forward past ARG other characters (backward if ARG negative). | |
| If no argument and at end of line, the previous two chars are exchanged." | |
| (interactive "*P") | |
| (when (and (null arg) (eolp) (not (bobp)) | |
| (not (get-text-property (1- (point)) 'read-only))) | |
| (forward-char -1)) | |
| (transpose-subr 'forward-char (prefix-numeric-value arg))) | |
| (defun transpose-words (arg) | |
| "Interchange words around point, leaving point at end of them. | |
| With prefix arg ARG, effect is to take word before or around point | |
| and drag it forward past ARG other words (backward if ARG negative). | |
| If ARG is zero, the words around or after point and around or after mark | |
| are interchanged." | |
| ;; FIXME: `foo a!nd bar' should transpose into `bar and foo'. | |
| (interactive "*p") | |
| (transpose-subr 'forward-word arg)) | |
| (defun transpose-sexps (arg) | |
| "Like \\[transpose-chars] (`transpose-chars'), but applies to sexps. | |
| Unlike `transpose-words', point must be between the two sexps and not | |
| in the middle of a sexp to be transposed. | |
| With non-zero prefix arg ARG, effect is to take the sexp before point | |
| and drag it forward past ARG other sexps (backward if ARG is negative). | |
| If ARG is zero, the sexps ending at or after point and at or after mark | |
| are interchanged." | |
| (interactive "*p") | |
| (transpose-subr | |
| (lambda (arg) | |
| ;; Here we should try to simulate the behavior of | |
| ;; (cons (progn (forward-sexp x) (point)) | |
| ;; (progn (forward-sexp (- x)) (point))) | |
| ;; Except that we don't want to rely on the second forward-sexp | |
| ;; putting us back to where we want to be, since forward-sexp-function | |
| ;; might do funny things like infix-precedence. | |
| (if (if (> arg 0) | |
| (looking-at "\\sw\\|\\s_") | |
| (and (not (bobp)) | |
| (save-excursion (forward-char -1) (looking-at "\\sw\\|\\s_")))) | |
| ;; Jumping over a symbol. We might be inside it, mind you. | |
| (progn (funcall (if (> arg 0) | |
| 'skip-syntax-backward 'skip-syntax-forward) | |
| "w_") | |
| (cons (save-excursion (forward-sexp arg) (point)) (point))) | |
| ;; Otherwise, we're between sexps. Take a step back before jumping | |
| ;; to make sure we'll obey the same precedence no matter which direction | |
| ;; we're going. | |
| (funcall (if (> arg 0) 'skip-syntax-backward 'skip-syntax-forward) " .") | |
| (cons (save-excursion (forward-sexp arg) (point)) | |
| (progn (while (or (forward-comment (if (> arg 0) 1 -1)) | |
| (not (zerop (funcall (if (> arg 0) | |
| 'skip-syntax-forward | |
| 'skip-syntax-backward) | |
| "."))))) | |
| (point))))) | |
| arg 'special)) | |
| (defun transpose-lines (arg) | |
| "Exchange current line and previous line, leaving point after both. | |
| With argument ARG, takes previous line and moves it past ARG lines. | |
| With argument 0, interchanges line point is in with line mark is in." | |
| (interactive "*p") | |
| (transpose-subr (function | |
| (lambda (arg) | |
| (if (> arg 0) | |
| (progn | |
| ;; Move forward over ARG lines, | |
| ;; but create newlines if necessary. | |
| (setq arg (forward-line arg)) | |
| (if (/= (preceding-char) ?\n) | |
| (setq arg (1+ arg))) | |
| (if (> arg 0) | |
| (newline arg))) | |
| (forward-line arg)))) | |
| arg)) | |
| ;; FIXME seems to leave point BEFORE the current object when ARG = 0, | |
| ;; which seems inconsistent with the ARG /= 0 case. | |
| ;; FIXME document SPECIAL. | |
| (defun transpose-subr (mover arg &optional special) | |
| "Subroutine to do the work of transposing objects. | |
| Works for lines, sentences, paragraphs, etc. MOVER is a function that | |
| moves forward by units of the given object (e.g. forward-sentence, | |
| forward-paragraph). If ARG is zero, exchanges the current object | |
| with the one containing mark. If ARG is an integer, moves the | |
| current object past ARG following (if ARG is positive) or | |
| preceding (if ARG is negative) objects, leaving point after the | |
| current object." | |
| (let ((aux (if special mover | |
| (lambda (x) | |
| (cons (progn (funcall mover x) (point)) | |
| (progn (funcall mover (- x)) (point)))))) | |
| pos1 pos2) | |
| (cond | |
| ((= arg 0) | |
| (save-excursion | |
| (setq pos1 (funcall aux 1)) | |
| (goto-char (or (mark) (error "No mark set in this buffer"))) | |
| (setq pos2 (funcall aux 1)) | |
| (transpose-subr-1 pos1 pos2)) | |
| (exchange-point-and-mark)) | |
| ((> arg 0) | |
| (setq pos1 (funcall aux -1)) | |
| (setq pos2 (funcall aux arg)) | |
| (transpose-subr-1 pos1 pos2) | |
| (goto-char (car pos2))) | |
| (t | |
| (setq pos1 (funcall aux -1)) | |
| (goto-char (car pos1)) | |
| (setq pos2 (funcall aux arg)) | |
| (transpose-subr-1 pos1 pos2) | |
| (goto-char (+ (car pos2) (- (cdr pos1) (car pos1)))))))) | |
| (defun transpose-subr-1 (pos1 pos2) | |
| (when (> (car pos1) (cdr pos1)) (setq pos1 (cons (cdr pos1) (car pos1)))) | |
| (when (> (car pos2) (cdr pos2)) (setq pos2 (cons (cdr pos2) (car pos2)))) | |
| (when (> (car pos1) (car pos2)) | |
| (let ((swap pos1)) | |
| (setq pos1 pos2 pos2 swap))) | |
| (if (> (cdr pos1) (car pos2)) (error "Don't have two things to transpose")) | |
| (atomic-change-group | |
| ;; This sequence of insertions attempts to preserve marker | |
| ;; positions at the start and end of the transposed objects. | |
| (let* ((word (buffer-substring (car pos2) (cdr pos2))) | |
| (len1 (- (cdr pos1) (car pos1))) | |
| (len2 (length word)) | |
| (boundary (make-marker))) | |
| (set-marker boundary (car pos2)) | |
| (goto-char (cdr pos1)) | |
| (insert-before-markers word) | |
| (setq word (delete-and-extract-region (car pos1) (+ (car pos1) len1))) | |
| (goto-char boundary) | |
| (insert word) | |
| (goto-char (+ boundary len1)) | |
| (delete-region (point) (+ (point) len2)) | |
| (set-marker boundary nil)))) | |
| (defun backward-word (&optional arg) | |
| "Move backward until encountering the beginning of a word. | |
| With argument ARG, do this that many times. | |
| If ARG is omitted or nil, move point backward one word. | |
| The word boundaries are normally determined by the buffer's | |
| syntax table and character script (according to | |
| `char-script-table'), but `find-word-boundary-function-table', | |
| such as set up by `subword-mode', can change that. If a Lisp | |
| program needs to move by words determined strictly by the syntax | |
| table, it should use `backward-word-strictly' instead. See Info | |
| node `(elisp) Word Motion' for details." | |
| (interactive "^p") | |
| (forward-word (- (or arg 1)))) | |
| (defun mark-word (&optional arg allow-extend) | |
| "Set mark ARG words away from point. | |
| The place mark goes is the same place \\[forward-word] would | |
| move to with the same argument. | |
| Interactively, if this command is repeated | |
| or (in Transient Mark mode) if the mark is active, | |
| it marks the next ARG words after the ones already marked." | |
| (interactive "P\np") | |
| (cond ((and allow-extend | |
| (or (and (eq last-command this-command) (mark t)) | |
| (region-active-p))) | |
| (setq arg (if arg (prefix-numeric-value arg) | |
| (if (< (mark) (point)) -1 1))) | |
| (set-mark | |
| (save-excursion | |
| (goto-char (mark)) | |
| (forward-word arg) | |
| (point)))) | |
| (t | |
| (push-mark | |
| (save-excursion | |
| (forward-word (prefix-numeric-value arg)) | |
| (point)) | |
| nil t)))) | |
| (defun kill-word (arg) | |
| "Kill characters forward until encountering the end of a word. | |
| With argument ARG, do this that many times." | |
| (interactive "p") | |
| (kill-region (point) (progn (forward-word arg) (point)))) | |
| (defun backward-kill-word (arg) | |
| "Kill characters backward until encountering the beginning of a word. | |
| With argument ARG, do this that many times." | |
| (interactive "p") | |
| (kill-word (- arg))) | |
| (defun current-word (&optional strict really-word) | |
| "Return the word at or near point, as a string. | |
| The return value includes no text properties. | |
| If optional arg STRICT is non-nil, return nil unless point is | |
| within or adjacent to a word, otherwise look for a word within | |
| point's line. If there is no word anywhere on point's line, the | |
| value is nil regardless of STRICT. | |
| By default, this function treats as a single word any sequence of | |
| characters that have either word or symbol syntax. If optional | |
| arg REALLY-WORD is non-nil, only characters of word syntax can | |
| constitute a word." | |
| (save-excursion | |
| (let* ((oldpoint (point)) (start (point)) (end (point)) | |
| (syntaxes (if really-word "w" "w_")) | |
| (not-syntaxes (concat "^" syntaxes))) | |
| (skip-syntax-backward syntaxes) (setq start (point)) | |
| (goto-char oldpoint) | |
| (skip-syntax-forward syntaxes) (setq end (point)) | |
| (when (and (eq start oldpoint) (eq end oldpoint) | |
| ;; Point is neither within nor adjacent to a word. | |
| (not strict)) | |
| ;; Look for preceding word in same line. | |
| (skip-syntax-backward not-syntaxes (line-beginning-position)) | |
| (if (bolp) | |
| ;; No preceding word in same line. | |
| ;; Look for following word in same line. | |
| (progn | |
| (skip-syntax-forward not-syntaxes (line-end-position)) | |
| (setq start (point)) | |
| (skip-syntax-forward syntaxes) | |
| (setq end (point))) | |
| (setq end (point)) | |
| (skip-syntax-backward syntaxes) | |
| (setq start (point)))) | |
| ;; If we found something nonempty, return it as a string. | |
| (unless (= start end) | |
| (buffer-substring-no-properties start end))))) | |
| (defcustom fill-prefix nil | |
| "String for filling to insert at front of new line, or nil for none." | |
| :type '(choice (const :tag "None" nil) | |
| string) | |
| :group 'fill) | |
| (make-variable-buffer-local 'fill-prefix) | |
| (put 'fill-prefix 'safe-local-variable 'string-or-null-p) | |
| (defcustom auto-fill-inhibit-regexp nil | |
| "Regexp to match lines that should not be auto-filled." | |
| :type '(choice (const :tag "None" nil) | |
| regexp) | |
| :group 'fill) | |
| (defun do-auto-fill () | |
| "The default value for `normal-auto-fill-function'. | |
| This is the default auto-fill function, some major modes use a different one. | |
| Returns t if it really did any work." | |
| (let (fc justify give-up | |
| (fill-prefix fill-prefix)) | |
| (if (or (not (setq justify (current-justification))) | |
| (null (setq fc (current-fill-column))) | |
| (and (eq justify 'left) | |
| (<= (current-column) fc)) | |
| (and auto-fill-inhibit-regexp | |
| (save-excursion (beginning-of-line) | |
| (looking-at auto-fill-inhibit-regexp)))) | |
| nil ;; Auto-filling not required | |
| (if (memq justify '(full center right)) | |
| (save-excursion (unjustify-current-line))) | |
| ;; Choose a fill-prefix automatically. | |
| (when (and adaptive-fill-mode | |
| (or (null fill-prefix) (string= fill-prefix ""))) | |
| (let ((prefix | |
| (fill-context-prefix | |
| (save-excursion (fill-forward-paragraph -1) (point)) | |
| (save-excursion (fill-forward-paragraph 1) (point))))) | |
| (and prefix (not (equal prefix "")) | |
| ;; Use auto-indentation rather than a guessed empty prefix. | |
| (not (and fill-indent-according-to-mode | |
| (string-match "\\`[ \t]*\\'" prefix))) | |
| (setq fill-prefix prefix)))) | |
| (while (and (not give-up) (> (current-column) fc)) | |
| ;; Determine where to split the line. | |
| (let ((fill-point | |
| (save-excursion | |
| (beginning-of-line) | |
| ;; Don't split earlier in the line than the length of the | |
| ;; fill prefix, since the resulting line would be longer. | |
| (when fill-prefix | |
| (move-to-column (string-width fill-prefix))) | |
| (let ((after-prefix (point))) | |
| (move-to-column (1+ fc)) | |
| (fill-move-to-break-point after-prefix) | |
| (point))))) | |
| ;; See whether the place we found is any good. | |
| (if (save-excursion | |
| (goto-char fill-point) | |
| (or (bolp) | |
| ;; There is no use breaking at end of line. | |
| (save-excursion (skip-chars-forward " ") (eolp)) | |
| ;; Don't split right after a comment starter | |
| ;; since we would just make another comment starter. | |
| (and comment-start-skip | |
| (let ((limit (point))) | |
| (beginning-of-line) | |
| (and (re-search-forward comment-start-skip | |
| limit t) | |
| (eq (point) limit)))))) | |
| ;; No good place to break => stop trying. | |
| (setq give-up t) | |
| ;; Ok, we have a useful place to break the line. Do it. | |
| (let ((prev-column (current-column))) | |
| ;; If point is at the fill-point, do not `save-excursion'. | |
| ;; Otherwise, if a comment prefix or fill-prefix is inserted, | |
| ;; point will end up before it rather than after it. | |
| (if (save-excursion | |
| (skip-chars-backward " \t") | |
| (= (point) fill-point)) | |
| (default-indent-new-line t) | |
| (save-excursion | |
| (goto-char fill-point) | |
| (default-indent-new-line t))) | |
| ;; Now do justification, if required | |
| (if (not (eq justify 'left)) | |
| (save-excursion | |
| (end-of-line 0) | |
| (justify-current-line justify nil t))) | |
| ;; If making the new line didn't reduce the hpos of | |
| ;; the end of the line, then give up now; | |
| ;; trying again will not help. | |
| (if (>= (current-column) prev-column) | |
| (setq give-up t)))))) | |
| ;; Justify last line. | |
| (justify-current-line justify t t) | |
| t))) | |
| (defvar comment-line-break-function 'comment-indent-new-line | |
| "Mode-specific function that line breaks and continues a comment. | |
| This function is called during auto-filling when a comment syntax | |
| is defined. | |
| The function should take a single optional argument, which is a flag | |
| indicating whether it should use soft newlines.") | |
| (defun default-indent-new-line (&optional soft) | |
| "Break line at point and indent. | |
| If a comment syntax is defined, call `comment-line-break-function'. | |
| The inserted newline is marked hard if variable `use-hard-newlines' is true, | |
| unless optional argument SOFT is non-nil." | |
| (interactive) | |
| (if comment-start | |
| (funcall comment-line-break-function soft) | |
| ;; Insert the newline before removing empty space so that markers | |
| ;; get preserved better. | |
| (if soft (insert-and-inherit ?\n) (newline 1)) | |
| (save-excursion (forward-char -1) (delete-horizontal-space)) | |
| (delete-horizontal-space) | |
| (if (and fill-prefix (not adaptive-fill-mode)) | |
| ;; Blindly trust a non-adaptive fill-prefix. | |
| (progn | |
| (indent-to-left-margin) | |
| (insert-before-markers-and-inherit fill-prefix)) | |
| (cond | |
| ;; If there's an adaptive prefix, use it unless we're inside | |
| ;; a comment and the prefix is not a comment starter. | |
| (fill-prefix | |
| (indent-to-left-margin) | |
| (insert-and-inherit fill-prefix)) | |
| ;; If we're not inside a comment, just try to indent. | |
| (t (indent-according-to-mode)))))) | |
| (defun internal-auto-fill () | |
| "The function called by `self-insert-command' to perform auto-filling." | |
| (when (or (not comment-start) | |
| (not comment-auto-fill-only-comments) | |
| (nth 4 (syntax-ppss))) | |
| (funcall auto-fill-function))) | |
| (defvar normal-auto-fill-function 'do-auto-fill | |
| "The function to use for `auto-fill-function' if Auto Fill mode is turned on. | |
| Some major modes set this.") | |
| (put 'auto-fill-function :minor-mode-function 'auto-fill-mode) | |
| ;; `functions' and `hooks' are usually unsafe to set, but setting | |
| ;; auto-fill-function to nil in a file-local setting is safe and | |
| ;; can be useful to prevent auto-filling. | |
| (put 'auto-fill-function 'safe-local-variable 'null) | |
| (define-minor-mode auto-fill-mode | |
| "Toggle automatic line breaking (Auto Fill mode). | |
| When Auto Fill mode is enabled, inserting a space at a column | |
| beyond `current-fill-column' automatically breaks the line at a | |
| previous space. | |
| When `auto-fill-mode' is on, the `auto-fill-function' variable is | |
| non-nil. | |
| The value of `normal-auto-fill-function' specifies the function to use | |
| for `auto-fill-function' when turning Auto Fill mode on." | |
| :variable (auto-fill-function | |
| . (lambda (v) (setq auto-fill-function | |
| (if v normal-auto-fill-function))))) | |
| ;; This holds a document string used to document auto-fill-mode. | |
| (defun auto-fill-function () | |
| "Automatically break line at a previous space, in insertion of text." | |
| nil) | |
| (defun turn-on-auto-fill () | |
| "Unconditionally turn on Auto Fill mode." | |
| (auto-fill-mode 1)) | |
| (defun turn-off-auto-fill () | |
| "Unconditionally turn off Auto Fill mode." | |
| (auto-fill-mode -1)) | |
| (custom-add-option 'text-mode-hook 'turn-on-auto-fill) | |
| (defun set-fill-column (arg) | |
| "Set `fill-column' to specified argument. | |
| Use \\[universal-argument] followed by a number to specify a column. | |
| Just \\[universal-argument] as argument means to use the current column." | |
| (interactive | |
| (list (or current-prefix-arg | |
| ;; We used to use current-column silently, but C-x f is too easily | |
| ;; typed as a typo for C-x C-f, so we turned it into an error and | |
| ;; now an interactive prompt. | |
| (read-number "Set fill-column to: " (current-column))))) | |
| (if (consp arg) | |
| (setq arg (current-column))) | |
| (if (not (integerp arg)) | |
| ;; Disallow missing argument; it's probably a typo for C-x C-f. | |
| (error "set-fill-column requires an explicit argument") | |
| (message "Fill column set to %d (was %d)" arg fill-column) | |
| (setq fill-column arg))) | |
| (defun set-selective-display (arg) | |
| "Set `selective-display' to ARG; clear it if no arg. | |
| When the value of `selective-display' is a number > 0, | |
| lines whose indentation is >= that value are not displayed. | |
| The variable `selective-display' has a separate value for each buffer." | |
| (interactive "P") | |
| (if (eq selective-display t) | |
| (error "selective-display already in use for marked lines")) | |
| (let ((current-vpos | |
| (save-restriction | |
| (narrow-to-region (point-min) (point)) | |
| (goto-char (window-start)) | |
| (vertical-motion (window-height))))) | |
| (setq selective-display | |
| (and arg (prefix-numeric-value arg))) | |
| (recenter current-vpos)) | |
| (set-window-start (selected-window) (window-start)) | |
| (princ "selective-display set to " t) | |
| (prin1 selective-display t) | |
| (princ "." t)) | |
| (defvaralias 'indicate-unused-lines 'indicate-empty-lines) | |
| (defun toggle-truncate-lines (&optional arg) | |
| "Toggle truncating of long lines for the current buffer. | |
| When truncating is off, long lines are folded. | |
| With prefix argument ARG, truncate long lines if ARG is positive, | |
| otherwise fold them. Note that in side-by-side windows, this | |
| command has no effect if `truncate-partial-width-windows' is | |
| non-nil." | |
| (interactive "P") | |
| (setq truncate-lines | |
| (if (null arg) | |
| (not truncate-lines) | |
| (> (prefix-numeric-value arg) 0))) | |
| (force-mode-line-update) | |
| (unless truncate-lines | |
| (let ((buffer (current-buffer))) | |
| (walk-windows (lambda (window) | |
| (if (eq buffer (window-buffer window)) | |
| (set-window-hscroll window 0))) | |
| nil t))) | |
| (message "Truncate long lines %s" | |
| (if truncate-lines "enabled" "disabled"))) | |
| (defun toggle-word-wrap (&optional arg) | |
| "Toggle whether to use word-wrapping for continuation lines. | |
| With prefix argument ARG, wrap continuation lines at word boundaries | |
| if ARG is positive, otherwise wrap them at the right screen edge. | |
| This command toggles the value of `word-wrap'. It has no effect | |
| if long lines are truncated." | |
| (interactive "P") | |
| (setq word-wrap | |
| (if (null arg) | |
| (not word-wrap) | |
| (> (prefix-numeric-value arg) 0))) | |
| (force-mode-line-update) | |
| (message "Word wrapping %s" | |
| (if word-wrap "enabled" "disabled"))) | |
| (defvar overwrite-mode-textual (purecopy " Ovwrt") | |
| "The string displayed in the mode line when in overwrite mode.") | |
| (defvar overwrite-mode-binary (purecopy " Bin Ovwrt") | |
| "The string displayed in the mode line when in binary overwrite mode.") | |
| (define-minor-mode overwrite-mode | |
| "Toggle Overwrite mode. | |
| When Overwrite mode is enabled, printing characters typed in | |
| replace existing text on a one-for-one basis, rather than pushing | |
| it to the right. At the end of a line, such characters extend | |
| the line. Before a tab, such characters insert until the tab is | |
| filled in. \\[quoted-insert] still inserts characters in | |
| overwrite mode; this is supposed to make it easier to insert | |
| characters when necessary." | |
| :variable (overwrite-mode | |
| . (lambda (v) (setq overwrite-mode (if v 'overwrite-mode-textual))))) | |
| (define-minor-mode binary-overwrite-mode | |
| "Toggle Binary Overwrite mode. | |
| When Binary Overwrite mode is enabled, printing characters typed | |
| in replace existing text. Newlines are not treated specially, so | |
| typing at the end of a line joins the line to the next, with the | |
| typed character between them. Typing before a tab character | |
| simply replaces the tab with the character typed. | |
| \\[quoted-insert] replaces the text at the cursor, just as | |
| ordinary typing characters do. | |
| Note that Binary Overwrite mode is not its own minor mode; it is | |
| a specialization of overwrite mode, entered by setting the | |
| `overwrite-mode' variable to `overwrite-mode-binary'." | |
| :variable (overwrite-mode | |
| . (lambda (v) (setq overwrite-mode (if v 'overwrite-mode-binary))))) | |
| (define-minor-mode line-number-mode | |
| "Toggle line number display in the mode line (Line Number mode). | |
| Line numbers do not appear for very large buffers and buffers | |
| with very long lines; see variables `line-number-display-limit' | |
| and `line-number-display-limit-width'." | |
| :init-value t :global t :group 'mode-line) | |
| (define-minor-mode column-number-mode | |
| "Toggle column number display in the mode line (Column Number mode)." | |
| :global t :group 'mode-line) | |
| (define-minor-mode size-indication-mode | |
| "Toggle buffer size display in the mode line (Size Indication mode)." | |
| :global t :group 'mode-line) | |
| (define-minor-mode auto-save-mode | |
| "Toggle auto-saving in the current buffer (Auto Save mode)." | |
| :variable ((and buffer-auto-save-file-name | |
| ;; If auto-save is off because buffer has shrunk, | |
| ;; then toggling should turn it on. | |
| (>= buffer-saved-size 0)) | |
| . (lambda (val) | |
| (setq buffer-auto-save-file-name | |
| (cond | |
| ((null val) nil) | |
| ((and buffer-file-name auto-save-visited-file-name | |
| (not buffer-read-only)) | |
| buffer-file-name) | |
| (t (make-auto-save-file-name)))))) | |
| ;; If -1 was stored here, to temporarily turn off saving, | |
| ;; turn it back on. | |
| (and (< buffer-saved-size 0) | |
| (setq buffer-saved-size 0))) | |
| (defgroup paren-blinking nil | |
| "Blinking matching of parens and expressions." | |
| :prefix "blink-matching-" | |
| :group 'paren-matching) | |
| (defcustom blink-matching-paren t | |
| "Non-nil means show matching open-paren when close-paren is inserted. | |
| If t, highlight the paren. If `jump', briefly move cursor to its | |
| position. If `jump-offscreen', move cursor there even if the | |
| position is off screen. With any other non-nil value, the | |
| off-screen position of the opening paren will be shown in the | |
| echo area." | |
| :type '(choice | |
| (const :tag "Disable" nil) | |
| (const :tag "Highlight" t) | |
| (const :tag "Move cursor" jump) | |
| (const :tag "Move cursor, even if off screen" jump-offscreen)) | |
| :group 'paren-blinking) | |
| (defcustom blink-matching-paren-on-screen t | |
| "Non-nil means show matching open-paren when it is on screen. | |
| If nil, don't show it (but the open-paren can still be shown | |
| in the echo area when it is off screen). | |
| This variable has no effect if `blink-matching-paren' is nil. | |
| \(In that case, the open-paren is never shown.) | |
| It is also ignored if `show-paren-mode' is enabled." | |
| :type 'boolean | |
| :group 'paren-blinking) | |
| (defcustom blink-matching-paren-distance (* 100 1024) | |
| "If non-nil, maximum distance to search backwards for matching open-paren. | |
| If nil, search stops at the beginning of the accessible portion of the buffer." | |
| :version "23.2" ; 25->100k | |
| :type '(choice (const nil) integer) | |
| :group 'paren-blinking) | |
| (defcustom blink-matching-delay 1 | |
| "Time in seconds to delay after showing a matching paren." | |
| :type 'number | |
| :group 'paren-blinking) | |
| (defcustom blink-matching-paren-dont-ignore-comments nil | |
| "If nil, `blink-matching-paren' ignores comments. | |
| More precisely, when looking for the matching parenthesis, | |
| it skips the contents of comments that end before point." | |
| :type 'boolean | |
| :group 'paren-blinking) | |
| (defun blink-matching-check-mismatch (start end) | |
| "Return whether or not START...END are matching parens. | |
| END is the current point and START is the blink position. | |
| START might be nil if no matching starter was found. | |
| Returns non-nil if we find there is a mismatch." | |
| (let* ((end-syntax (syntax-after (1- end))) | |
| (matching-paren (and (consp end-syntax) | |
| (eq (syntax-class end-syntax) 5) | |
| (cdr end-syntax)))) | |
| ;; For self-matched chars like " and $, we can't know when they're | |
| ;; mismatched or unmatched, so we can do it only for parens. | |
| (when matching-paren | |
| (not (and start | |
| (or | |
| (eq (char-after start) matching-paren) | |
| ;; The cdr might hold a new paren-class info rather than | |
| ;; a matching-char info, in which case the two CDRs | |
| ;; should match. | |
| (eq matching-paren (cdr-safe (syntax-after start))))))))) | |
| (defvar blink-matching-check-function #'blink-matching-check-mismatch | |
| "Function to check parentheses mismatches. | |
| The function takes two arguments (START and END) where START is the | |
| position just before the opening token and END is the position right after. | |
| START can be nil, if it was not found. | |
| The function should return non-nil if the two tokens do not match.") | |
| (defvar blink-matching--overlay | |
| (let ((ol (make-overlay (point) (point) nil t))) | |
| (overlay-put ol 'face 'show-paren-match) | |
| (delete-overlay ol) | |
| ol) | |
| "Overlay used to highlight the matching paren.") | |
| (defun blink-matching-open () | |
| "Momentarily highlight the beginning of the sexp before point." | |
| (interactive) | |
| (when (and (not (bobp)) | |
| blink-matching-paren) | |
| (let* ((oldpos (point)) | |
| (message-log-max nil) ; Don't log messages about paren matching. | |
| (blinkpos | |
| (save-excursion | |
| (save-restriction | |
| (if blink-matching-paren-distance | |
| (narrow-to-region | |
| (max (minibuffer-prompt-end) ;(point-min) unless minibuf. | |
| (- (point) blink-matching-paren-distance)) | |
| oldpos)) | |
| (let ((parse-sexp-ignore-comments | |
| (and parse-sexp-ignore-comments | |
| (not blink-matching-paren-dont-ignore-comments)))) | |
| (condition-case () | |
| (progn | |
| (syntax-propertize (point)) | |
| (forward-sexp -1) | |
| ;; backward-sexp skips backward over prefix chars, | |
| ;; so move back to the matching paren. | |
| (while (and (< (point) (1- oldpos)) | |
| (let ((code (syntax-after (point)))) | |
| (or (eq (syntax-class code) 6) | |
| (eq (logand 1048576 (car code)) | |
| 1048576)))) | |
| (forward-char 1)) | |
| (point)) | |
| (error nil)))))) | |
| (mismatch (funcall blink-matching-check-function blinkpos oldpos))) | |
| (cond | |
| (mismatch | |
| (if blinkpos | |
| (if (minibufferp) | |
| (minibuffer-message "Mismatched parentheses") | |
| (message "Mismatched parentheses")) | |
| (if (minibufferp) | |
| (minibuffer-message "No matching parenthesis found") | |
| (message "No matching parenthesis found")))) | |
| ((not blinkpos) nil) | |
| ((or | |
| (eq blink-matching-paren 'jump-offscreen) | |
| (pos-visible-in-window-p blinkpos)) | |
| ;; Matching open within window, temporarily move to or highlight | |
| ;; char after blinkpos but only if `blink-matching-paren-on-screen' | |
| ;; is non-nil. | |
| (and blink-matching-paren-on-screen | |
| (not show-paren-mode) | |
| (if (memq blink-matching-paren '(jump jump-offscreen)) | |
| (save-excursion | |
| (goto-char blinkpos) | |
| (sit-for blink-matching-delay)) | |
| (unwind-protect | |
| (progn | |
| (move-overlay blink-matching--overlay blinkpos (1+ blinkpos) | |
| (current-buffer)) | |
| (sit-for blink-matching-delay)) | |
| (delete-overlay blink-matching--overlay))))) | |
| (t | |
| (let ((open-paren-line-string | |
| (save-excursion | |
| (goto-char blinkpos) | |
| ;; Show what precedes the open in its line, if anything. | |
| (cond | |
| ((save-excursion (skip-chars-backward " \t") (not (bolp))) | |
| (buffer-substring (line-beginning-position) | |
| (1+ blinkpos))) | |
| ;; Show what follows the open in its line, if anything. | |
| ((save-excursion | |
| (forward-char 1) | |
| (skip-chars-forward " \t") | |
| (not (eolp))) | |
| (buffer-substring blinkpos | |
| (line-end-position))) | |
| ;; Otherwise show the previous nonblank line, | |
| ;; if there is one. | |
| ((save-excursion (skip-chars-backward "\n \t") (not (bobp))) | |
| (concat | |
| (buffer-substring (progn | |
| (skip-chars-backward "\n \t") | |
| (line-beginning-position)) | |
| (progn (end-of-line) | |
| (skip-chars-backward " \t") | |
| (point))) | |
| ;; Replace the newline and other whitespace with `...'. | |
| "..." | |
| (buffer-substring blinkpos (1+ blinkpos)))) | |
| ;; There is nothing to show except the char itself. | |
| (t (buffer-substring blinkpos (1+ blinkpos))))))) | |
| (minibuffer-message | |
| "Matches %s" | |
| (substring-no-properties open-paren-line-string)))))))) | |
| (defvar blink-paren-function 'blink-matching-open | |
| "Function called, if non-nil, whenever a close parenthesis is inserted. | |
| More precisely, a char with closeparen syntax is self-inserted.") | |
| (defun blink-paren-post-self-insert-function () | |
| (when (and (eq (char-before) last-command-event) ; Sanity check. | |
| (memq (char-syntax last-command-event) '(?\) ?\$)) | |
| blink-paren-function | |
| (not executing-kbd-macro) | |
| (not noninteractive) | |
| ;; Verify an even number of quoting characters precede the close. | |
| ;; FIXME: Also check if this parenthesis closes a comment as | |
| ;; can happen in Pascal and SML. | |
| (= 1 (logand 1 (- (point) | |
| (save-excursion | |
| (forward-char -1) | |
| (skip-syntax-backward "/\\") | |
| (point)))))) | |
| (funcall blink-paren-function))) | |
| (put 'blink-paren-post-self-insert-function 'priority 100) | |
| (add-hook 'post-self-insert-hook #'blink-paren-post-self-insert-function | |
| ;; Most likely, this hook is nil, so this arg doesn't matter, | |
| ;; but I use it as a reminder that this function usually | |
| ;; likes to be run after others since it does | |
| ;; `sit-for'. That's also the reason it get a `priority' prop | |
| ;; of 100. | |
| 'append) | |
| ;; This executes C-g typed while Emacs is waiting for a command. | |
| ;; Quitting out of a program does not go through here; | |
| ;; that happens in the maybe_quit function at the C code level. | |
| (defun keyboard-quit () | |
| "Signal a `quit' condition. | |
| During execution of Lisp code, this character causes a quit directly. | |
| At top-level, as an editor command, this simply beeps." | |
| (interactive) | |
| ;; Avoid adding the region to the window selection. | |
| (setq saved-region-selection nil) | |
| (let (select-active-regions) | |
| (deactivate-mark)) | |
| (if (fboundp 'kmacro-keyboard-quit) | |
| (kmacro-keyboard-quit)) | |
| (when completion-in-region-mode | |
| (completion-in-region-mode -1)) | |
| ;; Force the next redisplay cycle to remove the "Def" indicator from | |
| ;; all the mode lines. | |
| (if defining-kbd-macro | |
| (force-mode-line-update t)) | |
| (setq defining-kbd-macro nil) | |
| (let ((debug-on-quit nil)) | |
| (signal 'quit nil))) | |
| (defvar buffer-quit-function nil | |
| "Function to call to \"quit\" the current buffer, or nil if none. | |
| \\[keyboard-escape-quit] calls this function when its more local actions | |
| \(such as canceling a prefix argument, minibuffer or region) do not apply.") | |
| (defun keyboard-escape-quit () | |
| "Exit the current \"mode\" (in a generalized sense of the word). | |
| This command can exit an interactive command such as `query-replace', | |
| can clear out a prefix argument or a region, | |
| can get out of the minibuffer or other recursive edit, | |
| cancel the use of the current buffer (for special-purpose buffers), | |
| or go back to just one window (by deleting all but the selected window)." | |
| (interactive) | |
| (cond ((eq last-command 'mode-exited) nil) | |
| ((region-active-p) | |
| (deactivate-mark)) | |
| ((> (minibuffer-depth) 0) | |
| (abort-recursive-edit)) | |
| (current-prefix-arg | |
| nil) | |
| ((> (recursion-depth) 0) | |
| (exit-recursive-edit)) | |
| (buffer-quit-function | |
| (funcall buffer-quit-function)) | |
| ((not (one-window-p t)) | |
| (delete-other-windows)) | |
| ((string-match "^ \\*" (buffer-name (current-buffer))) | |
| (bury-buffer)))) | |
| (defun play-sound-file (file &optional volume device) | |
| "Play sound stored in FILE. | |
| VOLUME and DEVICE correspond to the keywords of the sound | |
| specification for `play-sound'." | |
| (interactive "fPlay sound file: ") | |
| (let ((sound (list :file file))) | |
| (if volume | |
| (plist-put sound :volume volume)) | |
| (if device | |
| (plist-put sound :device device)) | |
| (push 'sound sound) | |
| (play-sound sound))) | |
| (defcustom read-mail-command 'rmail | |
| "Your preference for a mail reading package. | |
| This is used by some keybindings that support reading mail. | |
| See also `mail-user-agent' concerning sending mail." | |
| :type '(radio (function-item :tag "Rmail" :format "%t\n" rmail) | |
| (function-item :tag "Gnus" :format "%t\n" gnus) | |
| (function-item :tag "Emacs interface to MH" | |
| :format "%t\n" mh-rmail) | |
| (function :tag "Other")) | |
| :version "21.1" | |
| :group 'mail) | |
| (defcustom mail-user-agent 'message-user-agent | |
| "Your preference for a mail composition package. | |
| Various Emacs Lisp packages (e.g. Reporter) require you to compose an | |
| outgoing email message. This variable lets you specify which | |
| mail-sending package you prefer. | |
| Valid values include: | |
| `message-user-agent' -- use the Message package. | |
| See Info node `(message)'. | |
| `sendmail-user-agent' -- use the Mail package. | |
| See Info node `(emacs)Sending Mail'. | |
| `mh-e-user-agent' -- use the Emacs interface to the MH mail system. | |
| See Info node `(mh-e)'. | |
| `gnus-user-agent' -- like `message-user-agent', but with Gnus | |
| paraphernalia if Gnus is running, particularly | |
| the Gcc: header for archiving. | |
| Additional valid symbols may be available; check with the author of | |
| your package for details. The function should return non-nil if it | |
| succeeds. | |
| See also `read-mail-command' concerning reading mail." | |
| :type '(radio (function-item :tag "Message package" | |
| :format "%t\n" | |
| message-user-agent) | |
| (function-item :tag "Mail package" | |
| :format "%t\n" | |
| sendmail-user-agent) | |
| (function-item :tag "Emacs interface to MH" | |
| :format "%t\n" | |
| mh-e-user-agent) | |
| (function-item :tag "Message with full Gnus features" | |
| :format "%t\n" | |
| gnus-user-agent) | |
| (function :tag "Other")) | |
| :version "23.2" ; sendmail->message | |
| :group 'mail) | |
| (defcustom compose-mail-user-agent-warnings t | |
| "If non-nil, `compose-mail' warns about changes in `mail-user-agent'. | |
| If the value of `mail-user-agent' is the default, and the user | |
| appears to have customizations applying to the old default, | |
| `compose-mail' issues a warning." | |
| :type 'boolean | |
| :version "23.2" | |
| :group 'mail) | |
| (defun rfc822-goto-eoh () | |
| "If the buffer starts with a mail header, move point to the header's end. | |
| Otherwise, moves to `point-min'. | |
| The end of the header is the start of the next line, if there is one, | |
| else the end of the last line. This function obeys RFC 822 (or later)." | |
| (goto-char (point-min)) | |
| (when (re-search-forward | |
| "^\\([:\n]\\|[^: \t\n]+[ \t\n]\\)" nil 'move) | |
| (goto-char (match-beginning 0)))) | |
| ;; Used by Rmail (e.g., rmail-forward). | |
| (defvar mail-encode-mml nil | |
| "If non-nil, mail-user-agent's `sendfunc' command should mml-encode | |
| the outgoing message before sending it.") | |
| (defun compose-mail (&optional to subject other-headers continue | |
| switch-function yank-action send-actions | |
| return-action) | |
| "Start composing a mail message to send. | |
| This uses the user's chosen mail composition package | |
| as selected with the variable `mail-user-agent'. | |
| The optional arguments TO and SUBJECT specify recipients | |
| and the initial Subject field, respectively. | |
| OTHER-HEADERS is an alist specifying additional | |
| header fields. Elements look like (HEADER . VALUE) where both | |
| HEADER and VALUE are strings. | |
| CONTINUE, if non-nil, says to continue editing a message already | |
| being composed. Interactively, CONTINUE is the prefix argument. | |
| SWITCH-FUNCTION, if non-nil, is a function to use to | |
| switch to and display the buffer used for mail composition. | |
| YANK-ACTION, if non-nil, is an action to perform, if and when necessary, | |
| to insert the raw text of the message being replied to. | |
| It has the form (FUNCTION . ARGS). The user agent will apply | |
| FUNCTION to ARGS, to insert the raw text of the original message. | |
| \(The user agent will also run `mail-citation-hook', *after* the | |
| original text has been inserted in this way.) | |
| SEND-ACTIONS is a list of actions to call when the message is sent. | |
| Each action has the form (FUNCTION . ARGS). | |
| RETURN-ACTION, if non-nil, is an action for returning to the | |
| caller. It has the form (FUNCTION . ARGS). The function is | |
| called after the mail has been sent or put aside, and the mail | |
| buffer buried." | |
| (interactive | |
| (list nil nil nil current-prefix-arg)) | |
| ;; In Emacs 23.2, the default value of `mail-user-agent' changed | |
| ;; from sendmail-user-agent to message-user-agent. Some users may | |
| ;; encounter incompatibilities. This hack tries to detect problems | |
| ;; and warn about them. | |
| (and compose-mail-user-agent-warnings | |
| (eq mail-user-agent 'message-user-agent) | |
| (let (warn-vars) | |
| (dolist (var '(mail-mode-hook mail-send-hook mail-setup-hook | |
| mail-citation-hook mail-archive-file-name | |
| mail-default-reply-to mail-mailing-lists | |
| mail-self-blind)) | |
| (and (boundp var) | |
| (symbol-value var) | |
| (push var warn-vars))) | |
| (when warn-vars | |
| (display-warning 'mail | |
| (format-message "\ | |
| The default mail mode is now Message mode. | |
| You have the following Mail mode variable%s customized: | |
| \n %s\n\nTo use Mail mode, set `mail-user-agent' to sendmail-user-agent. | |
| To disable this warning, set `compose-mail-user-agent-warnings' to nil." | |
| (if (> (length warn-vars) 1) "s" "") | |
| (mapconcat 'symbol-name | |
| warn-vars " ")))))) | |
| (let ((function (get mail-user-agent 'composefunc))) | |
| (unless function | |
| (error "Invalid value for `mail-user-agent'")) | |
| (funcall function to subject other-headers continue switch-function | |
| yank-action send-actions return-action))) | |
| (defun compose-mail-other-window (&optional to subject other-headers continue | |
| yank-action send-actions | |
| return-action) | |
| "Like \\[compose-mail], but edit the outgoing message in another window." | |
| (interactive (list nil nil nil current-prefix-arg)) | |
| (compose-mail to subject other-headers continue | |
| 'switch-to-buffer-other-window yank-action send-actions | |
| return-action)) | |
| (defun compose-mail-other-frame (&optional to subject other-headers continue | |
| yank-action send-actions | |
| return-action) | |
| "Like \\[compose-mail], but edit the outgoing message in another frame." | |
| (interactive (list nil nil nil current-prefix-arg)) | |
| (compose-mail to subject other-headers continue | |
| 'switch-to-buffer-other-frame yank-action send-actions | |
| return-action)) | |
| (defvar set-variable-value-history nil | |
| "History of values entered with `set-variable'. | |
| Maximum length of the history list is determined by the value | |
| of `history-length', which see.") | |
| (defun set-variable (variable value &optional make-local) | |
| "Set VARIABLE to VALUE. VALUE is a Lisp object. | |
| VARIABLE should be a user option variable name, a Lisp variable | |
| meant to be customized by users. You should enter VALUE in Lisp syntax, | |
| so if you want VALUE to be a string, you must surround it with doublequotes. | |
| VALUE is used literally, not evaluated. | |
| If VARIABLE has a `variable-interactive' property, that is used as if | |
| it were the arg to `interactive' (which see) to interactively read VALUE. | |
| If VARIABLE has been defined with `defcustom', then the type information | |
| in the definition is used to check that VALUE is valid. | |
| Note that this function is at heart equivalent to the basic `set' function. | |
| For a variable defined with `defcustom', it does not pay attention to | |
| any :set property that the variable might have (if you want that, use | |
| \\[customize-set-variable] instead). | |
| With a prefix argument, set VARIABLE to VALUE buffer-locally. | |
| When called interactively, the user is prompted for VARIABLE and | |
| then VALUE. The current value of VARIABLE will be put in the | |
| minibuffer history so that it can be accessed with `M-n', which | |
| makes it easier to edit it." | |
| (interactive | |
| (let* ((default-var (variable-at-point)) | |
| (var (if (custom-variable-p default-var) | |
| (read-variable (format "Set variable (default %s): " default-var) | |
| default-var) | |
| (read-variable "Set variable: "))) | |
| (minibuffer-help-form `(describe-variable ',var)) | |
| (prop (get var 'variable-interactive)) | |
| (obsolete (car (get var 'byte-obsolete-variable))) | |
| (prompt (format "Set %s %s to value: " var | |
| (cond ((local-variable-p var) | |
| "(buffer-local)") | |
| ((or current-prefix-arg | |
| (local-variable-if-set-p var)) | |
| "buffer-locally") | |
| (t "globally")))) | |
| (val (progn | |
| (when obsolete | |
| (message (concat "`%S' is obsolete; " | |
| (if (symbolp obsolete) "use `%S' instead" "%s")) | |
| var obsolete) | |
| (sit-for 3)) | |
| (if prop | |
| ;; Use VAR's `variable-interactive' property | |
| ;; as an interactive spec for prompting. | |
| (call-interactively `(lambda (arg) | |
| (interactive ,prop) | |
| arg)) | |
| (read-from-minibuffer prompt nil | |
| read-expression-map t | |
| 'set-variable-value-history | |
| (format "%S" (symbol-value var))))))) | |
| (list var val current-prefix-arg))) | |
| (and (custom-variable-p variable) | |
| (not (get variable 'custom-type)) | |
| (custom-load-symbol variable)) | |
| (let ((type (get variable 'custom-type))) | |
| (when type | |
| ;; Match with custom type. | |
| (require 'cus-edit) | |
| (setq type (widget-convert type)) | |
| (unless (widget-apply type :match value) | |
| (user-error "Value `%S' does not match type %S of %S" | |
| value (car type) variable)))) | |
| (if make-local | |
| (make-local-variable variable)) | |
| (set variable value) | |
| ;; Force a thorough redisplay for the case that the variable | |
| ;; has an effect on the display, like `tab-width' has. | |
| (force-mode-line-update)) | |
| ;; Define the major mode for lists of completions. | |
| (defvar completion-list-mode-map | |
| (let ((map (make-sparse-keymap))) | |
| (define-key map [mouse-2] 'choose-completion) | |
| (define-key map [follow-link] 'mouse-face) | |
| (define-key map [down-mouse-2] nil) | |
| (define-key map "\C-m" 'choose-completion) | |
| (define-key map "\e\e\e" 'delete-completion-window) | |
| (define-key map [left] 'previous-completion) | |
| (define-key map [right] 'next-completion) | |
| (define-key map [?\t] 'next-completion) | |
| (define-key map [backtab] 'previous-completion) | |
| (define-key map "q" 'quit-window) | |
| (define-key map "z" 'kill-current-buffer) | |
| map) | |
| "Local map for completion list buffers.") | |
| ;; Completion mode is suitable only for specially formatted data. | |
| (put 'completion-list-mode 'mode-class 'special) | |
| (defvar completion-reference-buffer nil | |
| "Record the buffer that was current when the completion list was requested. | |
| This is a local variable in the completion list buffer. | |
| Initial value is nil to avoid some compiler warnings.") | |
| (defvar completion-no-auto-exit nil | |
| "Non-nil means `choose-completion-string' should never exit the minibuffer. | |
| This also applies to other functions such as `choose-completion'.") | |
| (defvar completion-base-position nil | |
| "Position of the base of the text corresponding to the shown completions. | |
| This variable is used in the *Completions* buffers. | |
| Its value is a list of the form (START END) where START is the place | |
| where the completion should be inserted and END (if non-nil) is the end | |
| of the text to replace. If END is nil, point is used instead.") | |
| (defvar completion-list-insert-choice-function #'completion--replace | |
| "Function to use to insert the text chosen in *Completions*. | |
| Called with three arguments (BEG END TEXT), it should replace the text | |
| between BEG and END with TEXT. Expected to be set buffer-locally | |
| in the *Completions* buffer.") | |
| (defvar completion-base-size nil | |
| "Number of chars before point not involved in completion. | |
| This is a local variable in the completion list buffer. | |
| It refers to the chars in the minibuffer if completing in the | |
| minibuffer, or in `completion-reference-buffer' otherwise. | |
| Only characters in the field at point are included. | |
| If nil, Emacs determines which part of the tail end of the | |
| buffer's text is involved in completion by comparing the text | |
| directly.") | |
| (make-obsolete-variable 'completion-base-size 'completion-base-position "23.2") | |
| (defun delete-completion-window () | |
| "Delete the completion list window. | |
| Go to the window from which completion was requested." | |
| (interactive) | |
| (let ((buf completion-reference-buffer)) | |
| (if (one-window-p t) | |
| (if (window-dedicated-p) (delete-frame)) | |
| (delete-window (selected-window)) | |
| (if (get-buffer-window buf) | |
| (select-window (get-buffer-window buf)))))) | |
| (defun previous-completion (n) | |
| "Move to the previous item in the completion list." | |
| (interactive "p") | |
| (next-completion (- n))) | |
| (defun next-completion (n) | |
| "Move to the next item in the completion list. | |
| With prefix argument N, move N items (negative N means move backward)." | |
| (interactive "p") | |
| (let ((beg (point-min)) (end (point-max))) | |
| (while (and (> n 0) (not (eobp))) | |
| ;; If in a completion, move to the end of it. | |
| (when (get-text-property (point) 'mouse-face) | |
| (goto-char (next-single-property-change (point) 'mouse-face nil end))) | |
| ;; Move to start of next one. | |
| (unless (get-text-property (point) 'mouse-face) | |
| (goto-char (next-single-property-change (point) 'mouse-face nil end))) | |
| (setq n (1- n))) | |
| (while (and (< n 0) (not (bobp))) | |
| (let ((prop (get-text-property (1- (point)) 'mouse-face))) | |
| ;; If in a completion, move to the start of it. | |
| (when (and prop (eq prop (get-text-property (point) 'mouse-face))) | |
| (goto-char (previous-single-property-change | |
| (point) 'mouse-face nil beg))) | |
| ;; Move to end of the previous completion. | |
| (unless (or (bobp) (get-text-property (1- (point)) 'mouse-face)) | |
| (goto-char (previous-single-property-change | |
| (point) 'mouse-face nil beg))) | |
| ;; Move to the start of that one. | |
| (goto-char (previous-single-property-change | |
| (point) 'mouse-face nil beg)) | |
| (setq n (1+ n)))))) | |
| (defun choose-completion (&optional event) | |
| "Choose the completion at point. | |
| If EVENT, use EVENT's position to determine the starting position." | |
| (interactive (list last-nonmenu-event)) | |
| ;; In case this is run via the mouse, give temporary modes such as | |
| ;; isearch a chance to turn off. | |
| (run-hooks 'mouse-leave-buffer-hook) | |
| (with-current-buffer (window-buffer (posn-window (event-start event))) | |
| (let ((buffer completion-reference-buffer) | |
| (base-size completion-base-size) | |
| (base-position completion-base-position) | |
| (insert-function completion-list-insert-choice-function) | |
| (choice | |
| (save-excursion | |
| (goto-char (posn-point (event-start event))) | |
| (let (beg end) | |
| (cond | |
| ((and (not (eobp)) (get-text-property (point) 'mouse-face)) | |
| (setq end (point) beg (1+ (point)))) | |
| ((and (not (bobp)) | |
| (get-text-property (1- (point)) 'mouse-face)) | |
| (setq end (1- (point)) beg (point))) | |
| (t (error "No completion here"))) | |
| (setq beg (previous-single-property-change beg 'mouse-face)) | |
| (setq end (or (next-single-property-change end 'mouse-face) | |
| (point-max))) | |
| (buffer-substring-no-properties beg end))))) | |
| (unless (buffer-live-p buffer) | |
| (error "Destination buffer is dead")) | |
| (quit-window nil (posn-window (event-start event))) | |
| (with-current-buffer buffer | |
| (choose-completion-string | |
| choice buffer | |
| (or base-position | |
| (when base-size | |
| ;; Someone's using old completion code that doesn't know | |
| ;; about base-position yet. | |
| (list (+ base-size (field-beginning)))) | |
| ;; If all else fails, just guess. | |
| (list (choose-completion-guess-base-position choice))) | |
| insert-function))))) | |
| ;; Delete the longest partial match for STRING | |
| ;; that can be found before POINT. | |
| (defun choose-completion-guess-base-position (string) | |
| (save-excursion | |
| (let ((opoint (point)) | |
| len) | |
| ;; Try moving back by the length of the string. | |
| (goto-char (max (- (point) (length string)) | |
| (minibuffer-prompt-end))) | |
| ;; See how far back we were actually able to move. That is the | |
| ;; upper bound on how much we can match and delete. | |
| (setq len (- opoint (point))) | |
| (if completion-ignore-case | |
| (setq string (downcase string))) | |
| (while (and (> len 0) | |
| (let ((tail (buffer-substring (point) opoint))) | |
| (if completion-ignore-case | |
| (setq tail (downcase tail))) | |
| (not (string= tail (substring string 0 len))))) | |
| (setq len (1- len)) | |
| (forward-char 1)) | |
| (point)))) | |
| (defun choose-completion-delete-max-match (string) | |
| (declare (obsolete choose-completion-guess-base-position "23.2")) | |
| (delete-region (choose-completion-guess-base-position string) (point))) | |
| (defvar choose-completion-string-functions nil | |
| "Functions that may override the normal insertion of a completion choice. | |
| These functions are called in order with three arguments: | |
| CHOICE - the string to insert in the buffer, | |
| BUFFER - the buffer in which the choice should be inserted, | |
| BASE-POSITION - where to insert the completion. | |
| Functions should also accept and ignore a potential fourth | |
| argument, passed for backwards compatibility. | |
| If a function in the list returns non-nil, that function is supposed | |
| to have inserted the CHOICE in the BUFFER, and possibly exited | |
| the minibuffer; no further functions will be called. | |
| If all functions in the list return nil, that means to use | |
| the default method of inserting the completion in BUFFER.") | |
| (defun choose-completion-string (choice &optional | |
| buffer base-position insert-function) | |
| "Switch to BUFFER and insert the completion choice CHOICE. | |
| BASE-POSITION says where to insert the completion. | |
| INSERT-FUNCTION says how to insert the completion and falls | |
| back on `completion-list-insert-choice-function' when nil." | |
| ;; If BUFFER is the minibuffer, exit the minibuffer | |
| ;; unless it is reading a file name and CHOICE is a directory, | |
| ;; or completion-no-auto-exit is non-nil. | |
| ;; Some older code may call us passing `base-size' instead of | |
| ;; `base-position'. It's difficult to make any use of `base-size', | |
| ;; so we just ignore it. | |
| (unless (consp base-position) | |
| (message "Obsolete `base-size' passed to choose-completion-string") | |
| (setq base-position nil)) | |
| (let* ((buffer (or buffer completion-reference-buffer)) | |
| (mini-p (minibufferp buffer))) | |
| ;; If BUFFER is a minibuffer, barf unless it's the currently | |
| ;; active minibuffer. | |
| (if (and mini-p | |
| (not (and (active-minibuffer-window) | |
| (equal buffer | |
| (window-buffer (active-minibuffer-window)))))) | |
| (error "Minibuffer is not active for completion") | |
| ;; Set buffer so buffer-local choose-completion-string-functions works. | |
| (set-buffer buffer) | |
| (unless (run-hook-with-args-until-success | |
| 'choose-completion-string-functions | |
| ;; The fourth arg used to be `mini-p' but was useless | |
| ;; (since minibufferp can be used on the `buffer' arg) | |
| ;; and indeed unused. The last used to be `base-size', so we | |
| ;; keep it to try and avoid breaking old code. | |
| choice buffer base-position nil) | |
| ;; This remove-text-properties should be unnecessary since `choice' | |
| ;; comes from buffer-substring-no-properties. | |
| ;;(remove-text-properties 0 (length choice) '(mouse-face nil) choice) | |
| ;; Insert the completion into the buffer where it was requested. | |
| (funcall (or insert-function completion-list-insert-choice-function) | |
| (or (car base-position) (point)) | |
| (or (cadr base-position) (point)) | |
| choice) | |
| ;; Update point in the window that BUFFER is showing in. | |
| (let ((window (get-buffer-window buffer t))) | |
| (set-window-point window (point))) | |
| ;; If completing for the minibuffer, exit it with this choice. | |
| (and (not completion-no-auto-exit) | |
| (minibufferp buffer) | |
| minibuffer-completion-table | |
| ;; If this is reading a file name, and the file name chosen | |
| ;; is a directory, don't exit the minibuffer. | |
| (let* ((result (buffer-substring (field-beginning) (point))) | |
| (bounds | |
| (completion-boundaries result minibuffer-completion-table | |
| minibuffer-completion-predicate | |
| ""))) | |
| (if (eq (car bounds) (length result)) | |
| ;; The completion chosen leads to a new set of completions | |
| ;; (e.g. it's a directory): don't exit the minibuffer yet. | |
| (let ((mini (active-minibuffer-window))) | |
| (select-window mini) | |
| (when minibuffer-auto-raise | |
| (raise-frame (window-frame mini)))) | |
| (exit-minibuffer)))))))) | |
| (define-derived-mode completion-list-mode nil "Completion List" | |
| "Major mode for buffers showing lists of possible completions. | |
| Type \\<completion-list-mode-map>\\[choose-completion] in the completion list\ | |
| to select the completion near point. | |
| Or click to select one with the mouse. | |
| \\{completion-list-mode-map}" | |
| (set (make-local-variable 'completion-base-size) nil)) | |
| (defun completion-list-mode-finish () | |
| "Finish setup of the completions buffer. | |
| Called from `temp-buffer-show-hook'." | |
| (when (eq major-mode 'completion-list-mode) | |
| (setq buffer-read-only t))) | |
| (add-hook 'temp-buffer-show-hook 'completion-list-mode-finish) | |
| ;; Variables and faces used in `completion-setup-function'. | |
| (defcustom completion-show-help t | |
| "Non-nil means show help message in *Completions* buffer." | |
| :type 'boolean | |
| :version "22.1" | |
| :group 'completion) | |
| ;; This function goes in completion-setup-hook, so that it is called | |
| ;; after the text of the completion list buffer is written. | |
| (defun completion-setup-function () | |
| (let* ((mainbuf (current-buffer)) | |
| (base-dir | |
| ;; FIXME: This is a bad hack. We try to set the default-directory | |
| ;; in the *Completions* buffer so that the relative file names | |
| ;; displayed there can be treated as valid file names, independently | |
| ;; from the completion context. But this suffers from many problems: | |
| ;; - It's not clear when the completions are file names. With some | |
| ;; completion tables (e.g. bzr revision specs), the listed | |
| ;; completions can mix file names and other things. | |
| ;; - It doesn't pay attention to possible quoting. | |
| ;; - With fancy completion styles, the code below will not always | |
| ;; find the right base directory. | |
| (if minibuffer-completing-file-name | |
| (file-name-as-directory | |
| (expand-file-name | |
| (buffer-substring (minibuffer-prompt-end) | |
| (- (point) (or completion-base-size 0)))))))) | |
| (with-current-buffer standard-output | |
| (let ((base-size completion-base-size) ;Read before killing localvars. | |
| (base-position completion-base-position) | |
| (insert-fun completion-list-insert-choice-function)) | |
| (completion-list-mode) | |
| (set (make-local-variable 'completion-base-size) base-size) | |
| (set (make-local-variable 'completion-base-position) base-position) | |
| (set (make-local-variable 'completion-list-insert-choice-function) | |
| insert-fun)) | |
| (set (make-local-variable 'completion-reference-buffer) mainbuf) | |
| (if base-dir (setq default-directory base-dir)) | |
| ;; Maybe insert help string. | |
| (when completion-show-help | |
| (goto-char (point-min)) | |
| (if (display-mouse-p) | |
| (insert "Click on a completion to select it.\n")) | |
| (insert (substitute-command-keys | |
| "In this buffer, type \\[choose-completion] to \ | |
| select the completion near point.\n\n")))))) | |
| (add-hook 'completion-setup-hook #'completion-setup-function) | |
| (defun switch-to-completions () | |
| "Select the completion list window." | |
| (interactive) | |
| (let ((window (or (get-buffer-window "*Completions*" 0) | |
| ;; Make sure we have a completions window. | |
| (progn (minibuffer-completion-help) | |
| (get-buffer-window "*Completions*" 0))))) | |
| (when window | |
| (select-window window) | |
| ;; In the new buffer, go to the first completion. | |
| ;; FIXME: Perhaps this should be done in `minibuffer-completion-help'. | |
| (when (bobp) | |
| (next-completion 1))))) | |
| ;;; Support keyboard commands to turn on various modifiers. | |
| ;; These functions -- which are not commands -- each add one modifier | |
| ;; to the following event. | |
| (defun event-apply-alt-modifier (_ignore-prompt) | |
| "\\<function-key-map>Add the Alt modifier to the following event. | |
| For example, type \\[event-apply-alt-modifier] & to enter Alt-&." | |
| (vector (event-apply-modifier (read-event) 'alt 22 "A-"))) | |
| (defun event-apply-super-modifier (_ignore-prompt) | |
| "\\<function-key-map>Add the Super modifier to the following event. | |
| For example, type \\[event-apply-super-modifier] & to enter Super-&." | |
| (vector (event-apply-modifier (read-event) 'super 23 "s-"))) | |
| (defun event-apply-hyper-modifier (_ignore-prompt) | |
| "\\<function-key-map>Add the Hyper modifier to the following event. | |
| For example, type \\[event-apply-hyper-modifier] & to enter Hyper-&." | |
| (vector (event-apply-modifier (read-event) 'hyper 24 "H-"))) | |
| (defun event-apply-shift-modifier (_ignore-prompt) | |
| "\\<function-key-map>Add the Shift modifier to the following event. | |
| For example, type \\[event-apply-shift-modifier] & to enter Shift-&." | |
| (vector (event-apply-modifier (read-event) 'shift 25 "S-"))) | |
| (defun event-apply-control-modifier (_ignore-prompt) | |
| "\\<function-key-map>Add the Ctrl modifier to the following event. | |
| For example, type \\[event-apply-control-modifier] & to enter Ctrl-&." | |
| (vector (event-apply-modifier (read-event) 'control 26 "C-"))) | |
| (defun event-apply-meta-modifier (_ignore-prompt) | |
| "\\<function-key-map>Add the Meta modifier to the following event. | |
| For example, type \\[event-apply-meta-modifier] & to enter Meta-&." | |
| (vector (event-apply-modifier (read-event) 'meta 27 "M-"))) | |
| (defun event-apply-modifier (event symbol lshiftby prefix) | |
| "Apply a modifier flag to event EVENT. | |
| SYMBOL is the name of this modifier, as a symbol. | |
| LSHIFTBY is the numeric value of this modifier, in keyboard events. | |
| PREFIX is the string that represents this modifier in an event type symbol." | |
| (if (numberp event) | |
| (cond ((eq symbol 'control) | |
| (if (<= 64 (upcase event) 95) | |
| (- (upcase event) 64) | |
| (logior (ash 1 lshiftby) event))) | |
| ((eq symbol 'shift) | |
| ;; FIXME: Should we also apply this "upcase" behavior of shift | |
| ;; to non-ascii letters? | |
| (if (and (<= (downcase event) ?z) | |
| (>= (downcase event) ?a)) | |
| (upcase event) | |
| (logior (ash 1 lshiftby) event))) | |
| (t | |
| (logior (ash 1 lshiftby) event))) | |
| (if (memq symbol (event-modifiers event)) | |
| event | |
| (let ((event-type (if (symbolp event) event (car event)))) | |
| (setq event-type (intern (concat prefix (symbol-name event-type)))) | |
| (if (symbolp event) | |
| event-type | |
| (cons event-type (cdr event))))))) | |
| (define-key function-key-map [?\C-x ?@ ?h] 'event-apply-hyper-modifier) | |
| (define-key function-key-map [?\C-x ?@ ?s] 'event-apply-super-modifier) | |
| (define-key function-key-map [?\C-x ?@ ?m] 'event-apply-meta-modifier) | |
| (define-key function-key-map [?\C-x ?@ ?a] 'event-apply-alt-modifier) | |
| (define-key function-key-map [?\C-x ?@ ?S] 'event-apply-shift-modifier) | |
| (define-key function-key-map [?\C-x ?@ ?c] 'event-apply-control-modifier) | |
| ;;;; Keypad support. | |
| ;; Make the keypad keys act like ordinary typing keys. If people add | |
| ;; bindings for the function key symbols, then those bindings will | |
| ;; override these, so this shouldn't interfere with any existing | |
| ;; bindings. | |
| ;; Also tell read-char how to handle these keys. | |
| (mapc | |
| (lambda (keypad-normal) | |
| (let ((keypad (nth 0 keypad-normal)) | |
| (normal (nth 1 keypad-normal))) | |
| (put keypad 'ascii-character normal) | |
| (define-key function-key-map (vector keypad) (vector normal)))) | |
| ;; See also kp-keys bound in bindings.el. | |
| '((kp-space ?\s) | |
| (kp-tab ?\t) | |
| (kp-enter ?\r) | |
| (kp-separator ?,) | |
| (kp-equal ?=) | |
| ;; Do the same for various keys that are represented as symbols under | |
| ;; GUIs but naturally correspond to characters. | |
| (backspace 127) | |
| (delete 127) | |
| (tab ?\t) | |
| (linefeed ?\n) | |
| (clear ?\C-l) | |
| (return ?\C-m) | |
| (escape ?\e) | |
| )) | |
| ;;;; | |
| ;;;; forking a twin copy of a buffer. | |
| ;;;; | |
| (defvar clone-buffer-hook nil | |
| "Normal hook to run in the new buffer at the end of `clone-buffer'.") | |
| (defvar clone-indirect-buffer-hook nil | |
| "Normal hook to run in the new buffer at the end of `clone-indirect-buffer'.") | |
| (defun clone-process (process &optional newname) | |
| "Create a twin copy of PROCESS. | |
| If NEWNAME is nil, it defaults to PROCESS' name; | |
| NEWNAME is modified by adding or incrementing <N> at the end as necessary. | |
| If PROCESS is associated with a buffer, the new process will be associated | |
| with the current buffer instead. | |
| Returns nil if PROCESS has already terminated." | |
| (setq newname (or newname (process-name process))) | |
| (if (string-match "<[0-9]+>\\'" newname) | |
| (setq newname (substring newname 0 (match-beginning 0)))) | |
| (when (memq (process-status process) '(run stop open)) | |
| (let* ((process-connection-type (process-tty-name process)) | |
| (new-process | |
| (if (memq (process-status process) '(open)) | |
| (let ((args (process-contact process t))) | |
| (setq args (plist-put args :name newname)) | |
| (setq args (plist-put args :buffer | |
| (if (process-buffer process) | |
| (current-buffer)))) | |
| (apply 'make-network-process args)) | |
| (apply 'start-process newname | |
| (if (process-buffer process) (current-buffer)) | |
| (process-command process))))) | |
| (set-process-query-on-exit-flag | |
| new-process (process-query-on-exit-flag process)) | |
| (set-process-inherit-coding-system-flag | |
| new-process (process-inherit-coding-system-flag process)) | |
| (set-process-filter new-process (process-filter process)) | |
| (set-process-sentinel new-process (process-sentinel process)) | |
| (set-process-plist new-process (copy-sequence (process-plist process))) | |
| new-process))) | |
| ;; things to maybe add (currently partly covered by `funcall mode'): | |
| ;; - syntax-table | |
| ;; - overlays | |
| (defun clone-buffer (&optional newname display-flag) | |
| "Create and return a twin copy of the current buffer. | |
| Unlike an indirect buffer, the new buffer can be edited | |
| independently of the old one (if it is not read-only). | |
| NEWNAME is the name of the new buffer. It may be modified by | |
| adding or incrementing <N> at the end as necessary to create a | |
| unique buffer name. If nil, it defaults to the name of the | |
| current buffer, with the proper suffix. If DISPLAY-FLAG is | |
| non-nil, the new buffer is shown with `pop-to-buffer'. Trying to | |
| clone a file-visiting buffer, or a buffer whose major mode symbol | |
| has a non-nil `no-clone' property, results in an error. | |
| Interactively, DISPLAY-FLAG is t and NEWNAME is the name of the | |
| current buffer with appropriate suffix. However, if a prefix | |
| argument is given, then the command prompts for NEWNAME in the | |
| minibuffer. | |
| This runs the normal hook `clone-buffer-hook' in the new buffer | |
| after it has been set up properly in other respects." | |
| (interactive | |
| (progn | |
| (if buffer-file-name | |
| (error "Cannot clone a file-visiting buffer")) | |
| (if (get major-mode 'no-clone) | |
| (error "Cannot clone a buffer in %s mode" mode-name)) | |
| (list (if current-prefix-arg | |
| (read-buffer "Name of new cloned buffer: " (current-buffer))) | |
| t))) | |
| (if buffer-file-name | |
| (error "Cannot clone a file-visiting buffer")) | |
| (if (get major-mode 'no-clone) | |
| (error "Cannot clone a buffer in %s mode" mode-name)) | |
| (setq newname (or newname (buffer-name))) | |
| (if (string-match "<[0-9]+>\\'" newname) | |
| (setq newname (substring newname 0 (match-beginning 0)))) | |
| (let ((buf (current-buffer)) | |
| (ptmin (point-min)) | |
| (ptmax (point-max)) | |
| (pt (point)) | |
| (mk (if mark-active (mark t))) | |
| (modified (buffer-modified-p)) | |
| (mode major-mode) | |
| (lvars (buffer-local-variables)) | |
| (process (get-buffer-process (current-buffer))) | |
| (new (generate-new-buffer (or newname (buffer-name))))) | |
| (save-restriction | |
| (widen) | |
| (with-current-buffer new | |
| (insert-buffer-substring buf))) | |
| (with-current-buffer new | |
| (narrow-to-region ptmin ptmax) | |
| (goto-char pt) | |
| (if mk (set-mark mk)) | |
| (set-buffer-modified-p modified) | |
| ;; Clone the old buffer's process, if any. | |
| (when process (clone-process process)) | |
| ;; Now set up the major mode. | |
| (funcall mode) | |
| ;; Set up other local variables. | |
| (mapc (lambda (v) | |
| (condition-case () | |
| (if (symbolp v) | |
| (makunbound (make-local-variable v)) | |
| (set (make-local-variable (car v)) (cdr v))) | |
| (setting-constant nil))) ;E.g. for enable-multibyte-characters. | |
| lvars) | |
| (setq mark-ring (mapcar (lambda (mk) (copy-marker (marker-position mk))) | |
| mark-ring)) | |
| ;; Run any hooks (typically set up by the major mode | |
| ;; for cloning to work properly). | |
| (run-hooks 'clone-buffer-hook)) | |
| (if display-flag | |
| ;; Presumably the current buffer is shown in the selected frame, so | |
| ;; we want to display the clone elsewhere. | |
| (let ((same-window-regexps nil) | |
| (same-window-buffer-names)) | |
| (pop-to-buffer new))) | |
| new)) | |
| (defun clone-indirect-buffer (newname display-flag &optional norecord) | |
| "Create an indirect buffer that is a twin copy of the current buffer. | |
| Give the indirect buffer name NEWNAME. Interactively, read NEWNAME | |
| from the minibuffer when invoked with a prefix arg. If NEWNAME is nil | |
| or if not called with a prefix arg, NEWNAME defaults to the current | |
| buffer's name. The name is modified by adding a `<N>' suffix to it | |
| or by incrementing the N in an existing suffix. Trying to clone a | |
| buffer whose major mode symbol has a non-nil `no-clone-indirect' | |
| property results in an error. | |
| DISPLAY-FLAG non-nil means show the new buffer with `pop-to-buffer'. | |
| This is always done when called interactively. | |
| Optional third arg NORECORD non-nil means do not put this buffer at the | |
| front of the list of recently selected ones. | |
| Returns the newly created indirect buffer." | |
| (interactive | |
| (progn | |
| (if (get major-mode 'no-clone-indirect) | |
| (error "Cannot indirectly clone a buffer in %s mode" mode-name)) | |
| (list (if current-prefix-arg | |
| (read-buffer "Name of indirect buffer: " (current-buffer))) | |
| t))) | |
| (if (get major-mode 'no-clone-indirect) | |
| (error "Cannot indirectly clone a buffer in %s mode" mode-name)) | |
| (setq newname (or newname (buffer-name))) | |
| (if (string-match "<[0-9]+>\\'" newname) | |
| (setq newname (substring newname 0 (match-beginning 0)))) | |
| (let* ((name (generate-new-buffer-name newname)) | |
| (buffer (make-indirect-buffer (current-buffer) name t))) | |
| (with-current-buffer buffer | |
| (run-hooks 'clone-indirect-buffer-hook)) | |
| (when display-flag | |
| (pop-to-buffer buffer nil norecord)) | |
| buffer)) | |
| (defun clone-indirect-buffer-other-window (newname display-flag &optional norecord) | |
| "Like `clone-indirect-buffer' but display in another window." | |
| (interactive | |
| (progn | |
| (if (get major-mode 'no-clone-indirect) | |
| (error "Cannot indirectly clone a buffer in %s mode" mode-name)) | |
| (list (if current-prefix-arg | |
| (read-buffer "Name of indirect buffer: " (current-buffer))) | |
| t))) | |
| (let ((pop-up-windows t)) | |
| (clone-indirect-buffer newname display-flag norecord))) | |
| ;;; Handling of Backspace and Delete keys. | |
| (defcustom normal-erase-is-backspace 'maybe | |
| "Set the default behavior of the Delete and Backspace keys. | |
| If set to t, Delete key deletes forward and Backspace key deletes | |
| backward. | |
| If set to nil, both Delete and Backspace keys delete backward. | |
| If set to `maybe' (which is the default), Emacs automatically | |
| selects a behavior. On window systems, the behavior depends on | |
| the keyboard used. If the keyboard has both a Backspace key and | |
| a Delete key, and both are mapped to their usual meanings, the | |
| option's default value is set to t, so that Backspace can be used | |
| to delete backward, and Delete can be used to delete forward. | |
| If not running under a window system, customizing this option | |
| accomplishes a similar effect by mapping C-h, which is usually | |
| generated by the Backspace key, to DEL, and by mapping DEL to C-d | |
| via `keyboard-translate'. The former functionality of C-h is | |
| available on the F1 key. You should probably not use this | |
| setting if you don't have both Backspace, Delete and F1 keys. | |
| Setting this variable with setq doesn't take effect. Programmatically, | |
| call `normal-erase-is-backspace-mode' (which see) instead." | |
| :type '(choice (const :tag "Off" nil) | |
| (const :tag "Maybe" maybe) | |
| (other :tag "On" t)) | |
| :group 'editing-basics | |
| :version "21.1" | |
| :set (lambda (symbol value) | |
| ;; The fboundp is because of a problem with :set when | |
| ;; dumping Emacs. It doesn't really matter. | |
| (if (fboundp 'normal-erase-is-backspace-mode) | |
| (normal-erase-is-backspace-mode (or value 0)) | |
| (set-default symbol value)))) | |
| (defun normal-erase-is-backspace-setup-frame (&optional frame) | |
| "Set up `normal-erase-is-backspace-mode' on FRAME, if necessary." | |
| (unless frame (setq frame (selected-frame))) | |
| (with-selected-frame frame | |
| (unless (terminal-parameter nil 'normal-erase-is-backspace) | |
| (normal-erase-is-backspace-mode | |
| (if (if (eq normal-erase-is-backspace 'maybe) | |
| (and (not noninteractive) | |
| (or (memq system-type '(ms-dos windows-nt)) | |
| (memq window-system '(w32 ns)) | |
| (and (eq window-system 'x) | |
| (fboundp 'x-backspace-delete-keys-p) | |
| (x-backspace-delete-keys-p)) | |
| ;; If the terminal Emacs is running on has erase char | |
| ;; set to ^H, use the Backspace key for deleting | |
| ;; backward, and the Delete key for deleting forward. | |
| (and (null window-system) | |
| (eq tty-erase-char ?\^H)))) | |
| normal-erase-is-backspace) | |
| 1 0))))) | |
| (declare-function display-symbol-keys-p "frame" (&optional display)) | |
| (define-minor-mode normal-erase-is-backspace-mode | |
| "Toggle the Erase and Delete mode of the Backspace and Delete keys. | |
| On window systems, when this mode is on, Delete is mapped to C-d | |
| and Backspace is mapped to DEL; when this mode is off, both | |
| Delete and Backspace are mapped to DEL. (The remapping goes via | |
| `local-function-key-map', so binding Delete or Backspace in the | |
| global or local keymap will override that.) | |
| In addition, on window systems, the bindings of C-Delete, M-Delete, | |
| C-M-Delete, C-Backspace, M-Backspace, and C-M-Backspace are changed in | |
| the global keymap in accordance with the functionality of Delete and | |
| Backspace. For example, if Delete is remapped to C-d, which deletes | |
| forward, C-Delete is bound to `kill-word', but if Delete is remapped | |
| to DEL, which deletes backward, C-Delete is bound to | |
| `backward-kill-word'. | |
| If not running on a window system, a similar effect is accomplished by | |
| remapping C-h (normally produced by the Backspace key) and DEL via | |
| `keyboard-translate': if this mode is on, C-h is mapped to DEL and DEL | |
| to C-d; if it's off, the keys are not remapped. | |
| When not running on a window system, and this mode is turned on, the | |
| former functionality of C-h is available on the F1 key. You should | |
| probably not turn on this mode on a text-only terminal if you don't | |
| have both Backspace, Delete and F1 keys. | |
| See also `normal-erase-is-backspace'." | |
| :variable ((eq (terminal-parameter nil 'normal-erase-is-backspace) 1) | |
| . (lambda (v) | |
| (setf (terminal-parameter nil 'normal-erase-is-backspace) | |
| (if v 1 0)))) | |
| (let ((enabled (eq 1 (terminal-parameter | |
| nil 'normal-erase-is-backspace)))) | |
| (cond ((display-symbol-keys-p) | |
| (let ((bindings | |
| '(([M-delete] [M-backspace]) | |
| ([C-M-delete] [C-M-backspace]) | |
| ([?\e C-delete] [?\e C-backspace])))) | |
| (if enabled | |
| (progn | |
| (define-key local-function-key-map [delete] [deletechar]) | |
| (define-key local-function-key-map [kp-delete] [deletechar]) | |
| (define-key local-function-key-map [backspace] [?\C-?]) | |
| (dolist (b bindings) | |
| ;; Not sure if input-decode-map is really right, but | |
| ;; keyboard-translate-table (used below) works only | |
| ;; for integer events, and key-translation-table is | |
| ;; global (like the global-map, used earlier). | |
| (define-key input-decode-map (car b) nil) | |
| (define-key input-decode-map (cadr b) nil))) | |
| (define-key local-function-key-map [delete] [?\C-?]) | |
| (define-key local-function-key-map [kp-delete] [?\C-?]) | |
| (define-key local-function-key-map [backspace] [?\C-?]) | |
| (dolist (b bindings) | |
| (define-key input-decode-map (car b) (cadr b)) | |
| (define-key input-decode-map (cadr b) (car b)))))) | |
| (t | |
| (if enabled | |
| (progn | |
| (keyboard-translate ?\C-h ?\C-?) | |
| (keyboard-translate ?\C-? ?\C-d)) | |
| (keyboard-translate ?\C-h ?\C-h) | |
| (keyboard-translate ?\C-? ?\C-?)))) | |
| (if (called-interactively-p 'interactive) | |
| (message "Delete key deletes %s" | |
| (if (eq 1 (terminal-parameter nil 'normal-erase-is-backspace)) | |
| "forward" "backward"))))) | |
| (defvar vis-mode-saved-buffer-invisibility-spec nil | |
| "Saved value of `buffer-invisibility-spec' when Visible mode is on.") | |
| (define-minor-mode read-only-mode | |
| "Change whether the current buffer is read-only. | |
| If buffer is read-only and `view-read-only' is non-nil, enter | |
| view mode. | |
| Do not call this from a Lisp program unless you really intend to | |
| do the same thing as the \\[read-only-mode] command, including | |
| possibly enabling or disabling View mode. Also, note that this | |
| command works by setting the variable `buffer-read-only', which | |
| does not affect read-only regions caused by text properties. To | |
| ignore read-only status in a Lisp program (whether due to text | |
| properties or buffer state), bind `inhibit-read-only' temporarily | |
| to a non-nil value." | |
| :variable buffer-read-only | |
| (cond | |
| ((and (not buffer-read-only) view-mode) | |
| (View-exit-and-edit) | |
| (make-local-variable 'view-read-only) | |
| (setq view-read-only t)) ; Must leave view mode. | |
| ((and buffer-read-only view-read-only | |
| ;; If view-mode is already active, `view-mode-enter' is a nop. | |
| (not view-mode) | |
| (not (eq (get major-mode 'mode-class) 'special))) | |
| (view-mode-enter)))) | |
| (define-minor-mode visible-mode | |
| "Toggle making all invisible text temporarily visible (Visible mode). | |
| This mode works by saving the value of `buffer-invisibility-spec' | |
| and setting it to nil." | |
| :lighter " Vis" | |
| :group 'editing-basics | |
| (when (local-variable-p 'vis-mode-saved-buffer-invisibility-spec) | |
| (setq buffer-invisibility-spec vis-mode-saved-buffer-invisibility-spec) | |
| (kill-local-variable 'vis-mode-saved-buffer-invisibility-spec)) | |
| (when visible-mode | |
| (set (make-local-variable 'vis-mode-saved-buffer-invisibility-spec) | |
| buffer-invisibility-spec) | |
| (setq buffer-invisibility-spec nil))) | |
| (defvar messages-buffer-mode-map | |
| (let ((map (make-sparse-keymap))) | |
| (set-keymap-parent map special-mode-map) | |
| (define-key map "g" nil) ; nothing to revert | |
| map)) | |
| (define-derived-mode messages-buffer-mode special-mode "Messages" | |
| "Major mode used in the \"*Messages*\" buffer.") | |
| (defun messages-buffer () | |
| "Return the \"*Messages*\" buffer. | |
| If it does not exist, create it and switch it to `messages-buffer-mode'." | |
| (or (get-buffer "*Messages*") | |
| (with-current-buffer (get-buffer-create "*Messages*") | |
| (messages-buffer-mode) | |
| (current-buffer)))) | |
| ;; Minibuffer prompt stuff. | |
| ;;(defun minibuffer-prompt-modification (start end) | |
| ;; (error "You cannot modify the prompt")) | |
| ;; | |
| ;; | |
| ;;(defun minibuffer-prompt-insertion (start end) | |
| ;; (let ((inhibit-modification-hooks t)) | |
| ;; (delete-region start end) | |
| ;; ;; Discard undo information for the text insertion itself | |
| ;; ;; and for the text deletion.above. | |
| ;; (when (consp buffer-undo-list) | |
| ;; (setq buffer-undo-list (cddr buffer-undo-list))) | |
| ;; (message "You cannot modify the prompt"))) | |
| ;; | |
| ;; | |
| ;;(setq minibuffer-prompt-properties | |
| ;; (list 'modification-hooks '(minibuffer-prompt-modification) | |
| ;; 'insert-in-front-hooks '(minibuffer-prompt-insertion))) | |
| ;;;; Problematic external packages. | |
| ;; rms says this should be done by specifying symbols that define | |
| ;; versions together with bad values. This is therefore not as | |
| ;; flexible as it could be. See the thread: | |
| ;; https://lists.gnu.org/r/emacs-devel/2007-08/msg00300.html | |
| (defconst bad-packages-alist | |
| ;; Not sure exactly which semantic versions have problems. | |
| ;; Definitely 2.0pre3, probably all 2.0pre's before this. | |
| '((semantic semantic-version "\\`2\\.0pre[1-3]\\'" | |
| "The version of `semantic' loaded does not work in Emacs 22. | |
| It can cause constant high CPU load. | |
| Upgrade to at least Semantic 2.0pre4 (distributed with CEDET 1.0pre4).") | |
| ;; CUA-mode does not work with GNU Emacs version 22.1 and newer. | |
| ;; Except for version 1.2, all of the 1.x and 2.x version of cua-mode | |
| ;; provided the `CUA-mode' feature. Since this is no longer true, | |
| ;; we can warn the user if the `CUA-mode' feature is ever provided. | |
| (CUA-mode t nil | |
| "CUA-mode is now part of the standard GNU Emacs distribution, | |
| so you can now enable CUA via the Options menu or by customizing `cua-mode'. | |
| You have loaded an older version of CUA-mode which does not work | |
| correctly with this version of Emacs. You should remove the old | |
| version and use the one distributed with Emacs.")) | |
| "Alist of packages known to cause problems in this version of Emacs. | |
| Each element has the form (PACKAGE SYMBOL REGEXP STRING). | |
| PACKAGE is either a regular expression to match file names, or a | |
| symbol (a feature name), like for `with-eval-after-load'. | |
| SYMBOL is either the name of a string variable, or t. Upon | |
| loading PACKAGE, if SYMBOL is t or matches REGEXP, display a | |
| warning using STRING as the message.") | |
| (defun bad-package-check (package) | |
| "Run a check using the element from `bad-packages-alist' matching PACKAGE." | |
| (condition-case nil | |
| (let* ((list (assoc package bad-packages-alist)) | |
| (symbol (nth 1 list))) | |
| (and list | |
| (boundp symbol) | |
| (or (eq symbol t) | |
| (and (stringp (setq symbol (eval symbol))) | |
| (string-match-p (nth 2 list) symbol))) | |
| (display-warning package (nth 3 list) :warning))) | |
| (error nil))) | |
| (dolist (elem bad-packages-alist) | |
| (let ((pkg (car elem))) | |
| (with-eval-after-load pkg | |
| (bad-package-check pkg)))) | |
| ;;; Generic dispatcher commands | |
| ;; Macro `define-alternatives' is used to create generic commands. | |
| ;; Generic commands are these (like web, mail, news, encrypt, irc, etc.) | |
| ;; that can have different alternative implementations where choosing | |
| ;; among them is exclusively a matter of user preference. | |
| ;; (define-alternatives COMMAND) creates a new interactive command | |
| ;; M-x COMMAND and a customizable variable COMMAND-alternatives. | |
| ;; Typically, the user will not need to customize this variable; packages | |
| ;; wanting to add alternative implementations should use | |
| ;; | |
| ;; ;;;###autoload (push '("My impl name" . my-impl-symbol) COMMAND-alternatives | |
| (defmacro define-alternatives (command &rest customizations) | |
| "Define the new command `COMMAND'. | |
| The argument `COMMAND' should be a symbol. | |
| Running `M-x COMMAND RET' for the first time prompts for which | |
| alternative to use and records the selected command as a custom | |
| variable. | |
| Running `C-u M-x COMMAND RET' prompts again for an alternative | |
| and overwrites the previous choice. | |
| The variable `COMMAND-alternatives' contains an alist with | |
| alternative implementations of COMMAND. `define-alternatives' | |
| does not have any effect until this variable is set. | |
| CUSTOMIZATIONS, if non-nil, should be composed of alternating | |
| `defcustom' keywords and values to add to the declaration of | |
| `COMMAND-alternatives' (typically :group and :version)." | |
| (let* ((command-name (symbol-name command)) | |
| (varalt-name (concat command-name "-alternatives")) | |
| (varalt-sym (intern varalt-name)) | |
| (varimp-sym (intern (concat command-name "--implementation")))) | |
| `(progn | |
| (defcustom ,varalt-sym nil | |
| ,(format "Alist of alternative implementations for the `%s' command. | |
| Each entry must be a pair (ALTNAME . ALTFUN), where: | |
| ALTNAME - The name shown at user to describe the alternative implementation. | |
| ALTFUN - The function called to implement this alternative." | |
| command-name) | |
| :type '(alist :key-type string :value-type function) | |
| ,@customizations) | |
| (put ',varalt-sym 'definition-name ',command) | |
| (defvar ,varimp-sym nil "Internal use only.") | |
| (defun ,command (&optional arg) | |
| ,(format "Run generic command `%s'. | |
| If used for the first time, or with interactive ARG, ask the user which | |
| implementation to use for `%s'. The variable `%s' | |
| contains the list of implementations currently supported for this command." | |
| command-name command-name varalt-name) | |
| (interactive "P") | |
| (when (or arg (null ,varimp-sym)) | |
| (let ((val (completing-read | |
| ,(format-message | |
| "Select implementation for command `%s': " | |
| command-name) | |
| ,varalt-sym nil t))) | |
| (unless (string-equal val "") | |
| (when (null ,varimp-sym) | |
| (message | |
| "Use `C-u M-x %s RET' to select another implementation" | |
| ,command-name) | |
| (sit-for 3)) | |
| (customize-save-variable ',varimp-sym | |
| (cdr (assoc-string val ,varalt-sym)))))) | |
| (if ,varimp-sym | |
| (call-interactively ,varimp-sym) | |
| (message "%s" ,(format-message | |
| "No implementation selected for command `%s'" | |
| command-name))))))) | |
| ;;; Functions for changing capitalization that Do What I Mean | |
| (defun upcase-dwim (arg) | |
| "Upcase words in the region, if active; if not, upcase word at point. | |
| If the region is active, this function calls `upcase-region'. | |
| Otherwise, it calls `upcase-word', with prefix argument passed to it | |
| to upcase ARG words." | |
| (interactive "*p") | |
| (if (use-region-p) | |
| (upcase-region (region-beginning) (region-end) (region-noncontiguous-p)) | |
| (upcase-word arg))) | |
| (defun downcase-dwim (arg) | |
| "Downcase words in the region, if active; if not, downcase word at point. | |
| If the region is active, this function calls `downcase-region'. | |
| Otherwise, it calls `downcase-word', with prefix argument passed to it | |
| to downcase ARG words." | |
| (interactive "*p") | |
| (if (use-region-p) | |
| (downcase-region (region-beginning) (region-end) (region-noncontiguous-p)) | |
| (downcase-word arg))) | |
| (defun capitalize-dwim (arg) | |
| "Capitalize words in the region, if active; if not, capitalize word at point. | |
| If the region is active, this function calls `capitalize-region'. | |
| Otherwise, it calls `capitalize-word', with prefix argument passed to it | |
| to capitalize ARG words." | |
| (interactive "*p") | |
| (if (use-region-p) | |
| (capitalize-region (region-beginning) (region-end) (region-noncontiguous-p)) | |
| (capitalize-word arg))) | |
| ;;; Accessors for `decode-time' values. | |
| (cl-defstruct (decoded-time | |
| (:constructor nil) | |
| (:copier nil) | |
| (:type list)) | |
| (second nil :documentation "\ | |
| This is an integer or a Lisp timestamp (TICKS . HZ) representing a nonnegative | |
| number of seconds less than 61. (If not less than 60, it is a leap second, | |
| which only some operating systems support.)") | |
| (minute nil :documentation "This is an integer between 0 and 59 (inclusive).") | |
| (hour nil :documentation "This is an integer between 0 and 23 (inclusive).") | |
| (day nil :documentation "This is an integer between 1 and 31 (inclusive).") | |
| (month nil :documentation "\ | |
| This is an integer between 1 and 12 (inclusive). January is 1.") | |
| (year nil :documentation "This is a four digit integer.") | |
| (weekday nil :documentation "\ | |
| This is a number between 0 and 6, and 0 is Sunday.") | |
| (dst nil :documentation "\ | |
| This is t if daylight saving time is in effect, nil if it is not | |
| in effect, and -1 if daylight saving information is not | |
| available.") | |
| (zone nil :documentation "\ | |
| This is an integer indicating the UTC offset in seconds, i.e., | |
| the number of seconds east of Greenwich.") | |
| ) | |
| (provide 'simple) | |
| ;;; simple.el ends here |
This file contains hidden or bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
| ;;; tramp-cache.el --- file information caching for Tramp -*- lexical-binding:t -*- | |
| ;; Copyright (C) 2000, 2005-2020 Free Software Foundation, Inc. | |
| ;; Author: Daniel Pittman <[email protected]> | |
| ;; Michael Albinus <[email protected]> | |
| ;; Maintainer: Michael Albinus <[email protected]> | |
| ;; Keywords: comm, processes | |
| ;; Package: tramp | |
| ;; This file is part of GNU Emacs. | |
| ;; GNU Emacs is free software: you can redistribute it and/or modify | |
| ;; it under the terms of the GNU General Public License as published by | |
| ;; the Free Software Foundation, either version 3 of the License, or | |
| ;; (at your option) any later version. | |
| ;; GNU Emacs is distributed in the hope that it will be useful, | |
| ;; but WITHOUT ANY WARRANTY; without even the implied warranty of | |
| ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
| ;; GNU General Public License for more details. | |
| ;; You should have received a copy of the GNU General Public License | |
| ;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. | |
| ;;; Commentary: | |
| ;; An implementation of information caching for remote files. | |
| ;; Each connection, identified by a `tramp-file-name' structure or by | |
| ;; a process, has a unique cache. We distinguish 4 kind of caches, | |
| ;; depending on the key: | |
| ;; | |
| ;; - localname is NIL. This are reusable properties. Examples: | |
| ;; "remote-shell" identifies the POSIX shell to be called on the | |
| ;; remote host, or "perl" is the command to be called on the remote | |
| ;; host when starting a Perl script. These properties are saved in | |
| ;; the file `tramp-persistency-file-name'. | |
| ;; | |
| ;; - localname is a string. This are temporary properties, which are | |
| ;; related to the file localname is referring to. Examples: | |
| ;; "file-exists-p" is t or nil, depending on the file existence, or | |
| ;; "file-attributes" caches the result of the function | |
| ;; `file-attributes'. These entries have a timestamp, and they | |
| ;; expire after `remote-file-name-inhibit-cache' seconds if this | |
| ;; variable is set. | |
| ;; | |
| ;; - The key is a process. This are temporary properties related to | |
| ;; an open connection. Examples: "scripts" keeps shell script | |
| ;; definitions already sent to the remote shell, "last-cmd-time" is | |
| ;; the time stamp a command has been sent to the remote process. | |
| ;; | |
| ;; - The key is nil. This are temporary properties related to the | |
| ;; local machine. Examples: "parse-passwd" and "parse-group" keep | |
| ;; the results of parsing "/etc/passwd" and "/etc/group", | |
| ;; "{uid,gid}-{integer,string}" are the local uid and gid, and | |
| ;; "locale" is the used shell locale. | |
| ;; Some properties are handled special: | |
| ;; | |
| ;; - "process-name", "process-buffer" and "first-password-request" are | |
| ;; not saved in the file `tramp-persistency-file-name'. | |
| ;;; Code: | |
| (require 'tramp) | |
| (autoload 'time-stamp-string "time-stamp") | |
| ;;; -- Cache -- | |
| ;;;###tramp-autoload | |
| (defvar tramp-cache-data (make-hash-table :test #'equal) | |
| "Hash table for remote files properties.") | |
| ;;;###tramp-autoload | |
| (defcustom tramp-connection-properties nil | |
| "List of static connection properties. | |
| Every entry has the form (REGEXP PROPERTY VALUE). The regexp | |
| matches remote file names. It can be nil. PROPERTY is a string, | |
| and VALUE the corresponding value. They are used, if there is no | |
| matching entry for PROPERTY in `tramp-cache-data'. For more | |
| details see the info pages." | |
| :group 'tramp | |
| :version "24.4" | |
| :type '(repeat (list (choice :tag "File Name regexp" regexp (const nil)) | |
| (choice :tag " Property" string) | |
| (choice :tag " Value" sexp)))) | |
| ;;;###tramp-autoload | |
| (defcustom tramp-persistency-file-name | |
| (expand-file-name (locate-user-emacs-file "tramp")) | |
| "File which keeps connection history for Tramp connections." | |
| :group 'tramp | |
| :type 'file) | |
| (defvar tramp-cache-data-changed nil | |
| "Whether persistent cache data have been changed.") | |
| (defun tramp-get-hash-table (key) | |
| "Return the hash table for KEY. | |
| If it doesn't exist yet, it is created and initialized with | |
| matching entries of `tramp-connection-properties'." | |
| (or (gethash key tramp-cache-data) | |
| (let ((hash | |
| (puthash key (make-hash-table :test #'equal) tramp-cache-data))) | |
| (when (tramp-file-name-p key) | |
| (dolist (elt tramp-connection-properties) | |
| (when (string-match-p | |
| (or (nth 0 elt) "") | |
| (tramp-make-tramp-file-name key 'noloc 'nohop)) | |
| (tramp-set-connection-property key (nth 1 elt) (nth 2 elt))))) | |
| hash))) | |
| ;;;###tramp-autoload | |
| (defun tramp-get-file-property (key file property default) | |
| "Get the PROPERTY of FILE from the cache context of KEY. | |
| Returns DEFAULT if not set." | |
| ;; Unify localname. Remove hop from `tramp-file-name' structure. | |
| (setq file (tramp-compat-file-name-unquote file) | |
| key (copy-tramp-file-name key)) | |
| (setf (tramp-file-name-localname key) | |
| (tramp-run-real-handler #'directory-file-name (list file)) | |
| (tramp-file-name-hop key) nil) | |
| (let* ((hash (tramp-get-hash-table key)) | |
| (value (when (hash-table-p hash) (gethash property hash)))) | |
| (if ;; We take the value only if there is any, and | |
| ;; `remote-file-name-inhibit-cache' indicates that it is still | |
| ;; valid. Otherwise, DEFAULT is set. | |
| (and (consp value) | |
| (or (null remote-file-name-inhibit-cache) | |
| (and (integerp remote-file-name-inhibit-cache) | |
| (time-less-p | |
| nil | |
| (time-add (car value) remote-file-name-inhibit-cache))) | |
| (and (consp remote-file-name-inhibit-cache) | |
| (time-less-p | |
| remote-file-name-inhibit-cache (car value))))) | |
| (setq value (cdr value)) | |
| (setq value default)) | |
| (tramp-message key 8 "%s %s %s" file property value) | |
| (when (>= tramp-verbose 10) | |
| (let* ((var (intern (concat "tramp-cache-get-count-" property))) | |
| (val (or (numberp (bound-and-true-p var)) | |
| (progn | |
| (add-hook 'tramp-cache-unload-hook | |
| (lambda () (makunbound var))) | |
| 0)))) | |
| (set var (1+ val)))) | |
| value)) | |
| ;;;###tramp-autoload | |
| (defun tramp-set-file-property (key file property value) | |
| "Set the PROPERTY of FILE to VALUE, in the cache context of KEY. | |
| Returns VALUE." | |
| ;; Unify localname. Remove hop from `tramp-file-name' structure. | |
| (setq file (tramp-compat-file-name-unquote file) | |
| key (copy-tramp-file-name key)) | |
| (setf (tramp-file-name-localname key) | |
| (tramp-run-real-handler #'directory-file-name (list file)) | |
| (tramp-file-name-hop key) nil) | |
| (let ((hash (tramp-get-hash-table key))) | |
| ;; We put the timestamp there. | |
| (puthash property (cons (current-time) value) hash) | |
| (tramp-message key 8 "%s %s %s" file property value) | |
| (when (>= tramp-verbose 10) | |
| (let* ((var (intern (concat "tramp-cache-set-count-" property))) | |
| (val (or (numberp (bound-and-true-p var)) | |
| (progn | |
| (add-hook 'tramp-cache-unload-hook | |
| (lambda () (makunbound var))) | |
| 0)))) | |
| (set var (1+ val)))) | |
| value)) | |
| ;;;###tramp-autoload | |
| (defun tramp-flush-file-property (key file property) | |
| "Remove PROPERTY of FILE in the cache context of KEY." | |
| ;; Unify localname. Remove hop from `tramp-file-name' structure. | |
| (setq file (tramp-compat-file-name-unquote file) | |
| key (copy-tramp-file-name key)) | |
| (setf (tramp-file-name-localname key) | |
| (tramp-run-real-handler #'directory-file-name (list file)) | |
| (tramp-file-name-hop key) nil) | |
| (remhash property (tramp-get-hash-table key)) | |
| (tramp-message key 8 "%s %s" file property) | |
| (when (>= tramp-verbose 10) | |
| (let ((var (intern (concat "tramp-cache-set-count-" property)))) | |
| (makunbound var)))) | |
| (defun tramp-flush-file-upper-properties (key file) | |
| "Remove some properties of FILE's upper directory." | |
| (when (file-name-absolute-p file) | |
| (let ((file (directory-file-name (file-name-directory file)))) | |
| ;; Unify localname. Remove hop from `tramp-file-name' structure. | |
| (setq file (tramp-compat-file-name-unquote file) | |
| key (copy-tramp-file-name key)) | |
| (setf (tramp-file-name-localname key) file | |
| (tramp-file-name-hop key) nil) | |
| (dolist (property (hash-table-keys (tramp-get-hash-table key))) | |
| (when (string-match-p | |
| "^\\(directory-\\|file-name-all-completions\\|file-entries\\)" | |
| property) | |
| (tramp-flush-file-property key file property)))))) | |
| ;;;###tramp-autoload | |
| (defun tramp-flush-file-properties (key file) | |
| "Remove all properties of FILE in the cache context of KEY." | |
| (let* ((file (tramp-run-real-handler | |
| #'directory-file-name (list file))) | |
| (truename (tramp-get-file-property key file "file-truename" nil))) | |
| ;; Unify localname. Remove hop from `tramp-file-name' structure. | |
| (setq file (tramp-compat-file-name-unquote file) | |
| key (copy-tramp-file-name key)) | |
| (setf (tramp-file-name-localname key) file | |
| (tramp-file-name-hop key) nil) | |
| (tramp-message key 8 "%s" file) | |
| (remhash key tramp-cache-data) | |
| ;; Remove file properties of symlinks. | |
| (when (and (stringp truename) | |
| (not (string-equal file (directory-file-name truename)))) | |
| (tramp-flush-file-properties key truename)) | |
| ;; Remove selected properties of upper directory. | |
| (tramp-flush-file-upper-properties key file))) | |
| ;;;###tramp-autoload | |
| (defun tramp-flush-directory-properties (key directory) | |
| "Remove all properties of DIRECTORY in the cache context of KEY. | |
| Remove also properties of all files in subdirectories." | |
| (setq directory (tramp-compat-file-name-unquote directory)) | |
| (let* ((directory (tramp-run-real-handler | |
| #'directory-file-name (list directory))) | |
| (truename (tramp-get-file-property key directory "file-truename" nil))) | |
| (tramp-message key 8 "%s" directory) | |
| (dolist (key (hash-table-keys tramp-cache-data)) | |
| (when (and (tramp-file-name-p key) | |
| (stringp (tramp-file-name-localname key)) | |
| (string-match-p (regexp-quote directory) | |
| (tramp-file-name-localname key))) | |
| (remhash key tramp-cache-data))) | |
| ;; Remove file properties of symlinks. | |
| (when (and (stringp truename) | |
| (not (string-equal directory (directory-file-name truename)))) | |
| (tramp-flush-directory-properties key truename)) | |
| ;; Remove selected properties of upper directory. | |
| (tramp-flush-file-upper-properties key directory))) | |
| ;; Reverting or killing a buffer should also flush file properties. | |
| ;; They could have been changed outside Tramp. In eshell, "ls" would | |
| ;; not show proper directory contents when a file has been copied or | |
| ;; deleted before. We must apply `save-match-data', because it would | |
| ;; corrupt other packages otherwise (reported from org). | |
| (defun tramp-flush-file-function () | |
| "Flush all Tramp cache properties from `buffer-file-name'. | |
| This is suppressed for temporary buffers." | |
| (save-match-data | |
| (unless (or (null (buffer-name)) | |
| (string-match-p "^\\( \\|\\*\\)" (buffer-name))) | |
| (let ((bfn (if (stringp (buffer-file-name)) | |
| (buffer-file-name) | |
| default-directory)) | |
| (tramp-verbose 0)) | |
| (when (tramp-tramp-file-p bfn) | |
| (with-parsed-tramp-file-name bfn nil | |
| (tramp-flush-file-properties v localname))))))) | |
| (add-hook 'before-revert-hook #'tramp-flush-file-function) | |
| (add-hook 'eshell-pre-command-hook #'tramp-flush-file-function) | |
| (add-hook 'kill-buffer-hook #'tramp-flush-file-function) | |
| (add-hook 'tramp-cache-unload-hook | |
| (lambda () | |
| (remove-hook 'before-revert-hook | |
| #'tramp-flush-file-function) | |
| (remove-hook 'eshell-pre-command-hook | |
| #'tramp-flush-file-function) | |
| (remove-hook 'kill-buffer-hook | |
| #'tramp-flush-file-function))) | |
| ;;; -- Properties -- | |
| ;;;###tramp-autoload | |
| (defun tramp-get-connection-property (key property default) | |
| "Get the named PROPERTY for the connection. | |
| KEY identifies the connection, it is either a process or a | |
| `tramp-file-name' structure. A special case is nil, which is | |
| used to cache connection properties of the local machine. If the | |
| value is not set for the connection, returns DEFAULT." | |
| ;; Unify key by removing localname and hop from `tramp-file-name' | |
| ;; structure. Work with a copy in order to avoid side effects. | |
| (when (tramp-file-name-p key) | |
| (setq key (copy-tramp-file-name key)) | |
| (setf (tramp-file-name-localname key) nil | |
| (tramp-file-name-hop key) nil)) | |
| (let* ((hash (tramp-get-hash-table key)) | |
| (value | |
| ;; If the key is an auxiliary process object, check whether | |
| ;; the process is still alive. | |
| (if (and (processp key) (not (process-live-p key))) | |
| default | |
| (if (hash-table-p hash) | |
| (gethash property hash default) | |
| default)))) | |
| (tramp-message key 7 "%s %s" property value) | |
| value)) | |
| ;;;###tramp-autoload | |
| (defun tramp-set-connection-property (key property value) | |
| "Set the named PROPERTY of a connection to VALUE. | |
| KEY identifies the connection, it is either a process or a | |
| `tramp-file-name' structure. A special case is nil, which is | |
| used to cache connection properties of the local machine. | |
| PROPERTY is set persistent when KEY is a `tramp-file-name' structure." | |
| ;; Unify key by removing localname and hop from `tramp-file-name' | |
| ;; structure. Work with a copy in order to avoid side effects. | |
| (when (tramp-file-name-p key) | |
| (setq key (copy-tramp-file-name key)) | |
| (setf (tramp-file-name-localname key) nil | |
| (tramp-file-name-hop key) nil)) | |
| (let ((hash (tramp-get-hash-table key))) | |
| (puthash property value hash) | |
| (setq tramp-cache-data-changed t) | |
| (tramp-message key 7 "%s %s" property value) | |
| value)) | |
| ;;;###tramp-autoload | |
| (defun tramp-connection-property-p (key property) | |
| "Check whether named PROPERTY of a connection is defined. | |
| KEY identifies the connection, it is either a process or a | |
| `tramp-file-name' structure. A special case is nil, which is | |
| used to cache connection properties of the local machine." | |
| (not (eq (tramp-get-connection-property key property 'undef) 'undef))) | |
| ;;;###tramp-autoload | |
| (defun tramp-flush-connection-property (key property) | |
| "Remove the named PROPERTY of a connection identified by KEY. | |
| KEY identifies the connection, it is either a process or a | |
| `tramp-file-name' structure. A special case is nil, which is | |
| used to cache connection properties of the local machine. | |
| PROPERTY is set persistent when KEY is a `tramp-file-name' structure." | |
| ;; Unify key by removing localname and hop from `tramp-file-name' | |
| ;; structure. Work with a copy in order to avoid side effects. | |
| (when (tramp-file-name-p key) | |
| (setq key (copy-tramp-file-name key)) | |
| (setf (tramp-file-name-localname key) nil | |
| (tramp-file-name-hop key) nil)) | |
| (remhash property (tramp-get-hash-table key)) | |
| (setq tramp-cache-data-changed t) | |
| (tramp-message key 7 "%s" property)) | |
| ;;;###tramp-autoload | |
| (defun tramp-flush-connection-properties (key) | |
| "Remove all properties identified by KEY. | |
| KEY identifies the connection, it is either a process or a | |
| `tramp-file-name' structure. A special case is nil, which is | |
| used to cache connection properties of the local machine." | |
| ;; Unify key by removing localname and hop from `tramp-file-name' | |
| ;; structure. Work with a copy in order to avoid side effects. | |
| (when (tramp-file-name-p key) | |
| (setq key (copy-tramp-file-name key)) | |
| (setf (tramp-file-name-localname key) nil | |
| (tramp-file-name-hop key) nil)) | |
| (tramp-message | |
| key 7 "%s %s" key | |
| (let ((hash (gethash key tramp-cache-data))) | |
| (when (hash-table-p hash) (hash-table-keys hash)))) | |
| (setq tramp-cache-data-changed t) | |
| (remhash key tramp-cache-data)) | |
| ;;;###tramp-autoload | |
| (defun tramp-cache-print (table) | |
| "Print hash table TABLE." | |
| (when (hash-table-p table) | |
| (let (result) | |
| (maphash | |
| (lambda (key value) | |
| ;; Remove text properties from KEY and VALUE. | |
| (when (tramp-file-name-p key) | |
| (dolist | |
| (slot | |
| (mapcar #'car (cdr (cl-struct-slot-info 'tramp-file-name)))) | |
| (when (stringp (cl-struct-slot-value 'tramp-file-name slot key)) | |
| (setf (cl-struct-slot-value 'tramp-file-name slot key) | |
| (substring-no-properties | |
| (cl-struct-slot-value 'tramp-file-name slot key)))))) | |
| (when (stringp key) | |
| (setq key (substring-no-properties key))) | |
| (when (stringp value) | |
| (setq value (substring-no-properties value))) | |
| ;; Dump. | |
| (let ((tmp (format | |
| "(%s %s)" | |
| (if (processp key) | |
| (prin1-to-string (prin1-to-string key)) | |
| (prin1-to-string key)) | |
| (if (hash-table-p value) | |
| (tramp-cache-print value) | |
| (if (or (bufferp value) | |
| ;; Mutexes have entered Emacs 26.1. | |
| (tramp-compat-funcall 'mutexp value)) | |
| (prin1-to-string (prin1-to-string value)) | |
| (prin1-to-string value)))))) | |
| (setq result (if result (concat result " " tmp) tmp)))) | |
| table) | |
| result))) | |
| ;;;###tramp-autoload | |
| (defun tramp-list-connections () | |
| "Return all known `tramp-file-name' structs according to `tramp-cache'." | |
| (let ((tramp-verbose 0)) | |
| (delq nil (mapcar | |
| (lambda (key) | |
| (and (tramp-file-name-p key) | |
| (null (tramp-file-name-localname key)) | |
| (tramp-connection-property-p key "process-buffer") | |
| key)) | |
| (hash-table-keys tramp-cache-data))))) | |
| (defun tramp-dump-connection-properties () | |
| "Write persistent connection properties into file `tramp-persistency-file-name'." | |
| ;; We shouldn't fail, otherwise Emacs might not be able to be closed. | |
| (ignore-errors | |
| (when (and (hash-table-p tramp-cache-data) | |
| (not (zerop (hash-table-count tramp-cache-data))) | |
| tramp-cache-data-changed | |
| (stringp tramp-persistency-file-name)) | |
| (let ((cache (copy-hash-table tramp-cache-data)) | |
| print-length print-level) | |
| ;; Remove temporary data. If there is the key "login-as", we | |
| ;; don't save either, because all other properties might | |
| ;; depend on the login name, and we want to give the | |
| ;; possibility to use another login name later on. Key | |
| ;; "started" exists for the "ftp" method only, which must be | |
| ;; be kept persistent. | |
| (maphash | |
| (lambda (key value) | |
| (if (and (tramp-file-name-p key) value | |
| (not (string-equal | |
| (tramp-file-name-method key) tramp-archive-method)) | |
| (not (tramp-file-name-localname key)) | |
| (not (gethash "login-as" value)) | |
| (not (gethash "started" value))) | |
| (progn | |
| (remhash "process-name" value) | |
| (remhash "process-buffer" value) | |
| (remhash "first-password-request" value)) | |
| (remhash key cache))) | |
| cache) | |
| ;; Dump it. | |
| (with-temp-file tramp-persistency-file-name | |
| (insert | |
| ";; -*- emacs-lisp -*-" | |
| ;; `time-stamp-string' might not exist in all Emacs flavors. | |
| (condition-case nil | |
| (progn | |
| (format | |
| " <%s %s>\n" | |
| (time-stamp-string "%02y/%02m/%02d %02H:%02M:%02S") | |
| tramp-persistency-file-name)) | |
| (error "\n")) | |
| ";; Tramp connection history. Don't change this file.\n" | |
| ";; Run `M-x tramp-cleanup-all-connections' instead.\n\n" | |
| (with-output-to-string | |
| (pp (read (format "(%s)" (tramp-cache-print cache))))))))))) | |
| (unless noninteractive | |
| (add-hook 'kill-emacs-hook #'tramp-dump-connection-properties)) | |
| (add-hook 'tramp-cache-unload-hook | |
| (lambda () | |
| (remove-hook 'kill-emacs-hook | |
| #'tramp-dump-connection-properties))) | |
| ;;;###tramp-autoload | |
| (defun tramp-parse-connection-properties (method) | |
| "Return a list of (user host) tuples allowed to access for METHOD. | |
| This function is added always in `tramp-get-completion-function' | |
| for all methods. Resulting data are derived from connection history." | |
| (mapcar | |
| (lambda (key) | |
| (and (tramp-file-name-p key) | |
| (string-equal method (tramp-file-name-method key)) | |
| (not (tramp-file-name-localname key)) | |
| (list (tramp-file-name-user key) | |
| (tramp-file-name-host key)))) | |
| (hash-table-keys tramp-cache-data))) | |
| ;; When "emacs -Q" has been called, both variables are nil. We do not | |
| ;; load the persistency file then, in order to have a clean test environment. | |
| ;;;###tramp-autoload | |
| (defvar tramp-cache-read-persistent-data (or init-file-user site-run-file) | |
| "Whether to read persistent data at startup time.") | |
| ;; Read persistent connection history. | |
| (when (and (stringp tramp-persistency-file-name) | |
| (zerop (hash-table-count tramp-cache-data)) | |
| tramp-cache-read-persistent-data) | |
| (condition-case err | |
| (with-temp-buffer | |
| (insert-file-contents-literally tramp-persistency-file-name) | |
| (let ((list (read (current-buffer))) | |
| (tramp-verbose 0) | |
| element key item) | |
| (while (setq element (pop list)) | |
| (setq key (pop element)) | |
| (when (tramp-file-name-p key) | |
| (while (setq item (pop element)) | |
| ;; We set only values which are not contained in | |
| ;; `tramp-connection-properties'. The cache is | |
| ;; initialized properly by side effect. | |
| (unless (tramp-connection-property-p key (car item)) | |
| (tramp-set-connection-property key (pop item) (car item))))))) | |
| (setq tramp-cache-data-changed nil)) | |
| (file-error | |
| ;; Most likely because the file doesn't exist yet. No message. | |
| (clrhash tramp-cache-data)) | |
| (error | |
| ;; File is corrupted. | |
| (message "Tramp persistency file `%s' is corrupted: %s" | |
| tramp-persistency-file-name (error-message-string err)) | |
| (clrhash tramp-cache-data)))) | |
| (add-hook 'tramp-unload-hook | |
| (lambda () | |
| (unload-feature 'tramp-cache 'force))) | |
| (provide 'tramp-cache) | |
| ;;; tramp-cache.el ends here |
This file contains hidden or bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
| ;;; tramp-compat.el --- Tramp compatibility functions -*- lexical-binding:t -*- | |
| ;; Copyright (C) 2007-2020 Free Software Foundation, Inc. | |
| ;; Author: Michael Albinus <[email protected]> | |
| ;; Keywords: comm, processes | |
| ;; Package: tramp | |
| ;; This file is part of GNU Emacs. | |
| ;; GNU Emacs is free software: you can redistribute it and/or modify | |
| ;; it under the terms of the GNU General Public License as published by | |
| ;; the Free Software Foundation, either version 3 of the License, or | |
| ;; (at your option) any later version. | |
| ;; GNU Emacs is distributed in the hope that it will be useful, | |
| ;; but WITHOUT ANY WARRANTY; without even the implied warranty of | |
| ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
| ;; GNU General Public License for more details. | |
| ;; You should have received a copy of the GNU General Public License | |
| ;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. | |
| ;;; Commentary: | |
| ;; Tramp's main Emacs version for development is Emacs 28. This | |
| ;; package provides compatibility functions for Emacs 25, Emacs 26 and | |
| ;; Emacs 27. | |
| ;;; Code: | |
| ;; In Emacs 25, `tramp-unload-file-name-handlers' is not autoloaded. | |
| ;; So we declare it here in order to avoid recursive load. This will | |
| ;; be overwritten in tramp.el. | |
| (defun tramp-unload-file-name-handlers () ".") | |
| (require 'auth-source) | |
| (require 'format-spec) | |
| (require 'ls-lisp) ;; Due to `tramp-handle-insert-directory'. | |
| (require 'parse-time) | |
| (require 'shell) | |
| (require 'subr-x) | |
| ;; `temporary-file-directory' as function is introduced with Emacs 26.1. | |
| (declare-function tramp-handle-temporary-file-directory "tramp") | |
| ;; For not existing functions, obsolete functions, or functions with a | |
| ;; changed argument list, there are compiler warnings. We want to | |
| ;; avoid them in cases we know what we do. | |
| (defmacro tramp-compat-funcall (function &rest arguments) | |
| "Call FUNCTION with ARGUMENTS if it exists. Do not raise compiler warnings." | |
| `(when (functionp ,function) | |
| (with-no-warnings (funcall ,function ,@arguments)))) | |
| (put #'tramp-compat-funcall 'tramp-suppress-trace t) | |
| (defsubst tramp-compat-temporary-file-directory () | |
| "Return name of directory for temporary files. | |
| It is the default value of `temporary-file-directory'." | |
| ;; We must return a local directory. If it is remote, we could run | |
| ;; into an infloop. | |
| (eval (car (get 'temporary-file-directory 'standard-value)))) | |
| (defsubst tramp-compat-make-temp-file (f &optional dir-flag) | |
| "Create a local temporary file (compat function). | |
| Add the extension of F, if existing." | |
| (let* (file-name-handler-alist | |
| (prefix (expand-file-name | |
| (symbol-value 'tramp-temp-name-prefix) | |
| (tramp-compat-temporary-file-directory))) | |
| (extension (file-name-extension f t))) | |
| (make-temp-file prefix dir-flag extension))) | |
| ;; `temporary-file-directory' as function is introduced with Emacs 26.1. | |
| (defalias 'tramp-compat-temporary-file-directory-function | |
| (if (fboundp 'temporary-file-directory) | |
| #'temporary-file-directory | |
| #'tramp-handle-temporary-file-directory)) | |
| ;; `file-attribute-*' are introduced in Emacs 26.1. | |
| (defalias 'tramp-compat-file-attribute-type | |
| (if (fboundp 'file-attribute-type) | |
| #'file-attribute-type | |
| (lambda (attributes) | |
| "The type field in ATTRIBUTES returned by `file-attributes'. | |
| The value is either t for directory, string (name linked to) for | |
| symbolic link, or nil." | |
| (nth 0 attributes)))) | |
| (defalias 'tramp-compat-file-attribute-link-number | |
| (if (fboundp 'file-attribute-link-number) | |
| #'file-attribute-link-number | |
| (lambda (attributes) | |
| "Return the number of links in ATTRIBUTES returned by `file-attributes'." | |
| (nth 1 attributes)))) | |
| (defalias 'tramp-compat-file-attribute-user-id | |
| (if (fboundp 'file-attribute-user-id) | |
| #'file-attribute-user-id | |
| (lambda (attributes) | |
| "The UID field in ATTRIBUTES returned by `file-attributes'. | |
| This is either a string or a number. If a string value cannot be | |
| looked up, a numeric value, either an integer or a float, is | |
| returned." | |
| (nth 2 attributes)))) | |
| (defalias 'tramp-compat-file-attribute-group-id | |
| (if (fboundp 'file-attribute-group-id) | |
| #'file-attribute-group-id | |
| (lambda (attributes) | |
| "The GID field in ATTRIBUTES returned by `file-attributes'. | |
| This is either a string or a number. If a string value cannot be | |
| looked up, a numeric value, either an integer or a float, is | |
| returned." | |
| (nth 3 attributes)))) | |
| (defalias 'tramp-compat-file-attribute-access-time | |
| (if (fboundp 'file-attribute-access-time) | |
| #'file-attribute-access-time | |
| (lambda (attributes) | |
| "The last access time in ATTRIBUTES returned by `file-attributes'. | |
| This a Lisp timestamp in the style of `current-time'." | |
| (nth 4 attributes)))) | |
| (defalias 'tramp-compat-file-attribute-modification-time | |
| (if (fboundp 'file-attribute-modification-time) | |
| #'file-attribute-modification-time | |
| (lambda (attributes) | |
| "The modification time in ATTRIBUTES returned by `file-attributes'. | |
| This is the time of the last change to the file's contents, and | |
| is a Lisp timestamp in the style of `current-time'." | |
| (nth 5 attributes)))) | |
| (defalias 'tramp-compat-file-attribute-status-change-time | |
| (if (fboundp 'file-attribute-status-change-time) | |
| #'file-attribute-status-change-time | |
| (lambda (attributes) | |
| "The status modification time in ATTRIBUTES returned by `file-attributes'. | |
| This is the time of last change to the file's attributes: owner | |
| and group, access mode bits, etc., and is a Lisp timestamp in the | |
| style of `current-time'." | |
| (nth 6 attributes)))) | |
| (defalias 'tramp-compat-file-attribute-size | |
| (if (fboundp 'file-attribute-size) | |
| #'file-attribute-size | |
| (lambda (attributes) | |
| "The size (in bytes) in ATTRIBUTES returned by `file-attributes'. | |
| If the size is too large for a fixnum, this is a bignum in Emacs 27 | |
| and later, and is a float in Emacs 26 and earlier." | |
| (nth 7 attributes)))) | |
| (defalias 'tramp-compat-file-attribute-modes | |
| (if (fboundp 'file-attribute-modes) | |
| #'file-attribute-modes | |
| (lambda (attributes) | |
| "The file modes in ATTRIBUTES returned by `file-attributes'. | |
| This is a string of ten letters or dashes as in ls -l." | |
| (nth 8 attributes)))) | |
| ;; `file-missing' is introduced in Emacs 26.1. | |
| (defconst tramp-file-missing | |
| (if (get 'file-missing 'error-conditions) 'file-missing 'file-error) | |
| "The error symbol for the `file-missing' error.") | |
| ;; `file-local-name', `file-name-quoted-p', `file-name-quote' and | |
| ;; `file-name-unquote' are introduced in Emacs 26.1. | |
| (defalias 'tramp-compat-file-local-name | |
| (if (fboundp 'file-local-name) | |
| #'file-local-name | |
| (lambda (name) | |
| "Return the local name component of NAME. | |
| It returns a file name which can be used directly as argument of | |
| `process-file', `start-file-process', or `shell-command'." | |
| (or (file-remote-p name 'localname) name)))) | |
| ;; `file-name-quoted-p', `file-name-quote' and `file-name-unquote' got | |
| ;; a second argument in Emacs 27.1. | |
| (defalias 'tramp-compat-file-name-quoted-p | |
| (if (and | |
| (fboundp 'file-name-quoted-p) | |
| (equal (tramp-compat-funcall 'func-arity #'file-name-quoted-p) '(1 . 2))) | |
| #'file-name-quoted-p | |
| (lambda (name &optional top) | |
| "Whether NAME is quoted with prefix \"/:\". | |
| If NAME is a remote file name and TOP is nil, check the local part of NAME." | |
| (let ((file-name-handler-alist (unless top file-name-handler-alist))) | |
| (string-prefix-p "/:" (tramp-compat-file-local-name name)))))) | |
| (defalias 'tramp-compat-file-name-quote | |
| (if (and | |
| (fboundp 'file-name-quote) | |
| (equal (tramp-compat-funcall 'func-arity #'file-name-quote) '(1 . 2))) | |
| #'file-name-quote | |
| (lambda (name &optional top) | |
| "Add the quotation prefix \"/:\" to file NAME. | |
| If NAME is a remote file name and TOP is nil, the local part of NAME is quoted." | |
| (let ((file-name-handler-alist (unless top file-name-handler-alist))) | |
| (if (tramp-compat-file-name-quoted-p name top) | |
| name | |
| (concat | |
| (file-remote-p name) "/:" (tramp-compat-file-local-name name))))))) | |
| (defalias 'tramp-compat-file-name-unquote | |
| (if (and | |
| (fboundp 'file-name-unquote) | |
| (equal (tramp-compat-funcall 'func-arity #'file-name-unquote) '(1 . 2))) | |
| #'file-name-unquote | |
| (lambda (name &optional top) | |
| "Remove quotation prefix \"/:\" from file NAME. | |
| If NAME is a remote file name and TOP is nil, the local part of | |
| NAME is unquoted." | |
| (let* ((file-name-handler-alist (unless top file-name-handler-alist)) | |
| (localname (tramp-compat-file-local-name name))) | |
| (when (tramp-compat-file-name-quoted-p localname top) | |
| (setq | |
| localname (if (= (length localname) 2) "/" (substring localname 2)))) | |
| (concat (file-remote-p name) localname))))) | |
| ;; `tramp-syntax' has changed its meaning in Emacs 26.1. We still | |
| ;; support old settings. | |
| (defsubst tramp-compat-tramp-syntax () | |
| "Return proper value of `tramp-syntax'." | |
| (defvar tramp-syntax) | |
| (cond ((eq tramp-syntax 'ftp) 'default) | |
| ((eq tramp-syntax 'sep) 'separate) | |
| (t tramp-syntax))) | |
| ;; The signature of `tramp-make-tramp-file-name' has been changed. | |
| ;; Therefore, we cannot use `url-tramp-convert-url-to-tramp' prior | |
| ;; Emacs 26.1. We use `temporary-file-directory' as indicator. | |
| (defconst tramp-compat-use-url-tramp-p (fboundp 'temporary-file-directory) | |
| "Whether to use url-tramp.el.") | |
| ;; Threads have entered Emacs 26.1, `main-thread' in Emacs 27.1. But | |
| ;; then, they might not exist when Emacs is configured | |
| ;; --without-threads. | |
| (defconst tramp-compat-main-thread (bound-and-true-p main-thread) | |
| "The main thread of Emacs, if compiled --with-threads.") | |
| (defsubst tramp-compat-current-thread () | |
| "The current thread, or nil if compiled --without-threads." | |
| (tramp-compat-funcall 'current-thread)) | |
| (defsubst tramp-compat-thread-yield () | |
| "Yield the CPU to another thread." | |
| (tramp-compat-funcall 'thread-yield)) | |
| ;; Mutexes have entered Emacs 26.1. Once we use only Emacs 26+, we | |
| ;; must check (mutexp mutex), because the other functions might still | |
| ;; not exist when Emacs is configured --without-threads. | |
| (defmacro tramp-compat-with-mutex (mutex &rest body) | |
| "Invoke BODY with MUTEX held, releasing MUTEX when done. | |
| This is the simplest safe way to acquire and release a mutex." | |
| (declare (indent 1) (debug t)) | |
| `(if (fboundp 'with-mutex) | |
| (with-mutex ,mutex ,@body) | |
| ,@body)) | |
| ;; `exec-path' is new in Emacs 27.1. | |
| (defalias 'tramp-compat-exec-path | |
| (if (fboundp 'exec-path) | |
| #'exec-path | |
| (lambda () | |
| "List of directories to search programs to run in remote subprocesses." | |
| (if-let ((handler (find-file-name-handler default-directory 'exec-path))) | |
| (funcall handler 'exec-path) | |
| exec-path)))) | |
| ;; `time-equal-p' has appeared in Emacs 27.1. | |
| (defalias 'tramp-compat-time-equal-p | |
| (if (fboundp 'time-equal-p) | |
| #'time-equal-p | |
| (lambda (t1 t2) | |
| "Return non-nil if time value T1 is equal to time value T2. | |
| A nil value for either argument stands for the current time." | |
| (equal (or t1 (current-time)) (or t2 (current-time)))))) | |
| ;; `flatten-tree' has appeared in Emacs 27.1. | |
| (defalias 'tramp-compat-flatten-tree | |
| (if (fboundp 'flatten-tree) | |
| #'flatten-tree | |
| (lambda (tree) | |
| "Take TREE and \"flatten\" it." | |
| (let (elems) | |
| (setq tree (list tree)) | |
| (while (let ((elem (pop tree))) | |
| (cond ((consp elem) | |
| (setq tree (cons (car elem) (cons (cdr elem) tree)))) | |
| (elem | |
| (push elem elems))) | |
| tree)) | |
| (nreverse elems))))) | |
| ;; `progress-reporter-update' got argument SUFFIX in Emacs 27.1. | |
| (defalias 'tramp-compat-progress-reporter-update | |
| (if (equal (tramp-compat-funcall 'func-arity #'progress-reporter-update) | |
| '(1 . 3)) | |
| #'progress-reporter-update | |
| (lambda (reporter &optional value _suffix) | |
| (progress-reporter-update reporter value)))) | |
| ;; `file-modes', `set-file-modes' and `set-file-times' got argument | |
| ;; FLAG in Emacs 28.1. | |
| (defalias 'tramp-compat-file-modes | |
| (if (equal (tramp-compat-funcall 'func-arity #'file-modes) '(1 . 2)) | |
| #'file-modes | |
| (lambda (filename &optional _flag) | |
| (file-modes filename)))) | |
| (defalias 'tramp-compat-set-file-modes | |
| (if (equal (tramp-compat-funcall 'func-arity #'set-file-modes) '(2 . 3)) | |
| #'set-file-modes | |
| (lambda (filename mode &optional _flag) | |
| (set-file-modes filename mode)))) | |
| (defalias 'tramp-compat-set-file-times | |
| (if (equal (tramp-compat-funcall 'func-arity #'set-file-times) '(1 . 3)) | |
| #'set-file-times | |
| (lambda (filename &optional timestamp _flag) | |
| (set-file-times filename timestamp)))) | |
| (add-hook 'tramp-unload-hook | |
| (lambda () | |
| (unload-feature 'tramp-loaddefs 'force) | |
| (unload-feature 'tramp-compat 'force))) | |
| (provide 'tramp-compat) | |
| ;;; TODO: | |
| ;; | |
| ;; * `func-arity' exists since Emacs 26.1. | |
| ;; | |
| ;; * Starting with Emacs 27.1, there's no need to escape open | |
| ;; parentheses with a backslash in docstrings anymore. | |
| ;;; tramp-compat.el ends here |
This file contains hidden or bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
| ;;; tramp-ftp.el --- Tramp convenience functions for Ange-FTP -*- lexical-binding:t -*- | |
| ;; Copyright (C) 2002-2020 Free Software Foundation, Inc. | |
| ;; Author: Michael Albinus <[email protected]> | |
| ;; Keywords: comm, processes | |
| ;; Package: tramp | |
| ;; This file is part of GNU Emacs. | |
| ;; GNU Emacs is free software: you can redistribute it and/or modify | |
| ;; it under the terms of the GNU General Public License as published by | |
| ;; the Free Software Foundation, either version 3 of the License, or | |
| ;; (at your option) any later version. | |
| ;; GNU Emacs is distributed in the hope that it will be useful, | |
| ;; but WITHOUT ANY WARRANTY; without even the implied warranty of | |
| ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
| ;; GNU General Public License for more details. | |
| ;; You should have received a copy of the GNU General Public License | |
| ;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. | |
| ;;; Commentary: | |
| ;; Convenience functions for calling Ange-FTP from Tramp. | |
| ;; Most of them are displaced from tramp.el. | |
| ;;; Code: | |
| (require 'tramp) | |
| ;; Pacify byte-compiler. | |
| (eval-when-compile | |
| (require 'custom)) | |
| (declare-function ange-ftp-ftp-process-buffer "ange-ftp") | |
| (defvar ange-ftp-ftp-name-arg) | |
| (defvar ange-ftp-ftp-name-res) | |
| (defvar ange-ftp-name-format) | |
| ;; Disable Ange-FTP from file-name-handler-alist. | |
| (defun tramp-disable-ange-ftp () | |
| "Turn Ange-FTP off. | |
| This is useful for unified remoting. See | |
| `tramp-file-name-structure' for details. Requests suitable for | |
| Ange-FTP will be forwarded to Ange-FTP. Also see the variables | |
| `tramp-ftp-method', `tramp-default-method', and | |
| `tramp-default-method-alist'. | |
| This function is not needed in Emacsen which include Tramp, but is | |
| present for backward compatibility." | |
| (let ((a1 (rassq 'ange-ftp-hook-function file-name-handler-alist)) | |
| (a2 (rassq 'ange-ftp-completion-hook-function file-name-handler-alist))) | |
| (setq file-name-handler-alist | |
| (delete a1 (delete a2 file-name-handler-alist))))) | |
| (with-eval-after-load 'ange-ftp | |
| (tramp-disable-ange-ftp)) | |
| ;;;###tramp-autoload | |
| (defun tramp-ftp-enable-ange-ftp () | |
| "Reenable Ange-FTP, when Tramp is unloaded." | |
| ;; The following code is commented out in Ange-FTP. | |
| ;;; This regexp takes care of real ange-ftp file names (with a slash | |
| ;;; and colon). | |
| ;;; Don't allow the host name to end in a period--some systems use /.: | |
| (or (assoc "^/[^/:]*[^/:.]:" file-name-handler-alist) | |
| (setq file-name-handler-alist | |
| (cons '("^/[^/:]*[^/:.]:" . ange-ftp-hook-function) | |
| file-name-handler-alist))) | |
| ;;; This regexp recognizes absolute filenames with only one component, | |
| ;;; for the sake of hostname completion. | |
| (or (assoc "^/[^/:]*\\'" file-name-handler-alist) | |
| (setq file-name-handler-alist | |
| (cons '("^/[^/:]*\\'" . ange-ftp-completion-hook-function) | |
| file-name-handler-alist))) | |
| ;;; This regexp recognizes absolute filenames with only one component | |
| ;;; on Windows, for the sake of hostname completion. | |
| (and (memq system-type '(ms-dos windows-nt)) | |
| (or (assoc "^[a-zA-Z]:/[^/:]*\\'" file-name-handler-alist) | |
| (setq file-name-handler-alist | |
| (cons '("^[a-zA-Z]:/[^/:]*\\'" . | |
| ange-ftp-completion-hook-function) | |
| file-name-handler-alist))))) | |
| (add-hook 'tramp-ftp-unload-hook #'tramp-ftp-enable-ange-ftp) | |
| ;; Define FTP method ... | |
| ;;;###tramp-autoload | |
| (defconst tramp-ftp-method "ftp" | |
| "When this method name is used, forward all calls to Ange-FTP.") | |
| ;; ... and add it to the method list. | |
| ;;;###tramp-autoload | |
| (tramp--with-startup | |
| (add-to-list 'tramp-methods (cons tramp-ftp-method nil)) | |
| ;; Add some defaults for `tramp-default-method-alist'. | |
| (add-to-list 'tramp-default-method-alist | |
| (list "\\`ftp\\." nil tramp-ftp-method)) | |
| (add-to-list 'tramp-default-method-alist | |
| (list nil "\\`\\(anonymous\\|ftp\\)\\'" tramp-ftp-method)) | |
| ;; Add completion function for FTP method. | |
| (tramp-set-completion-function | |
| tramp-ftp-method | |
| '((tramp-parse-netrc "~/.netrc")))) | |
| ;;;###tramp-autoload | |
| (defun tramp-ftp-file-name-handler (operation &rest args) | |
| "Invoke the Ange-FTP handler for OPERATION and ARGS. | |
| First arg specifies the OPERATION, second arg is a list of arguments to | |
| pass to the OPERATION." | |
| (save-match-data | |
| (or (boundp 'ange-ftp-name-format) | |
| (let (file-name-handler-alist) (require 'ange-ftp))) | |
| (let ((ange-ftp-name-format | |
| (list (nth 0 tramp-file-name-structure) | |
| (nth 3 tramp-file-name-structure) | |
| (nth 2 tramp-file-name-structure) | |
| (nth 4 tramp-file-name-structure))) | |
| ;; ange-ftp uses `ange-ftp-ftp-name-arg' and `ange-ftp-ftp-name-res' | |
| ;; for optimization in `ange-ftp-ftp-name'. If Tramp wasn't active, | |
| ;; there could be incorrect values from previous calls in case the | |
| ;; "ftp" method is used in the Tramp file name. So we unset | |
| ;; those values. | |
| (ange-ftp-ftp-name-arg "") | |
| (ange-ftp-ftp-name-res nil) | |
| (v (tramp-dissect-file-name | |
| (apply #'tramp-file-name-for-operation operation args) t))) | |
| (setf (tramp-file-name-method v) tramp-ftp-method) | |
| ;; Set "process-name" for thread support. | |
| (tramp-set-connection-property | |
| v "process-name" | |
| (ange-ftp-ftp-process-buffer | |
| (tramp-file-name-host v) (tramp-file-name-user v))) | |
| (cond | |
| ;; If argument is a symlink, `file-directory-p' and | |
| ;; `file-exists-p' call the traversed file recursively. So we | |
| ;; cannot disable the file-name-handler this case. We set the | |
| ;; connection property "started" in order to put the remote | |
| ;; location into the cache, which is helpful for further | |
| ;; completion. We don't use `with-parsed-tramp-file-name', | |
| ;; because this returns another user but the one declared in | |
| ;; "~/.netrc". | |
| ((memq operation '(file-directory-p file-exists-p)) | |
| (if (apply #'ange-ftp-hook-function operation args) | |
| (tramp-set-connection-property v "started" t) | |
| nil)) | |
| ;; If the second argument of `copy-file' or `rename-file' is a | |
| ;; remote file name but via FTP, ange-ftp doesn't check this. | |
| ;; We must copy it locally first, because there is no place in | |
| ;; ange-ftp for correct handling. | |
| ((and (memq operation '(copy-file rename-file)) | |
| (tramp-tramp-file-p (cadr args)) | |
| (not (tramp-ftp-file-name-p (cadr args)))) | |
| (let* ((filename (car args)) | |
| (newname (cadr args)) | |
| (tmpfile (tramp-compat-make-temp-file filename)) | |
| (args (cddr args))) | |
| ;; We must set `ok-if-already-exists' to t in the first | |
| ;; step, because the temp file has been created already. | |
| (if (eq operation 'copy-file) | |
| (apply operation filename tmpfile t (cdr args)) | |
| (apply operation filename tmpfile t)) | |
| (unwind-protect | |
| (rename-file tmpfile newname (car args)) | |
| ;; Cleanup. | |
| (ignore-errors (delete-file tmpfile))))) | |
| ;; Normally, the handlers must be discarded. | |
| (t (let* ((inhibit-file-name-handlers | |
| (list 'tramp-file-name-handler | |
| 'tramp-completion-file-name-handler | |
| (and (eq inhibit-file-name-operation operation) | |
| inhibit-file-name-handlers))) | |
| (inhibit-file-name-operation operation)) | |
| (apply #'ange-ftp-hook-function operation args))))))) | |
| ;; It must be a `defsubst' in order to push the whole code into | |
| ;; tramp-loaddefs.el. Otherwise, there would be recursive autoloading. | |
| ;;;###tramp-autoload | |
| (defsubst tramp-ftp-file-name-p (filename) | |
| "Check if it's a FILENAME that should be forwarded to Ange-FTP." | |
| (and (tramp-tramp-file-p filename) | |
| (string= (tramp-file-name-method (tramp-dissect-file-name filename)) | |
| tramp-ftp-method))) | |
| ;;;###tramp-autoload | |
| (tramp--with-startup | |
| (add-to-list 'tramp-foreign-file-name-handler-alist | |
| (cons #'tramp-ftp-file-name-p #'tramp-ftp-file-name-handler))) | |
| (add-hook 'tramp-unload-hook | |
| (lambda () | |
| (unload-feature 'tramp-ftp 'force))) | |
| (provide 'tramp-ftp) | |
| ;;; TODO: | |
| ;; * There are no backup files on FTP hosts. | |
| ;;; tramp-ftp.el ends here |
This file has been truncated, but you can view the full file.
This file contains hidden or bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
| ;;; tramp.el --- Transparent Remote Access, Multiple Protocol -*- lexical-binding:t -*- | |
| ;; Copyright (C) 1998-2020 Free Software Foundation, Inc. | |
| ;; Author: Kai Großjohann <[email protected]> | |
| ;; Michael Albinus <[email protected]> | |
| ;; Maintainer: Michael Albinus <[email protected]> | |
| ;; Keywords: comm, processes | |
| ;; Package: tramp | |
| ;; Version: 2.5.0-pre | |
| ;; Package-Requires: ((emacs "25.1")) | |
| ;; Package-Type: multi | |
| ;; URL: https://savannah.gnu.org/projects/tramp | |
| ;; This file is part of GNU Emacs. | |
| ;; GNU Emacs is free software: you can redistribute it and/or modify | |
| ;; it under the terms of the GNU General Public License as published by | |
| ;; the Free Software Foundation, either version 3 of the License, or | |
| ;; (at your option) any later version. | |
| ;; GNU Emacs is distributed in the hope that it will be useful, | |
| ;; but WITHOUT ANY WARRANTY; without even the implied warranty of | |
| ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
| ;; GNU General Public License for more details. | |
| ;; You should have received a copy of the GNU General Public License | |
| ;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. | |
| ;;; Commentary: | |
| ;; This package provides remote file editing, similar to ange-ftp. | |
| ;; The difference is that ange-ftp uses FTP to transfer files between | |
| ;; the local and the remote host, whereas tramp.el uses a combination | |
| ;; of rsh and rcp or other work-alike programs, such as ssh/scp. | |
| ;; | |
| ;; For more detailed instructions, please see the info file. | |
| ;; | |
| ;; Notes: | |
| ;; ----- | |
| ;; | |
| ;; Also see the todo list at the bottom of this file. | |
| ;; | |
| ;; The current version of Tramp can be retrieved from the following URL: | |
| ;; https://ftp.gnu.org/gnu/tramp/ | |
| ;; | |
| ;; There's a mailing list for this, as well. Its name is: | |
| ;; [email protected] | |
| ;; You can use the Web to subscribe, under the following URL: | |
| ;; https://lists.gnu.org/mailman/listinfo/tramp-devel | |
| ;; | |
| ;; For the adventurous, the current development sources are available | |
| ;; via Git. You can find instructions about this at the following URL: | |
| ;; https://savannah.gnu.org/projects/tramp/ | |
| ;; | |
| ;; Don't forget to put on your asbestos longjohns, first! | |
| ;;; Code: | |
| (require 'tramp-compat) | |
| (require 'tramp-integration) | |
| (require 'trampver) | |
| ;; Pacify byte-compiler. | |
| (require 'cl-lib) | |
| (declare-function netrc-parse "netrc") | |
| (defvar auto-save-file-name-transforms) | |
| ;;; User Customizable Internal Variables: | |
| (defgroup tramp nil | |
| "Edit remote files with a combination of ssh, scp, etc." | |
| :group 'files | |
| :group 'comm | |
| :link '(custom-manual "(tramp)Top") | |
| :version "22.1") | |
| (eval-and-compile ;; So it's also available in tramp-loaddefs.el! | |
| (defvar tramp--startup-hook nil | |
| "Forms to be executed at the end of tramp.el.") | |
| (defmacro tramp--with-startup (&rest body) | |
| "Schedule BODY to be executed at the end of tramp.el." | |
| `(add-hook 'tramp--startup-hook (lambda () ,@body)))) | |
| (require 'tramp-loaddefs) | |
| ;; Maybe we need once a real Tramp mode, with key bindings etc. | |
| ;;;###autoload | |
| (defcustom tramp-mode t | |
| "Whether Tramp is enabled. | |
| If it is set to nil, all remote file names are used literally." | |
| :type 'boolean) | |
| (defcustom tramp-verbose 3 | |
| "Verbosity level for Tramp messages. | |
| Any level x includes messages for all levels 1 .. x-1. The levels are | |
| 0 silent (no tramp messages at all) | |
| 1 errors | |
| 2 warnings | |
| 3 connection to remote hosts (default level) | |
| 4 activities | |
| 5 internal | |
| 6 sent and received strings | |
| 7 file caching | |
| 8 connection properties | |
| 9 test commands | |
| 10 traces (huge)." | |
| :type 'integer) | |
| (defcustom tramp-backup-directory-alist nil | |
| "Alist of filename patterns and backup directory names. | |
| Each element looks like (REGEXP . DIRECTORY), with the same meaning like | |
| in `backup-directory-alist'. If a Tramp file is backed up, and DIRECTORY | |
| is a local file name, the backup directory is prepended with Tramp file | |
| name prefix \(method, user, host) of file. | |
| (setq tramp-backup-directory-alist backup-directory-alist) | |
| gives the same backup policy for Tramp files on their hosts like the | |
| policy for local files." | |
| :type '(repeat (cons (regexp :tag "Regexp matching filename") | |
| (directory :tag "Backup directory name")))) | |
| (defcustom tramp-auto-save-directory nil | |
| "Put auto-save files in this directory, if set. | |
| The idea is to use a local directory so that auto-saving is faster. | |
| This setting has precedence over `auto-save-file-name-transforms'." | |
| :type '(choice (const :tag "Use default" nil) | |
| (directory :tag "Auto save directory name"))) | |
| ;; Suppress `shell-file-name' for w32 systems. | |
| (defcustom tramp-encoding-shell | |
| (let (shell-file-name) | |
| (or (tramp-compat-funcall 'w32-shell-name) "/bin/sh")) | |
| "Use this program for encoding and decoding commands on the local host. | |
| This shell is used to execute the encoding and decoding command on the | |
| local host, so if you want to use \"~\" in those commands, you should | |
| choose a shell here which groks tilde expansion. \"/bin/sh\" normally | |
| does not understand tilde expansion. | |
| For encoding and decoding, commands like the following are executed: | |
| /bin/sh -c COMMAND < INPUT > OUTPUT | |
| This variable can be used to change the \"/bin/sh\" part. See the | |
| variable `tramp-encoding-command-switch' for the \"-c\" part. | |
| If the shell must be forced to be interactive, see | |
| `tramp-encoding-command-interactive'. | |
| Note that this variable is not used for remote commands. There are | |
| mechanisms in tramp.el which automatically determine the right shell to | |
| use for the remote host." | |
| :type '(file :must-match t)) | |
| ;; Suppress `shell-file-name' for w32 systems. | |
| (defcustom tramp-encoding-command-switch | |
| (let (shell-file-name) | |
| (if (tramp-compat-funcall 'w32-shell-dos-semantics) "/c" "-c")) | |
| "Use this switch together with `tramp-encoding-shell' for local commands. | |
| See the variable `tramp-encoding-shell' for more information." | |
| :type 'string) | |
| ;; Suppress `shell-file-name' for w32 systems. | |
| (defcustom tramp-encoding-command-interactive | |
| (let (shell-file-name) | |
| (unless (tramp-compat-funcall 'w32-shell-dos-semantics) "-i")) | |
| "Use this switch together with `tramp-encoding-shell' for interactive shells. | |
| See the variable `tramp-encoding-shell' for more information." | |
| :version "24.1" | |
| :type '(choice (const nil) string)) | |
| (defvar tramp-methods nil | |
| "Alist of methods for remote files. | |
| This is a list of entries of the form (NAME PARAM1 PARAM2 ...). | |
| Each NAME stands for a remote access method. Each PARAM is a | |
| pair of the form (KEY VALUE). The following KEYs are defined: | |
| * `tramp-remote-shell' | |
| This specifies the shell to use on the remote host. This | |
| MUST be a Bourne-like shell. It is normally not necessary to | |
| set this to any value other than \"/bin/sh\": Tramp wants to | |
| use a shell which groks tilde expansion, but it can search | |
| for it. Also note that \"/bin/sh\" exists on all Unixen, | |
| this might not be true for the value that you decide to use. | |
| You Have Been Warned. | |
| * `tramp-remote-shell-login' | |
| This specifies the arguments to let `tramp-remote-shell' run | |
| as a login shell. It defaults to (\"-l\"), but some shells, | |
| like ksh, require another argument. See | |
| `tramp-connection-properties' for a way to overwrite the | |
| default value. | |
| * `tramp-remote-shell-args' | |
| For implementation of `shell-command', this specifies the | |
| arguments to let `tramp-remote-shell' run a single command. | |
| * `tramp-login-program' | |
| This specifies the name of the program to use for logging in to the | |
| remote host. This may be the name of rsh or a workalike program, | |
| or the name of telnet or a workalike, or the name of su or a workalike. | |
| * `tramp-login-args' | |
| This specifies a list of lists of arguments to pass to the | |
| above mentioned program. You normally want to put each | |
| argument in an individual string, i.e. | |
| (\"-a\" \"-b\") rather than (\"-a -b\"). | |
| \"%\" followed by a letter are expanded in the arguments as | |
| follows: | |
| - \"%h\" is replaced by the host name | |
| - \"%u\" is replaced by the user name | |
| - \"%p\" is replaced by the port number | |
| - \"%%\" can be used to obtain a literal percent character. | |
| If a sub-list containing \"%h\", \"%u\" or \"%p\" is | |
| unchanged after expansion (i.e. no host, no user or no port | |
| were specified), that sublist is not used. For e.g. | |
| '((\"-a\" \"-b\") (\"-l\" \"%u\")) | |
| that means that (\"-l\" \"%u\") is used only if the user was | |
| specified, and it is thus effectively optional. | |
| Other expansions are: | |
| - \"%l\" is replaced by the login shell `tramp-remote-shell' | |
| and its parameters. | |
| - \"%t\" is replaced by the temporary file name produced with | |
| `tramp-make-tramp-temp-file'. | |
| - \"%k\" indicates the keep-date parameter of a program, if exists. | |
| - \"%c\" adds additional `tramp-ssh-controlmaster-options' | |
| options for the first hop. | |
| The existence of `tramp-login-args', combined with the | |
| absence of `tramp-copy-args', is an indication that the | |
| method is capable of multi-hops. | |
| * `tramp-async-args' | |
| When an asynchronous process is started, we know already that | |
| the connection works. Therefore, we can pass additional | |
| parameters to suppress diagnostic messages, in order not to | |
| tamper the process output. | |
| * `tramp-copy-program' | |
| This specifies the name of the program to use for remotely copying | |
| the file; this might be the absolute filename of scp or the name of | |
| a workalike program. It is always applied on the local host. | |
| * `tramp-copy-args' | |
| This specifies the list of parameters to pass to the above mentioned | |
| program, the hints for `tramp-login-args' also apply here. | |
| * `tramp-copy-env' | |
| A list of environment variables and their values, which will | |
| be set when calling `tramp-copy-program'. | |
| * `tramp-remote-copy-program' | |
| The listener program to be applied on remote side, if needed. | |
| * `tramp-remote-copy-args' | |
| The list of parameters to pass to the listener program, the hints | |
| for `tramp-login-args' also apply here. Additionally, \"%r\" could | |
| be used here and in `tramp-copy-args'. It denotes a randomly | |
| chosen port for the remote listener. | |
| * `tramp-copy-keep-date' | |
| This specifies whether the copying program when the preserves the | |
| timestamp of the original file. | |
| * `tramp-copy-keep-tmpfile' | |
| This specifies whether a temporary local file shall be kept | |
| for optimization reasons (useful for \"rsync\" methods). | |
| * `tramp-copy-recursive' | |
| Whether the operation copies directories recursively. | |
| * `tramp-default-port' | |
| The default port of a method. | |
| * `tramp-tmpdir' | |
| A directory on the remote host for temporary files. If not | |
| specified, \"/tmp\" is taken as default. | |
| * `tramp-connection-timeout' | |
| This is the maximum time to be spent for establishing a connection. | |
| In general, the global default value shall be used, but for | |
| some methods, like \"su\" or \"sudo\", a shorter timeout | |
| might be desirable. | |
| * `tramp-session-timeout' | |
| How long a Tramp connection keeps open before being disconnected. | |
| This is useful for methods like \"su\" or \"sudo\", which | |
| shouldn't run an open connection in the background forever. | |
| * `tramp-case-insensitive' | |
| Whether the remote file system handles file names case insensitive. | |
| Only a non-nil value counts, the default value nil means to | |
| perform further checks on the remote host. See | |
| `tramp-connection-properties' for a way to overwrite this. | |
| * `tramp-mount-args' | |
| * `tramp-copyto-args' | |
| * `tramp-moveto-args' | |
| * `tramp-about-args' | |
| These parameters, a list of list like `tramp-login-args', are used | |
| for the \"rclone\" method, and are appended to the respective | |
| \"rclone\" commands. In general, they shouldn't be changed inside | |
| `tramp-methods'; it is recommended to change their values via | |
| `tramp-connection-properties'. Unlike `tramp-login-args' there is | |
| no pattern replacement. | |
| What does all this mean? Well, you should specify `tramp-login-program' | |
| for all methods; this program is used to log in to the remote site. Then, | |
| there are two ways to actually transfer the files between the local and the | |
| remote side. One way is using an additional scp-like program. If you want | |
| to do this, set `tramp-copy-program' in the method. | |
| Another possibility for file transfer is inline transfer, i.e. the | |
| file is passed through the same buffer used by `tramp-login-program'. In | |
| this case, the file contents need to be protected since the | |
| `tramp-login-program' might use escape codes or the connection might not | |
| be eight-bit clean. Therefore, file contents are encoded for transit. | |
| See the variables `tramp-local-coding-commands' and | |
| `tramp-remote-coding-commands' for details. | |
| So, to summarize: if the method is an out-of-band method, then you | |
| must specify `tramp-copy-program' and `tramp-copy-args'. If it is an | |
| inline method, then these two parameters should be nil. | |
| Notes: | |
| All these arguments can be overwritten by connection properties. | |
| See Info node `(tramp) Predefined connection information'. | |
| When using `su' or `sudo' the phrase \"open connection to a remote | |
| host\" sounds strange, but it is used nevertheless, for consistency. | |
| No connection is opened to a remote host, but `su' or `sudo' is | |
| started on the local host. You should specify a remote host | |
| `localhost' or the name of the local host. Another host name is | |
| useful only in combination with `tramp-default-proxies-alist'.") | |
| (defcustom tramp-default-method | |
| ;; An external copy method seems to be preferred, because it performs | |
| ;; much better for large files, and it hasn't too serious delays | |
| ;; for small files. But it must be ensured that there aren't | |
| ;; permanent password queries. Either a password agent like | |
| ;; "ssh-agent" or "Pageant" shall run, or the optional | |
| ;; password-cache.el or auth-sources.el packages shall be active for | |
| ;; password caching. If we detect that the user is running OpenSSH | |
| ;; 4.0 or newer, we could reuse the connection, which calls also for | |
| ;; an external method. | |
| (cond | |
| ;; PuTTY is installed. We don't take it, if it is installed on a | |
| ;; non-windows system, or pscp from the pssh (parallel ssh) package | |
| ;; is found. | |
| ((and (eq system-type 'windows-nt) (executable-find "pscp")) "pscp") | |
| ;; There is an ssh installation. | |
| ((executable-find "scp") "scp") | |
| ;; Fallback. | |
| (t "ftp")) | |
| "Default method to use for transferring files. | |
| See `tramp-methods' for possibilities. | |
| Also see `tramp-default-method-alist'." | |
| :type 'string) | |
| (defcustom tramp-default-method-alist nil | |
| "Default method to use for specific host/user pairs. | |
| This is an alist of items (HOST USER METHOD). The first matching item | |
| specifies the method to use for a file name which does not specify a | |
| method. HOST and USER are regular expressions or nil, which is | |
| interpreted as a regular expression which always matches. If no entry | |
| matches, the variable `tramp-default-method' takes effect. | |
| If the file name does not specify the user, lookup is done using the | |
| empty string for the user name. | |
| See `tramp-methods' for a list of possibilities for METHOD." | |
| :type '(repeat (list (choice :tag "Host regexp" regexp sexp) | |
| (choice :tag "User regexp" regexp sexp) | |
| (choice :tag "Method name" string (const nil))))) | |
| (defconst tramp-default-method-marker "-" | |
| "Marker for default method in remote file names.") | |
| (defcustom tramp-default-user nil | |
| "Default user to use for transferring files. | |
| It is nil by default; otherwise settings in configuration files like | |
| \"~/.ssh/config\" would be overwritten. Also see `tramp-default-user-alist'. | |
| This variable is regarded as obsolete, and will be removed soon." | |
| :type '(choice (const nil) string)) | |
| (defcustom tramp-default-user-alist nil | |
| "Default user to use for specific method/host pairs. | |
| This is an alist of items (METHOD HOST USER). The first matching item | |
| specifies the user to use for a file name which does not specify a | |
| user. METHOD and HOST are regular expressions or nil, which is | |
| interpreted as a regular expression which always matches. If no entry | |
| matches, the variable `tramp-default-user' takes effect. | |
| If the file name does not specify the method, lookup is done using the | |
| empty string for the method name." | |
| :type '(repeat (list (choice :tag "Method regexp" regexp sexp) | |
| (choice :tag " Host regexp" regexp sexp) | |
| (choice :tag " User name" string (const nil))))) | |
| (defcustom tramp-default-host (system-name) | |
| "Default host to use for transferring files. | |
| Useful for su and sudo methods mostly." | |
| :type 'string) | |
| (defcustom tramp-default-host-alist nil | |
| "Default host to use for specific method/user pairs. | |
| This is an alist of items (METHOD USER HOST). The first matching item | |
| specifies the host to use for a file name which does not specify a | |
| host. METHOD and USER are regular expressions or nil, which is | |
| interpreted as a regular expression which always matches. If no entry | |
| matches, the variable `tramp-default-host' takes effect. | |
| If the file name does not specify the method, lookup is done using the | |
| empty string for the method name." | |
| :version "24.4" | |
| :type '(repeat (list (choice :tag "Method regexp" regexp sexp) | |
| (choice :tag " User regexp" regexp sexp) | |
| (choice :tag " Host name" string (const nil))))) | |
| (defcustom tramp-default-proxies-alist nil | |
| "Route to be followed for specific host/user pairs. | |
| This is an alist of items (HOST USER PROXY). The first matching | |
| item specifies the proxy to be passed for a file name located on | |
| a remote target matching USER@HOST. HOST and USER are regular | |
| expressions, which could also cover a domain (USER%DOMAIN) or | |
| port (HOST#PORT). PROXY must be a Tramp filename without a | |
| localname part. Method and user name on PROXY are optional, | |
| which is interpreted with the default values. | |
| PROXY can contain the patterns %h and %u, which are replaced by | |
| the strings matching HOST or USER (without DOMAIN and PORT parts), | |
| respectively. | |
| If an entry is added while parsing ad-hoc hop definitions, PROXY | |
| carries the non-nil text property `tramp-ad-hoc'. | |
| HOST, USER or PROXY could also be Lisp forms, which will be | |
| evaluated. The result must be a string or nil, which is | |
| interpreted as a regular expression which always matches." | |
| :type '(repeat (list (choice :tag "Host regexp" regexp sexp) | |
| (choice :tag "User regexp" regexp sexp) | |
| (choice :tag " Proxy name" string (const nil))))) | |
| (defcustom tramp-save-ad-hoc-proxies nil | |
| "Whether to save ad-hoc proxies persistently." | |
| :version "24.3" | |
| :type 'boolean) | |
| ;; For some obscure technical reasons, `system-name' on w32 returns | |
| ;; either lower case or upper case letters. See | |
| ;; <https://debbugs.gnu.org/cgi/bugreport.cgi?bug=38079#20>. | |
| (defcustom tramp-restricted-shell-hosts-alist | |
| (when (memq system-type '(windows-nt)) | |
| (list (format "\\`\\(%s\\|%s\\)\\'" | |
| (regexp-quote (downcase (system-name))) | |
| (regexp-quote (upcase (system-name)))))) | |
| "List of hosts, which run a restricted shell. | |
| This is a list of regular expressions, which denote hosts running | |
| a restricted shell like \"rbash\". Those hosts can be used as | |
| proxies only, see `tramp-default-proxies-alist'. If the local | |
| host runs a restricted shell, it shall be added to this list, too." | |
| :version "27.1" | |
| :type '(repeat (regexp :tag "Host regexp"))) | |
| (defcustom tramp-local-host-regexp | |
| (concat | |
| "\\`" | |
| (regexp-opt | |
| (list "localhost" "localhost6" (system-name) "127.0.0.1" "::1") t) | |
| "\\'") | |
| "Host names which are regarded as local host. | |
| If the local host runs a chrooted environment, set this to nil." | |
| :version "27.1" | |
| :type '(choice (const :tag "Chrooted environment" nil) | |
| (regexp :tag "Host regexp"))) | |
| (defvar tramp-completion-function-alist nil | |
| "Alist of methods for remote files. | |
| This is a list of entries of the form \(NAME PAIR1 PAIR2 ...). | |
| Each NAME stands for a remote access method. Each PAIR is of the form | |
| \(FUNCTION FILE). FUNCTION is responsible to extract user names and host | |
| names from FILE for completion. The following predefined FUNCTIONs exists: | |
| * `tramp-parse-rhosts' for \"~/.rhosts\" like files, | |
| * `tramp-parse-shosts' for \"~/.ssh/known_hosts\" like files, | |
| * `tramp-parse-sconfig' for \"~/.ssh/config\" like files, | |
| * `tramp-parse-shostkeys' for \"~/.ssh2/hostkeys/*\" like files, | |
| * `tramp-parse-sknownhosts' for \"~/.ssh2/knownhosts/*\" like files, | |
| * `tramp-parse-hosts' for \"/etc/hosts\" like files, | |
| * `tramp-parse-passwd' for \"/etc/passwd\" like files. | |
| * `tramp-parse-etc-group' for \"/etc/group\" like files. | |
| * `tramp-parse-netrc' for \"~/.netrc\" like files. | |
| * `tramp-parse-putty' for PuTTY registered sessions. | |
| FUNCTION can also be a user defined function. For more details see | |
| the info pages.") | |
| (defconst tramp-echo-mark-marker "_echo" | |
| "String marker to surround echoed commands.") | |
| (defconst tramp-echo-mark-marker-length (length tramp-echo-mark-marker) | |
| "String length of `tramp-echo-mark-marker'.") | |
| (defconst tramp-echo-mark | |
| (concat tramp-echo-mark-marker | |
| (make-string tramp-echo-mark-marker-length ?\b)) | |
| "String mark to be transmitted around shell commands. | |
| Used to separate their echo from the output they produce. This | |
| will only be used if we cannot disable remote echo via stty. | |
| This string must have no effect on the remote shell except for | |
| producing some echo which can later be detected by | |
| `tramp-echoed-echo-mark-regexp'. Using `tramp-echo-mark-marker', | |
| followed by an equal number of backspaces to erase them will | |
| usually suffice.") | |
| (defconst tramp-echoed-echo-mark-regexp | |
| (format "%s\\(\b\\( \b\\)?\\)\\{%d\\}" | |
| tramp-echo-mark-marker tramp-echo-mark-marker-length) | |
| "Regexp which matches `tramp-echo-mark' as it gets echoed by \ | |
| the remote shell.") | |
| (defcustom tramp-local-end-of-line | |
| (if (memq system-type '(windows-nt)) "\r\n" "\n") | |
| "String used for end of line in local processes." | |
| :version "24.1" | |
| :type 'string) | |
| (defcustom tramp-rsh-end-of-line "\n" | |
| "String used for end of line in rsh connections. | |
| I don't think this ever needs to be changed, so please tell me about it | |
| if you need to change this." | |
| :type 'string) | |
| (defcustom tramp-login-prompt-regexp | |
| ".*\\(user\\|login\\)\\( .*\\)?: *" | |
| "Regexp matching login-like prompts. | |
| The regexp should match at end of buffer. | |
| Sometimes the prompt is reported to look like \"login as:\"." | |
| :type 'regexp) | |
| (defcustom tramp-shell-prompt-pattern | |
| ;; Allow a prompt to start right after a ^M since it indeed would be | |
| ;; displayed at the beginning of the line (and Zsh uses it). This | |
| ;; regexp works only for GNU Emacs. | |
| ;; Allow also [] style prompts. They can appear only during | |
| ;; connection initialization; Tramp redefines the prompt afterwards. | |
| (concat "\\(?:^\\|\r\\)" | |
| "[^]#$%>\n]*#?[]#$%>] *\\(\e\\[[0-9;]*[a-zA-Z] *\\)*") | |
| "Regexp to match prompts from remote shell. | |
| Normally, Tramp expects you to configure `shell-prompt-pattern' | |
| correctly, but sometimes it happens that you are connecting to a | |
| remote host which sends a different kind of shell prompt. Therefore, | |
| Tramp recognizes things matched by `shell-prompt-pattern' as prompt, | |
| and also things matched by this variable. The default value of this | |
| variable is similar to the default value of `shell-prompt-pattern', | |
| which should work well in many cases. | |
| This regexp must match both `tramp-initial-end-of-output' and | |
| `tramp-end-of-output'." | |
| :type 'regexp) | |
| (defcustom tramp-password-prompt-regexp | |
| (format "^.*\\(%s\\).*:\^@? *" (regexp-opt password-word-equivalents)) | |
| "Regexp matching password-like prompts. | |
| The regexp should match at end of buffer. | |
| The `sudo' program appears to insert a `^@' character into the prompt." | |
| :version "24.4" | |
| :type 'regexp) | |
| (defcustom tramp-wrong-passwd-regexp | |
| (concat "^.*" | |
| ;; These strings should be on the last line | |
| (regexp-opt '("Permission denied" | |
| "Login incorrect" | |
| "Login Incorrect" | |
| "Connection refused" | |
| "Connection closed" | |
| "Timeout, server not responding." | |
| "Sorry, try again." | |
| "Name or service not known" | |
| "Host key verification failed." | |
| "No supported authentication methods left to try!") | |
| t) | |
| ".*" | |
| "\\|" | |
| "^.*\\(" | |
| ;; Here comes a list of regexes, separated by \\| | |
| "Received signal [0-9]+" | |
| "\\).*") | |
| "Regexp matching a `login failed' message. | |
| The regexp should match at end of buffer." | |
| :type 'regexp) | |
| (defcustom tramp-yesno-prompt-regexp | |
| (concat | |
| (regexp-opt | |
| '("Are you sure you want to continue connecting (yes/no)?" | |
| "Are you sure you want to continue connecting (yes/no/[fingerprint])?") | |
| t) | |
| "\\s-*") | |
| "Regular expression matching all yes/no queries which need to be confirmed. | |
| The confirmation should be done with yes or no. | |
| The regexp should match at end of buffer. | |
| See also `tramp-yn-prompt-regexp'." | |
| :type 'regexp) | |
| (defcustom tramp-yn-prompt-regexp | |
| (concat | |
| (regexp-opt '("Store key in cache? (y/n)" | |
| "Update cached key? (y/n, Return cancels connection)") | |
| t) | |
| "\\s-*") | |
| "Regular expression matching all y/n queries which need to be confirmed. | |
| The confirmation should be done with y or n. | |
| The regexp should match at end of buffer. | |
| See also `tramp-yesno-prompt-regexp'." | |
| :type 'regexp) | |
| (defcustom tramp-terminal-prompt-regexp | |
| (concat "\\(" | |
| "TERM = (.*)" | |
| "\\|" | |
| "Terminal type\\? \\[.*\\]" | |
| "\\)\\s-*") | |
| "Regular expression matching all terminal setting prompts. | |
| The regexp should match at end of buffer. | |
| The answer will be provided by `tramp-action-terminal', which see." | |
| :type 'regexp) | |
| ;; Plink 0.71 has added an additional anti-spoofing prompt after | |
| ;; authentication. This could be discarded with the argument | |
| ;; "-no-antispoof". However, since we don't know which PuTTY | |
| ;; version is installed, we must react interactively. | |
| (defcustom tramp-antispoof-regexp | |
| (regexp-quote "Access granted. Press Return to begin session. ") | |
| "Regular expression matching plink's anti-spoofing message. | |
| The regexp should match at end of buffer." | |
| :version "27.1" | |
| :type 'regexp) | |
| (defcustom tramp-operation-not-permitted-regexp | |
| (concat "\\(" "preserving times.*" "\\|" "set mode" "\\)" ":\\s-*" | |
| (regexp-opt '("Operation not permitted") t)) | |
| "Regular expression matching keep-date problems in (s)cp operations. | |
| Copying has been performed successfully already, so this message can | |
| be ignored safely." | |
| :type 'regexp) | |
| (defcustom tramp-copy-failed-regexp | |
| (concat "\\(.+: " | |
| (regexp-opt '("Permission denied" | |
| "not a regular file" | |
| "is a directory" | |
| "No such file or directory") | |
| t) | |
| "\\)\\s-*") | |
| "Regular expression matching copy problems in (s)cp operations." | |
| :type 'regexp) | |
| (defcustom tramp-process-alive-regexp | |
| "" | |
| "Regular expression indicating a process has finished. | |
| In fact this expression is empty by intention, it will be used only to | |
| check regularly the status of the associated process. | |
| The answer will be provided by `tramp-action-process-alive', | |
| `tramp-action-out-of-band', which see." | |
| :type 'regexp) | |
| (defconst tramp-temp-name-prefix "tramp." | |
| "Prefix to use for temporary files. | |
| If this is a relative file name (such as \"tramp.\"), it is considered | |
| relative to the directory name returned by the function | |
| `tramp-compat-temporary-file-directory' (which see). It may also be an | |
| absolute file name; don't forget to include a prefix for the filename | |
| part, though.") | |
| (defconst tramp-temp-buffer-name " *tramp temp*" | |
| "Buffer name for a temporary buffer. | |
| It shall be used in combination with `generate-new-buffer-name'.") | |
| (defvar tramp-temp-buffer-file-name nil | |
| "File name of a persistent local temporary file. | |
| Useful for \"rsync\" like methods.") | |
| (make-variable-buffer-local 'tramp-temp-buffer-file-name) | |
| (put 'tramp-temp-buffer-file-name 'permanent-local t) | |
| (defcustom tramp-syntax 'default | |
| "Tramp filename syntax to be used. | |
| It can have the following values: | |
| `default' -- Default syntax | |
| `simplified' -- Ange-FTP like syntax | |
| `separate' -- Syntax as defined for XEmacs originally | |
| Do not change the value by `setq', it must be changed only via | |
| Customize. See also `tramp-change-syntax'." | |
| :version "26.1" | |
| :package-version '(Tramp . "2.3.3") | |
| :type '(choice (const :tag "Default" default) | |
| (const :tag "Ange-FTP" simplified) | |
| (const :tag "XEmacs" separate)) | |
| :require 'tramp | |
| :initialize #'custom-initialize-default | |
| :set #'tramp-set-syntax) | |
| (defun tramp-set-syntax (symbol value) | |
| "Set SYMBOL to value VALUE. | |
| Used in user option `tramp-syntax'. There are further variables | |
| to be set, depending on VALUE." | |
| ;; Check allowed values. | |
| (unless (memq value (tramp-syntax-values)) | |
| (tramp-user-error nil "Wrong `tramp-syntax' %s" value)) | |
| ;; Cleanup existing buffers. | |
| (unless (eq (symbol-value symbol) value) | |
| (tramp-cleanup-all-buffers)) | |
| ;; Set the value: | |
| (set-default symbol value) | |
| ;; Reset the depending variables. | |
| (with-no-warnings | |
| (setq tramp-prefix-format (tramp-build-prefix-format) | |
| tramp-prefix-regexp (tramp-build-prefix-regexp) | |
| tramp-method-regexp (tramp-build-method-regexp) | |
| tramp-postfix-method-format (tramp-build-postfix-method-format) | |
| tramp-postfix-method-regexp (tramp-build-postfix-method-regexp) | |
| tramp-prefix-ipv6-format (tramp-build-prefix-ipv6-format) | |
| tramp-prefix-ipv6-regexp (tramp-build-prefix-ipv6-regexp) | |
| tramp-postfix-ipv6-format (tramp-build-postfix-ipv6-format) | |
| tramp-postfix-ipv6-regexp (tramp-build-postfix-ipv6-regexp) | |
| tramp-postfix-host-format (tramp-build-postfix-host-format) | |
| tramp-postfix-host-regexp (tramp-build-postfix-host-regexp) | |
| tramp-remote-file-name-spec-regexp | |
| (tramp-build-remote-file-name-spec-regexp) | |
| tramp-file-name-structure (tramp-build-file-name-structure) | |
| tramp-file-name-regexp (tramp-build-file-name-regexp) | |
| tramp-completion-file-name-regexp | |
| (tramp-build-completion-file-name-regexp))) | |
| ;; Rearrange file name handlers. | |
| (tramp-register-file-name-handlers)) | |
| ;; Initialize the Tramp syntax variables. We want to override initial | |
| ;; value of `tramp-file-name-regexp'. Other Tramp syntax variables | |
| ;; must be initialized as well to proper values. We do not call | |
| ;; `custom-set-variable', this would load Tramp via custom.el. | |
| (tramp--with-startup | |
| (tramp-set-syntax 'tramp-syntax (tramp-compat-tramp-syntax))) | |
| (defun tramp-syntax-values () | |
| "Return possible values of `tramp-syntax', a list." | |
| (let ((values (cdr (get 'tramp-syntax 'custom-type)))) | |
| (setq values (mapcar #'last values) | |
| values (mapcar #'car values)) | |
| values)) | |
| (defun tramp-lookup-syntax (alist) | |
| "Look up a syntax string in ALIST according to `tramp-compat-tramp-syntax'. | |
| Raise an error if `tramp-syntax' is invalid." | |
| (or (cdr (assq (tramp-compat-tramp-syntax) alist)) | |
| (error "Wrong `tramp-syntax' %s" tramp-syntax))) | |
| (defconst tramp-prefix-format-alist | |
| '((default . "/") | |
| (simplified . "/") | |
| (separate . "/[")) | |
| "Alist mapping Tramp syntax to strings beginning Tramp file names.") | |
| (defun tramp-build-prefix-format () | |
| "Return `tramp-prefix-format' according to `tramp-syntax'." | |
| (tramp-lookup-syntax tramp-prefix-format-alist)) | |
| (defvar tramp-prefix-format nil ;Initialized when defining `tramp-syntax'! | |
| "String matching the very beginning of Tramp file names. | |
| Used in `tramp-make-tramp-file-name'.") | |
| (defun tramp-build-prefix-regexp () | |
| "Return `tramp-prefix-regexp'." | |
| (concat "^" (regexp-quote tramp-prefix-format))) | |
| (defvar tramp-prefix-regexp nil ;Initialized when defining `tramp-syntax'! | |
| "Regexp matching the very beginning of Tramp file names. | |
| Should always start with \"^\". Derived from `tramp-prefix-format'.") | |
| (defconst tramp-method-regexp-alist | |
| '((default . "[a-zA-Z0-9-]+") | |
| (simplified . "") | |
| (separate . "[a-zA-Z0-9-]*")) | |
| "Alist mapping Tramp syntax to regexps matching methods identifiers.") | |
| (defun tramp-build-method-regexp () | |
| "Return `tramp-method-regexp' according to `tramp-syntax'." | |
| (tramp-lookup-syntax tramp-method-regexp-alist)) | |
| (defvar tramp-method-regexp nil ;Initialized when defining `tramp-syntax'! | |
| "Regexp matching methods identifiers. | |
| The `ftp' syntax does not support methods.") | |
| (defconst tramp-postfix-method-format-alist | |
| '((default . ":") | |
| (simplified . "") | |
| (separate . "/")) | |
| "Alist mapping Tramp syntax to the delimiter after the method.") | |
| (defun tramp-build-postfix-method-format () | |
| "Return `tramp-postfix-method-format' according to `tramp-syntax'." | |
| (tramp-lookup-syntax tramp-postfix-method-format-alist)) | |
| (defvar tramp-postfix-method-format nil ;Init'd when defining `tramp-syntax'! | |
| "String matching delimiter between method and user or host names. | |
| The `ftp' syntax does not support methods. | |
| Used in `tramp-make-tramp-file-name'.") | |
| (defun tramp-build-postfix-method-regexp () | |
| "Return `tramp-postfix-method-regexp'." | |
| (regexp-quote tramp-postfix-method-format)) | |
| (defvar tramp-postfix-method-regexp nil ;Init'd when defining `tramp-syntax'! | |
| "Regexp matching delimiter between method and user or host names. | |
| Derived from `tramp-postfix-method-format'.") | |
| (defconst tramp-user-regexp "[^/|: \t]+" | |
| "Regexp matching user names.") | |
| (defconst tramp-prefix-domain-format "%" | |
| "String matching delimiter between user and domain names.") | |
| (defconst tramp-prefix-domain-regexp (regexp-quote tramp-prefix-domain-format) | |
| "Regexp matching delimiter between user and domain names. | |
| Derived from `tramp-prefix-domain-format'.") | |
| (defconst tramp-domain-regexp "[a-zA-Z0-9_.-]+" | |
| "Regexp matching domain names.") | |
| (defconst tramp-user-with-domain-regexp | |
| (concat "\\(" tramp-user-regexp "\\)" | |
| tramp-prefix-domain-regexp | |
| "\\(" tramp-domain-regexp "\\)") | |
| "Regexp matching user names with domain names.") | |
| (defconst tramp-postfix-user-format "@" | |
| "String matching delimiter between user and host names. | |
| Used in `tramp-make-tramp-file-name'.") | |
| (defconst tramp-postfix-user-regexp (regexp-quote tramp-postfix-user-format) | |
| "Regexp matching delimiter between user and host names. | |
| Derived from `tramp-postfix-user-format'.") | |
| (defconst tramp-host-regexp "[a-zA-Z0-9_.%-]+" | |
| "Regexp matching host names.") | |
| (defconst tramp-prefix-ipv6-format-alist | |
| '((default . "[") | |
| (simplified . "[") | |
| (separate . "")) | |
| "Alist mapping Tramp syntax to strings prefixing IPv6 addresses.") | |
| (defun tramp-build-prefix-ipv6-format () | |
| "Return `tramp-prefix-ipv6-format' according to `tramp-syntax'." | |
| (tramp-lookup-syntax tramp-prefix-ipv6-format-alist)) | |
| (defvar tramp-prefix-ipv6-format nil ;Initialized when defining `tramp-syntax'! | |
| "String matching left hand side of IPv6 addresses. | |
| Used in `tramp-make-tramp-file-name'.") | |
| (defun tramp-build-prefix-ipv6-regexp () | |
| "Return `tramp-prefix-ipv6-regexp'." | |
| (regexp-quote tramp-prefix-ipv6-format)) | |
| (defvar tramp-prefix-ipv6-regexp nil ;Initialized when defining `tramp-syntax'! | |
| "Regexp matching left hand side of IPv6 addresses. | |
| Derived from `tramp-prefix-ipv6-format'.") | |
| ;; The following regexp is a bit sloppy. But it shall serve our | |
| ;; purposes. It covers also IPv4 mapped IPv6 addresses, like in | |
| ;; "::ffff:192.168.0.1". | |
| (defconst tramp-ipv6-regexp "\\(?:[a-zA-Z0-9]*:\\)+[a-zA-Z0-9.]+" | |
| "Regexp matching IPv6 addresses.") | |
| (defconst tramp-postfix-ipv6-format-alist | |
| '((default . "]") | |
| (simplified . "]") | |
| (separate . "")) | |
| "Alist mapping Tramp syntax to suffix for IPv6 addresses.") | |
| (defun tramp-build-postfix-ipv6-format () | |
| "Return `tramp-postfix-ipv6-format' according to `tramp-syntax'." | |
| (tramp-lookup-syntax tramp-postfix-ipv6-format-alist)) | |
| (defvar tramp-postfix-ipv6-format nil ;Initialized when defining `tramp-syntax'! | |
| "String matching right hand side of IPv6 addresses. | |
| Used in `tramp-make-tramp-file-name'.") | |
| (defun tramp-build-postfix-ipv6-regexp () | |
| "Return `tramp-postfix-ipv6-regexp'." | |
| (regexp-quote tramp-postfix-ipv6-format)) | |
| (defvar tramp-postfix-ipv6-regexp nil ;Initialized when defining `tramp-syntax'! | |
| "Regexp matching right hand side of IPv6 addresses. | |
| Derived from `tramp-postfix-ipv6-format'.") | |
| (defconst tramp-prefix-port-format "#" | |
| "String matching delimiter between host names and port numbers.") | |
| (defconst tramp-prefix-port-regexp (regexp-quote tramp-prefix-port-format) | |
| "Regexp matching delimiter between host names and port numbers. | |
| Derived from `tramp-prefix-port-format'.") | |
| (defconst tramp-port-regexp "[0-9]+" | |
| "Regexp matching port numbers.") | |
| (defconst tramp-host-with-port-regexp | |
| (concat "\\(" tramp-host-regexp "\\)" | |
| tramp-prefix-port-regexp | |
| "\\(" tramp-port-regexp "\\)") | |
| "Regexp matching host names with port numbers.") | |
| (defconst tramp-postfix-hop-format "|" | |
| "String matching delimiter after ad-hoc hop definitions.") | |
| (defconst tramp-postfix-hop-regexp (regexp-quote tramp-postfix-hop-format) | |
| "Regexp matching delimiter after ad-hoc hop definitions. | |
| Derived from `tramp-postfix-hop-format'.") | |
| (defconst tramp-postfix-host-format-alist | |
| '((default . ":") | |
| (simplified . ":") | |
| (separate . "]")) | |
| "Alist mapping Tramp syntax to strings between host and local names.") | |
| (defun tramp-build-postfix-host-format () | |
| "Return `tramp-postfix-host-format' according to `tramp-syntax'." | |
| (tramp-lookup-syntax tramp-postfix-host-format-alist)) | |
| (defvar tramp-postfix-host-format nil ;Initialized when defining `tramp-syntax'! | |
| "String matching delimiter between host names and localnames. | |
| Used in `tramp-make-tramp-file-name'.") | |
| (defun tramp-build-postfix-host-regexp () | |
| "Return `tramp-postfix-host-regexp'." | |
| (regexp-quote tramp-postfix-host-format)) | |
| (defvar tramp-postfix-host-regexp nil ;Initialized when defining `tramp-syntax'! | |
| "Regexp matching delimiter between host names and localnames. | |
| Derived from `tramp-postfix-host-format'.") | |
| (defconst tramp-localname-regexp "[^\n\r]*\\'" | |
| "Regexp matching localnames.") | |
| (defconst tramp-unknown-id-string "UNKNOWN" | |
| "String used to denote an unknown user or group.") | |
| (defconst tramp-unknown-id-integer -1 | |
| "Integer used to denote an unknown user or group.") | |
| ;;; File name format: | |
| (defun tramp-build-remote-file-name-spec-regexp () | |
| "Construct a regexp matching a Tramp file name for a Tramp syntax. | |
| It is expected, that `tramp-syntax' has the proper value." | |
| (concat | |
| "\\(" tramp-method-regexp "\\)" tramp-postfix-method-regexp | |
| "\\(?:" "\\(" tramp-user-regexp "\\)" tramp-postfix-user-regexp "\\)?" | |
| "\\(" "\\(?:" tramp-host-regexp "\\|" | |
| tramp-prefix-ipv6-regexp "\\(?:" tramp-ipv6-regexp "\\)?" | |
| tramp-postfix-ipv6-regexp "\\)" | |
| "\\(?:" tramp-prefix-port-regexp tramp-port-regexp "\\)?" "\\)?")) | |
| (defvar tramp-remote-file-name-spec-regexp | |
| nil ;Initialized when defining `tramp-syntax'! | |
| "Regular expression matching a Tramp file name between prefix and postfix.") | |
| (defun tramp-build-file-name-structure () | |
| "Construct the Tramp file name structure for a Tramp syntax. | |
| It is expected, that `tramp-syntax' has the proper value. | |
| See `tramp-file-name-structure'." | |
| (list | |
| (concat | |
| tramp-prefix-regexp | |
| "\\(" "\\(?:" tramp-remote-file-name-spec-regexp | |
| tramp-postfix-hop-regexp "\\)+" "\\)?" | |
| tramp-remote-file-name-spec-regexp tramp-postfix-host-regexp | |
| "\\(" tramp-localname-regexp "\\)") | |
| 5 6 7 8 1)) | |
| (defvar tramp-file-name-structure nil ;Initialized when defining `tramp-syntax'! | |
| "List of six elements (REGEXP METHOD USER HOST FILE HOP), detailing \ | |
| the Tramp file name structure. | |
| The first element REGEXP is a regular expression matching a Tramp file | |
| name. The regex should contain parentheses around the method name, | |
| the user name, the host name, and the file name parts. | |
| The second element METHOD is a number, saying which pair of | |
| parentheses matches the method name. The third element USER is | |
| similar, but for the user name. The fourth element HOST is similar, | |
| but for the host name. The fifth element FILE is for the file name. | |
| The last element HOP is the ad-hoc hop definition, which could be a | |
| cascade of several hops. | |
| These numbers are passed directly to `match-string', which see. That | |
| means the opening parentheses are counted to identify the pair. | |
| See also `tramp-file-name-regexp'.") | |
| (defun tramp-build-file-name-regexp () | |
| "Return `tramp-file-name-regexp'." | |
| (car tramp-file-name-structure)) | |
| ;;;###autoload | |
| (defconst tramp-initial-file-name-regexp "\\`/[^/:]+:[^/:]*:" | |
| "Value for `tramp-file-name-regexp' for autoload. | |
| It must match the initial `tramp-syntax' settings.") | |
| ;;;###autoload | |
| (defvar tramp-file-name-regexp tramp-initial-file-name-regexp | |
| "Regular expression matching file names handled by Tramp. | |
| This regexp should match Tramp file names but no other file | |
| names. When calling `tramp-register-file-name-handlers', the | |
| initial value is overwritten by the car of `tramp-file-name-structure'.") | |
| ;;;###autoload | |
| (defcustom tramp-ignored-file-name-regexp nil | |
| "Regular expression matching file names that are not under Tramp's control." | |
| :version "27.1" | |
| :type '(choice (const nil) regexp)) | |
| (defconst tramp-completion-file-name-regexp-default | |
| (concat | |
| "\\`/\\(" | |
| ;; Optional multi hop. | |
| "\\([^/|:]+:[^/|:]*|\\)*" | |
| ;; Last hop. | |
| (if (memq system-type '(cygwin windows-nt)) | |
| ;; The method is either "-", or at least two characters. | |
| "\\(-\\|[^/|:]\\{2,\\}\\)" | |
| ;; At least one character for method. | |
| "[^/|:]+") | |
| ;; Method separator, user name and host name. | |
| "\\(:[^/|:]*\\)?" | |
| "\\)?\\'") | |
| "Value for `tramp-completion-file-name-regexp' for default remoting. | |
| See `tramp-file-name-structure' for more explanations. | |
| On W32 systems, the volume letter must be ignored.") | |
| (defconst tramp-completion-file-name-regexp-simplified | |
| (concat | |
| "\\`/\\(" | |
| ;; Optional multi hop. | |
| "\\([^/|:]*|\\)*" | |
| ;; Last hop. | |
| (if (memq system-type '(cygwin windows-nt)) | |
| ;; At least two characters. | |
| "[^/|:]\\{2,\\}" | |
| ;; At least one character. | |
| "[^/|:]+") | |
| "\\)?\\'") | |
| "Value for `tramp-completion-file-name-regexp' for simplified style remoting. | |
| See `tramp-file-name-structure' for more explanations. | |
| On W32 systems, the volume letter must be ignored.") | |
| (defconst tramp-completion-file-name-regexp-separate | |
| "\\`/\\(\\[[^]]*\\)?\\'" | |
| "Value for `tramp-completion-file-name-regexp' for separate remoting. | |
| See `tramp-file-name-structure' for more explanations.") | |
| (defconst tramp-completion-file-name-regexp-alist | |
| `((default . ,tramp-completion-file-name-regexp-default) | |
| (simplified . ,tramp-completion-file-name-regexp-simplified) | |
| (separate . ,tramp-completion-file-name-regexp-separate)) | |
| "Alist mapping incomplete Tramp file names.") | |
| (defun tramp-build-completion-file-name-regexp () | |
| "Return `tramp-completion-file-name-regexp' according to `tramp-syntax'." | |
| (tramp-lookup-syntax tramp-completion-file-name-regexp-alist)) | |
| (defvar tramp-completion-file-name-regexp | |
| nil ;Initialized when defining `tramp-syntax'! | |
| "Regular expression matching file names handled by Tramp completion. | |
| This regexp should match partial Tramp file names only. | |
| Please note that the entry in `file-name-handler-alist' is made when | |
| this file \(tramp.el) is loaded. This means that this variable must be set | |
| before loading tramp.el. Alternatively, `file-name-handler-alist' can be | |
| updated after changing this variable. | |
| Also see `tramp-file-name-structure'.") | |
| ;;;###autoload | |
| (defconst tramp-autoload-file-name-regexp | |
| (concat | |
| "\\`/" | |
| (if (memq system-type '(cygwin windows-nt)) | |
| ;; The method is either "-", or at least two characters. | |
| "\\(-\\|[^/|:]\\{2,\\}\\)" | |
| ;; At least one character for method. | |
| "[^/|:]+") | |
| ":") | |
| "Regular expression matching file names handled by Tramp autoload. | |
| It must match the initial `tramp-syntax' settings. It should not | |
| match file names at root of the underlying local file system, | |
| like \"/sys\" or \"/C:\".") | |
| ;; Chunked sending kludge. We set this to 500 for black-listed constellations | |
| ;; known to have a bug in `process-send-string'; some ssh connections appear | |
| ;; to drop bytes when data is sent too quickly. There is also a connection | |
| ;; buffer local variable, which is computed depending on remote host properties | |
| ;; when `tramp-chunksize' is zero or nil. | |
| (defcustom tramp-chunksize (when (memq system-type '(hpux)) 500) | |
| ;; Parentheses in docstring starting at beginning of line are escaped. | |
| ;; Fontification is messed up when | |
| ;; `open-paren-in-column-0-is-defun-start' set to t. | |
| "If non-nil, chunksize for sending input to local process. | |
| It is necessary only on systems which have a buggy `process-send-string' | |
| implementation. The necessity, whether this variable must be set, can be | |
| checked via the following code: | |
| (with-temp-buffer | |
| (let* ((user \"xxx\") (host \"yyy\") | |
| (init 0) (step 50) | |
| (sent init) (received init)) | |
| (while (= sent received) | |
| (setq sent (+ sent step)) | |
| (erase-buffer) | |
| (let ((proc (start-process (buffer-name) (current-buffer) | |
| \"ssh\" \"-l\" user host \"wc\" \"-c\"))) | |
| (when (process-live-p proc) | |
| (process-send-string proc (make-string sent ?\\ )) | |
| (process-send-eof proc) | |
| (process-send-eof proc)) | |
| (while (not (progn (goto-char (point-min)) | |
| (re-search-forward \"\\\\w+\" (point-max) t))) | |
| (accept-process-output proc 1)) | |
| (when (process-live-p proc) | |
| (setq received (string-to-number (match-string 0))) | |
| (delete-process proc) | |
| (message \"Bytes sent: %s\\tBytes received: %s\" sent received) | |
| (sit-for 0)))) | |
| (if (> sent (+ init step)) | |
| (message \"You should set `tramp-chunksize' to a maximum of %s\" | |
| (- sent step)) | |
| (message \"Test does not work\") | |
| (display-buffer (current-buffer)) | |
| (sit-for 30)))) | |
| In the Emacs normally running Tramp, evaluate the above code | |
| \(replace \"xxx\" and \"yyy\" by the remote user and host name, | |
| respectively). You can do this, for example, by pasting it into | |
| the `*scratch*' buffer and then hitting `C-j' with the cursor after the | |
| last closing parenthesis. Note that it works only if you have configured | |
| \"ssh\" to run without password query, see ssh-agent(1). | |
| You will see the number of bytes sent successfully to the remote host. | |
| If that number exceeds 1000, you can stop the execution by hitting | |
| `C-g', because your Emacs is likely clean. | |
| When it is necessary to set `tramp-chunksize', you might consider to | |
| use an out-of-the-band method \(like \"scp\") instead of an internal one | |
| \(like \"ssh\"), because setting `tramp-chunksize' to non-nil decreases | |
| performance. | |
| If your Emacs is buggy, the code stops and gives you an indication | |
| about the value `tramp-chunksize' should be set. Maybe you could just | |
| experiment a bit, e.g. changing the values of `init' and `step' | |
| in the third line of the code. | |
| Please raise a bug report via \\[tramp-bug] if your system needs | |
| this variable to be set as well." | |
| :type '(choice (const nil) integer)) | |
| ;; Logging in to a remote host normally requires obtaining a pty. But | |
| ;; Emacs on macOS has process-connection-type set to nil by default, | |
| ;; so on those systems Tramp doesn't obtain a pty. Here, we allow | |
| ;; for an override of the system default. | |
| (defcustom tramp-process-connection-type t | |
| "Overrides `process-connection-type' for connections from Tramp. | |
| Tramp binds `process-connection-type' to the value given here before | |
| opening a connection to a remote host." | |
| :type '(choice (const nil) (const t) (const pty))) | |
| (defcustom tramp-connection-timeout 60 | |
| "Defines the max time to wait for establishing a connection (in seconds). | |
| This can be overwritten for different connection types in `tramp-methods'. | |
| The timeout does not include the time reading a password." | |
| :version "24.4" | |
| :type 'integer) | |
| (defcustom tramp-connection-min-time-diff 5 | |
| "Defines seconds between two consecutive connection attempts. | |
| This is necessary as self defense mechanism, in order to avoid | |
| yo-yo connection attempts when the remote host is unavailable. | |
| A value of 0 or nil suppresses this check. This might be | |
| necessary, when several out-of-order copy operations are | |
| performed, or when several asynchronous processes will be started | |
| in a short time frame. In those cases it is recommended to | |
| let-bind this variable." | |
| :version "24.4" | |
| :type '(choice (const nil) integer)) | |
| (defcustom tramp-completion-reread-directory-timeout 10 | |
| "Defines seconds since last remote command before rereading a directory. | |
| A remote directory might have changed its contents. In order to | |
| make it visible during file name completion in the minibuffer, | |
| Tramp flushes its cache and rereads the directory contents when | |
| more than `tramp-completion-reread-directory-timeout' seconds | |
| have been gone since last remote command execution. A value of t | |
| would require an immediate reread during filename completion, nil | |
| means to use always cached values for the directory contents." | |
| :type '(choice (const nil) (const t) integer)) | |
| ;;; Internal Variables: | |
| (defvar tramp-current-connection nil | |
| "Last connection timestamp. | |
| It is a cons cell of the actual `tramp-file-name-structure', and | |
| the (optional) timestamp of last activity on this connection.") | |
| (defvar tramp-password-save-function nil | |
| "Password save function. | |
| Will be called once the password has been verified by successful | |
| authentication.") | |
| (defconst tramp-completion-file-name-handler-alist | |
| '((file-name-all-completions | |
| . tramp-completion-handle-file-name-all-completions) | |
| (file-name-completion . tramp-completion-handle-file-name-completion)) | |
| "Alist of completion handler functions. | |
| Used for file names matching `tramp-completion-file-name-regexp'. | |
| Operations not mentioned here will be handled by Tramp's file | |
| name handler functions, or the normal Emacs functions.") | |
| ;; Handlers for foreign methods, like FTP or SMB, shall be plugged here. | |
| (defvar tramp-foreign-file-name-handler-alist nil | |
| "Alist of elements (FUNCTION . HANDLER) for foreign methods handled specially. | |
| If (FUNCTION FILENAME) returns non-nil, then all I/O on that file is done by | |
| calling HANDLER.") | |
| ;;; Internal functions which must come first: | |
| ;; Conversion functions between external representation and | |
| ;; internal data structure. Convenience functions for internal | |
| ;; data structure. | |
| ;; The basic structure for remote file names. We use a list :type, | |
| ;; in order to be compatible with Emacs 25. | |
| (cl-defstruct (tramp-file-name (:type list) :named) | |
| method user domain host port localname hop) | |
| (defun tramp-file-name-user-domain (vec) | |
| "Return user and domain components of VEC." | |
| (when (or (tramp-file-name-user vec) (tramp-file-name-domain vec)) | |
| (concat (tramp-file-name-user vec) | |
| (and (tramp-file-name-domain vec) | |
| tramp-prefix-domain-format) | |
| (tramp-file-name-domain vec)))) | |
| (defun tramp-file-name-host-port (vec) | |
| "Return host and port components of VEC." | |
| (when (or (tramp-file-name-host vec) (tramp-file-name-port vec)) | |
| (concat (tramp-file-name-host vec) | |
| (and (tramp-file-name-port vec) | |
| tramp-prefix-port-format) | |
| (tramp-file-name-port vec)))) | |
| (defun tramp-file-name-port-or-default (vec) | |
| "Return port component of VEC. | |
| If nil, return `tramp-default-port'." | |
| (or (tramp-file-name-port vec) | |
| (tramp-get-method-parameter vec 'tramp-default-port))) | |
| ;; Comparision of file names is performed by `tramp-equal-remote'. | |
| (defun tramp-file-name-equal-p (vec1 vec2) | |
| "Check, whether VEC1 and VEC2 denote the same `tramp-file-name'." | |
| (and (tramp-file-name-p vec1) (tramp-file-name-p vec2) | |
| (string-equal (tramp-file-name-method vec1) | |
| (tramp-file-name-method vec2)) | |
| (string-equal (tramp-file-name-user-domain vec1) | |
| (tramp-file-name-user-domain vec2)) | |
| (string-equal (tramp-file-name-host-port vec1) | |
| (tramp-file-name-host-port vec2)))) | |
| (defun tramp-get-method-parameter (vec param) | |
| "Return the method parameter PARAM. | |
| If VEC is a vector, check first in connection properties. | |
| Afterwards, check in `tramp-methods'. If the `tramp-methods' | |
| entry does not exist, return nil." | |
| (let ((hash-entry | |
| (replace-regexp-in-string "^tramp-" "" (symbol-name param)))) | |
| (if (tramp-connection-property-p vec hash-entry) | |
| ;; We use the cached property. | |
| (tramp-get-connection-property vec hash-entry nil) | |
| ;; Use the static value from `tramp-methods'. | |
| (when-let ((methods-entry | |
| (assoc | |
| param (assoc (tramp-file-name-method vec) tramp-methods)))) | |
| (cadr methods-entry))))) | |
| ;; The localname can be quoted with "/:". Extract this. | |
| (defun tramp-file-name-unquote-localname (vec) | |
| "Return unquoted localname component of VEC." | |
| (tramp-compat-file-name-unquote (tramp-file-name-localname vec))) | |
| (defun tramp-tramp-file-p (name) | |
| "Return t if NAME is a string with Tramp file name syntax." | |
| (and tramp-mode (stringp name) | |
| ;; No "/:" and "/c:". This is not covered by `tramp-file-name-regexp'. | |
| (not (string-match-p | |
| (if (memq system-type '(cygwin windows-nt)) | |
| "^/[[:alpha:]]?:" "^/:") | |
| name)) | |
| ;; Excluded file names. | |
| (or (null tramp-ignored-file-name-regexp) | |
| (not (string-match-p tramp-ignored-file-name-regexp name))) | |
| (string-match-p tramp-file-name-regexp name) | |
| t)) | |
| ;; This function bypasses the file name handler approach. It is NOT | |
| ;; recommended to use it in any package if not absolutely necessary. | |
| ;; However, it is more performant than `file-local-name', and might be | |
| ;; useful where performance matters, like in operations over a bulk | |
| ;; list of file names. | |
| (defun tramp-file-local-name (name) | |
| "Return the local name component of NAME. | |
| This function removes from NAME the specification of the remote | |
| host and the method of accessing the host, leaving only the part | |
| that identifies NAME locally on the remote system. If NAME does | |
| not match `tramp-file-name-regexp', just `file-local-name' is | |
| called. The returned file name can be used directly as argument | |
| of `process-file', `start-file-process', or `shell-command'." | |
| (or (and (tramp-tramp-file-p name) | |
| (string-match (nth 0 tramp-file-name-structure) name) | |
| (match-string (nth 4 tramp-file-name-structure) name)) | |
| (tramp-compat-file-local-name name))) | |
| ;; The localname can be quoted with "/:". Extract this. | |
| (defun tramp-unquote-file-local-name (name) | |
| "Return unquoted localname of NAME." | |
| (tramp-compat-file-name-unquote (tramp-file-local-name name))) | |
| (defun tramp-find-method (method user host) | |
| "Return the right method string to use depending on USER and HOST. | |
| This is METHOD, if non-nil. Otherwise, do a lookup in | |
| `tramp-default-method-alist' and `tramp-default-method'." | |
| (when (and method | |
| (or (string-equal method "") | |
| (string-equal method tramp-default-method-marker))) | |
| (setq method nil)) | |
| (let ((result | |
| (or method | |
| (let ((choices tramp-default-method-alist) | |
| lmethod item) | |
| (while choices | |
| (setq item (pop choices)) | |
| (when (and (string-match-p (or (nth 0 item) "") (or host "")) | |
| (string-match-p (or (nth 1 item) "") (or user ""))) | |
| (setq lmethod (nth 2 item) | |
| choices nil))) | |
| lmethod) | |
| tramp-default-method))) | |
| ;; We must mark, whether a default value has been used. | |
| (if (or method (null result)) | |
| result | |
| (propertize result 'tramp-default t)))) | |
| (defun tramp-find-user (method user host) | |
| "Return the right user string to use depending on METHOD and HOST. | |
| This is USER, if non-nil. Otherwise, do a lookup in | |
| `tramp-default-user-alist' and `tramp-default-user'." | |
| (let ((result | |
| (or user | |
| (let ((choices tramp-default-user-alist) | |
| luser item) | |
| (while choices | |
| (setq item (pop choices)) | |
| (when (and (string-match-p (or (nth 0 item) "") (or method "")) | |
| (string-match-p (or (nth 1 item) "") (or host ""))) | |
| (setq luser (nth 2 item) | |
| choices nil))) | |
| luser) | |
| tramp-default-user))) | |
| ;; We must mark, whether a default value has been used. | |
| (if (or user (null result)) | |
| result | |
| (propertize result 'tramp-default t)))) | |
| (defun tramp-find-host (method user host) | |
| "Return the right host string to use depending on METHOD and USER. | |
| This is HOST, if non-nil. Otherwise, do a lookup in | |
| `tramp-default-host-alist' and `tramp-default-host'." | |
| (let ((result | |
| (or (and (> (length host) 0) host) | |
| (let ((choices tramp-default-host-alist) | |
| lhost item) | |
| (while choices | |
| (setq item (pop choices)) | |
| (when (and (string-match-p (or (nth 0 item) "") (or method "")) | |
| (string-match-p (or (nth 1 item) "") (or user ""))) | |
| (setq lhost (nth 2 item) | |
| choices nil))) | |
| lhost) | |
| tramp-default-host))) | |
| ;; We must mark, whether a default value has been used. | |
| (if (or (> (length host) 0) (null result)) | |
| result | |
| (propertize result 'tramp-default t)))) | |
| (defun tramp-dissect-file-name (name &optional nodefault) | |
| "Return a `tramp-file-name' structure of NAME, a remote file name. | |
| The structure consists of method, user, domain, host, port, | |
| localname (file name on remote host), and hop. | |
| Unless NODEFAULT is non-nil, method, user and host are expanded | |
| to their default values. For the other file name parts, no | |
| default values are used." | |
| (save-match-data | |
| (unless (tramp-tramp-file-p name) | |
| (tramp-user-error nil "Not a Tramp file name: \"%s\"" name)) | |
| (if (not (string-match (nth 0 tramp-file-name-structure) name)) | |
| (error "`tramp-file-name-structure' didn't match!") | |
| (let ((method (match-string (nth 1 tramp-file-name-structure) name)) | |
| (user (match-string (nth 2 tramp-file-name-structure) name)) | |
| (host (match-string (nth 3 tramp-file-name-structure) name)) | |
| (localname (match-string (nth 4 tramp-file-name-structure) name)) | |
| (hop (match-string (nth 5 tramp-file-name-structure) name)) | |
| domain port v) | |
| (when user | |
| (when (string-match tramp-user-with-domain-regexp user) | |
| (setq domain (match-string 2 user) | |
| user (match-string 1 user)))) | |
| (when host | |
| (when (string-match tramp-host-with-port-regexp host) | |
| (setq port (match-string 2 host) | |
| host (match-string 1 host))) | |
| (when (string-match tramp-prefix-ipv6-regexp host) | |
| (setq host (replace-match "" nil t host))) | |
| (when (string-match tramp-postfix-ipv6-regexp host) | |
| (setq host (replace-match "" nil t host)))) | |
| (unless nodefault | |
| (when hop | |
| (setq v (tramp-dissect-hop-name hop) | |
| hop (and hop (tramp-make-tramp-hop-name v)))) | |
| (let ((tramp-default-host | |
| (or (and v (not (string-match-p "%h" (tramp-file-name-host v))) | |
| (tramp-file-name-host v)) | |
| tramp-default-host))) | |
| (setq method (tramp-find-method method user host) | |
| user (tramp-find-user method user host) | |
| host (tramp-find-host method user host) | |
| hop | |
| (and hop | |
| (format-spec hop (format-spec-make ?h host ?u user)))))) | |
| ;; Return result. | |
| (prog1 | |
| (setq v (make-tramp-file-name | |
| :method method :user user :domain domain :host host | |
| :port port :localname localname :hop hop)) | |
| ;; The method must be known. | |
| (unless (or nodefault non-essential | |
| (string-equal method tramp-default-method-marker) | |
| (assoc method tramp-methods)) | |
| (tramp-user-error | |
| v "Method `%s' is not known." method)) | |
| ;; Only some methods from tramp-sh.el do support multi-hops. | |
| (when (and | |
| hop | |
| (or (not (tramp-get-method-parameter v 'tramp-login-program)) | |
| (tramp-get-method-parameter v 'tramp-copy-program))) | |
| (tramp-user-error | |
| v "Method `%s' is not supported for multi-hops." method))))))) | |
| (defun tramp-dissect-hop-name (name &optional nodefault) | |
| "Return a `tramp-file-name' structure of `hop' part of NAME. | |
| See `tramp-dissect-file-name' for details." | |
| (let ((v (tramp-dissect-file-name | |
| (concat tramp-prefix-format | |
| (replace-regexp-in-string | |
| (concat tramp-postfix-hop-regexp "$") | |
| tramp-postfix-host-format name)) | |
| nodefault))) | |
| ;; Only some methods from tramp-sh.el do support multi-hops. | |
| (when (or (not (tramp-get-method-parameter v 'tramp-login-program)) | |
| (tramp-get-method-parameter v 'tramp-copy-program)) | |
| (tramp-user-error | |
| v "Method `%s' is not supported for multi-hops." | |
| (tramp-file-name-method v))) | |
| ;; Return result. | |
| v)) | |
| (defun tramp-buffer-name (vec) | |
| "A name for the connection buffer VEC." | |
| (let ((method (tramp-file-name-method vec)) | |
| (user-domain (tramp-file-name-user-domain vec)) | |
| (host-port (tramp-file-name-host-port vec))) | |
| (if (not (zerop (length user-domain))) | |
| (format "*tramp/%s %s@%s*" method user-domain host-port) | |
| (format "*tramp/%s %s*" method host-port)))) | |
| (defun tramp-make-tramp-file-name (&rest args) | |
| "Construct a Tramp file name from ARGS. | |
| ARGS could have two different signatures. The first one is of | |
| type (VEC &optional LOCALNAME HOP). | |
| If LOCALNAME is nil, the value in VEC is used. If it is a | |
| symbol, a null localname will be used. Otherwise, LOCALNAME is | |
| expected to be a string, which will be used. | |
| If HOP is nil, the value in VEC is used. If it is a symbol, a | |
| null hop will be used. Otherwise, HOP is expected to be a | |
| string, which will be used. | |
| The other signature exists for backward compatibility. It has | |
| the form (METHOD USER DOMAIN HOST PORT LOCALNAME &optional HOP)." | |
| (let (method user domain host port localname hop) | |
| (cond | |
| ((tramp-file-name-p (car args)) | |
| (setq method (tramp-file-name-method (car args)) | |
| user (tramp-file-name-user (car args)) | |
| domain (tramp-file-name-domain (car args)) | |
| host (tramp-file-name-host (car args)) | |
| port (tramp-file-name-port (car args)) | |
| localname (tramp-file-name-localname (car args)) | |
| hop (tramp-file-name-hop (car args))) | |
| (when (cadr args) | |
| (setq localname (and (stringp (cadr args)) (cadr args)))) | |
| (when (cl-caddr args) | |
| (setq hop (and (stringp (cl-caddr args)) (cl-caddr args))))) | |
| (t (setq method (nth 0 args) | |
| user (nth 1 args) | |
| domain (nth 2 args) | |
| host (nth 3 args) | |
| port (nth 4 args) | |
| localname (nth 5 args) | |
| hop (nth 6 args)))) | |
| ;; Unless `tramp-syntax' is `simplified', we need a method. | |
| (when (and (not (zerop (length tramp-postfix-method-format))) | |
| (zerop (length method))) | |
| (signal 'wrong-type-argument (list #'stringp method))) | |
| (concat tramp-prefix-format hop | |
| (unless (zerop (length tramp-postfix-method-format)) | |
| (concat method tramp-postfix-method-format)) | |
| user | |
| (unless (zerop (length domain)) | |
| (concat tramp-prefix-domain-format domain)) | |
| (unless (zerop (length user)) | |
| tramp-postfix-user-format) | |
| (when host | |
| (if (string-match-p tramp-ipv6-regexp host) | |
| (concat | |
| tramp-prefix-ipv6-format host tramp-postfix-ipv6-format) | |
| host)) | |
| (unless (zerop (length port)) | |
| (concat tramp-prefix-port-format port)) | |
| tramp-postfix-host-format | |
| localname))) | |
| (defun tramp-make-tramp-hop-name (vec) | |
| "Construct a Tramp hop name from VEC." | |
| (replace-regexp-in-string | |
| tramp-prefix-regexp "" | |
| (replace-regexp-in-string | |
| (concat tramp-postfix-host-regexp "$") tramp-postfix-hop-format | |
| (tramp-make-tramp-file-name vec 'noloc)))) | |
| (defun tramp-completion-make-tramp-file-name (method user host localname) | |
| "Construct a Tramp file name from METHOD, USER, HOST and LOCALNAME. | |
| It must not be a complete Tramp file name, but as long as there are | |
| necessary only. This function will be used in file name completion." | |
| (concat tramp-prefix-format | |
| (unless (or (zerop (length method)) | |
| (zerop (length tramp-postfix-method-format))) | |
| (concat method tramp-postfix-method-format)) | |
| (unless (zerop (length user)) | |
| (concat user tramp-postfix-user-format)) | |
| (unless (zerop (length host)) | |
| (concat | |
| (if (string-match-p tramp-ipv6-regexp host) | |
| (concat | |
| tramp-prefix-ipv6-format host tramp-postfix-ipv6-format) | |
| host) | |
| tramp-postfix-host-format)) | |
| localname)) | |
| (defun tramp-get-buffer (vec &optional dont-create) | |
| "Get the connection buffer to be used for VEC. | |
| Unless DONT-CREATE, the buffer is created when it doesn't exist yet." | |
| (or (get-buffer (tramp-buffer-name vec)) | |
| (unless dont-create | |
| (with-current-buffer (get-buffer-create (tramp-buffer-name vec)) | |
| ;; We use the existence of connection property "process-buffer" | |
| ;; as indication, whether a connection is active. | |
| (tramp-set-connection-property | |
| vec "process-buffer" | |
| (tramp-get-connection-property vec "process-buffer" nil)) | |
| (setq buffer-undo-list t | |
| default-directory | |
| (tramp-make-tramp-file-name vec 'noloc 'nohop)) | |
| (current-buffer))))) | |
| (defun tramp-get-connection-buffer (vec &optional dont-create) | |
| "Get the connection buffer to be used for VEC. | |
| Unless DONT-CREATE, the buffer is created when it doesn't exist yet. | |
| In case a second asynchronous communication has been started, it is different | |
| from `tramp-get-buffer'." | |
| (or (tramp-get-connection-property vec "process-buffer" nil) | |
| (tramp-get-buffer vec dont-create))) | |
| (defun tramp-get-connection-name (vec) | |
| "Get the connection name to be used for VEC. | |
| In case a second asynchronous communication has been started, it is different | |
| from the default one." | |
| (or (tramp-get-connection-property vec "process-name" nil) | |
| (tramp-buffer-name vec))) | |
| (defun tramp-get-connection-process (vec) | |
| "Get the connection process to be used for VEC. | |
| In case a second asynchronous communication has been started, it is different | |
| from the default one." | |
| (and (tramp-file-name-p vec) (get-process (tramp-get-connection-name vec)))) | |
| (defun tramp-set-connection-local-variables (vec) | |
| "Set connection-local variables in the connection buffer used for VEC. | |
| If connection-local variables are not supported by this Emacs | |
| version, the function does nothing." | |
| (with-current-buffer (tramp-get-connection-buffer vec) | |
| ;; `hack-connection-local-variables-apply' exists since Emacs 26.1. | |
| (tramp-compat-funcall | |
| 'hack-connection-local-variables-apply | |
| `(:application tramp | |
| :protocol ,(tramp-file-name-method vec) | |
| :user ,(tramp-file-name-user-domain vec) | |
| :machine ,(tramp-file-name-host-port vec))))) | |
| (defun tramp-set-connection-local-variables-for-buffer () | |
| "Set connection-local variables in the current buffer. | |
| If connection-local variables are not supported by this Emacs | |
| version, the function does nothing." | |
| (when (tramp-tramp-file-p default-directory) | |
| ;; `hack-connection-local-variables-apply' exists since Emacs 26.1. | |
| (tramp-compat-funcall | |
| 'hack-connection-local-variables-apply | |
| `(:application tramp | |
| :protocol ,(file-remote-p default-directory 'method) | |
| :user ,(file-remote-p default-directory 'user) | |
| :machine ,(file-remote-p default-directory 'host))))) | |
| (defun tramp-debug-buffer-name (vec) | |
| "A name for the debug buffer for VEC." | |
| (let ((method (tramp-file-name-method vec)) | |
| (user-domain (tramp-file-name-user-domain vec)) | |
| (host-port (tramp-file-name-host-port vec))) | |
| (if (not (zerop (length user-domain))) | |
| (format "*debug tramp/%s %s@%s*" method user-domain host-port) | |
| (format "*debug tramp/%s %s*" method host-port)))) | |
| (defconst tramp-debug-outline-regexp | |
| (eval-when-compile | |
| (concat | |
| "[0-9]+:[0-9]+:[0-9]+\\.[0-9]+ " ;; Timestamp. | |
| "\\(?:\\(#<thread .+>\\) \\)?" ;; Thread. | |
| "[a-z0-9-]+ (\\([0-9]+\\)) #")) ;; Function name, verbosity. | |
| "Used for highlighting Tramp debug buffers in `outline-mode'.") | |
| (defconst tramp-debug-font-lock-keywords | |
| '(list | |
| (concat "^\\(?:" tramp-debug-outline-regexp "\\).+") | |
| '(1 font-lock-warning-face t t) | |
| '(0 (outline-font-lock-face) keep t)) | |
| "Used for highlighting Tramp debug buffers in `outline-mode'.") | |
| (defun tramp-debug-outline-level () | |
| "Return the depth to which a statement is nested in the outline. | |
| Point must be at the beginning of a header line. | |
| The outline level is equal to the verbosity of the Tramp message." | |
| (1+ (string-to-number (match-string 2)))) | |
| (defun tramp-get-debug-buffer (vec) | |
| "Get the debug buffer for VEC." | |
| (with-current-buffer | |
| (get-buffer-create (tramp-debug-buffer-name vec)) | |
| (when (bobp) | |
| (setq buffer-undo-list t) | |
| ;; Activate `outline-mode'. This runs `text-mode-hook' and | |
| ;; `outline-mode-hook'. We must prevent that local processes | |
| ;; die. Yes: I've seen `flyspell-mode', which starts "ispell". | |
| ;; `(custom-declare-variable outline-minor-mode-prefix ...)' | |
| ;; raises on error in `(outline-mode)', we don't want to see it | |
| ;; in the traces. | |
| (let ((default-directory (tramp-compat-temporary-file-directory)) | |
| signal-hook-function) | |
| (outline-mode)) | |
| (set (make-local-variable 'outline-level) 'tramp-debug-outline-level) | |
| (set (make-local-variable 'font-lock-keywords) | |
| `(t (eval ,tramp-debug-font-lock-keywords) | |
| ,(eval tramp-debug-font-lock-keywords))) | |
| ;; Do not edit the debug buffer. | |
| (use-local-map special-mode-map)) | |
| (current-buffer))) | |
| (defsubst tramp-debug-message (vec fmt-string &rest arguments) | |
| "Append message to debug buffer of VEC. | |
| Message is formatted with FMT-STRING as control string and the remaining | |
| ARGUMENTS to actually emit the message (if applicable)." | |
| (with-current-buffer (tramp-get-debug-buffer vec) | |
| (goto-char (point-max)) | |
| ;; Headline. | |
| (when (bobp) | |
| (insert | |
| (format | |
| ";; Emacs: %s Tramp: %s -*- mode: outline; -*-" | |
| emacs-version tramp-version)) | |
| (when (>= tramp-verbose 10) | |
| (let ((tramp-verbose 0)) | |
| (insert | |
| (format | |
| "\n;; Location: %s Git: %s/%s" | |
| (locate-library "tramp") | |
| (or tramp-repository-branch "") | |
| (or tramp-repository-version "")))))) | |
| (unless (bolp) | |
| (insert "\n")) | |
| ;; Timestamp. | |
| (let ((now (current-time))) | |
| (insert (format-time-string "%T." now)) | |
| (insert (format "%06d " (nth 2 now)))) | |
| ;; Threads. | |
| (unless (or (null tramp-compat-main-thread) | |
| (eq (tramp-compat-current-thread) tramp-compat-main-thread)) | |
| (insert (format "%s " (tramp-compat-current-thread)))) | |
| ;; Calling Tramp function. We suppress compat and trace functions | |
| ;; from being displayed. | |
| (let ((btn 1) btf fn) | |
| (while (not fn) | |
| (setq btf (nth 1 (backtrace-frame btn))) | |
| (if (not btf) | |
| (setq fn "") | |
| (and (symbolp btf) (setq fn (symbol-name btf)) | |
| (or (not (string-match-p "^tramp" fn)) | |
| (get btf 'tramp-suppress-trace)) | |
| (setq fn nil)) | |
| (setq btn (1+ btn)))) | |
| ;; The following code inserts filename and line number. Should | |
| ;; be inactive by default, because it is time consuming. | |
| ; (let ((ffn (find-function-noselect (intern fn)))) | |
| ; (insert | |
| ; (format | |
| ; "%s:%d: " | |
| ; (file-name-nondirectory (buffer-file-name (car ffn))) | |
| ; (with-current-buffer (car ffn) | |
| ; (1+ (count-lines (point-min) (cdr ffn))))))) | |
| (insert (format "%s " fn))) | |
| ;; The message. | |
| (insert (apply #'format-message fmt-string arguments)))) | |
| (put #'tramp-debug-message 'tramp-suppress-trace t) | |
| (defsubst tramp-message (vec-or-proc level fmt-string &rest arguments) | |
| "Emit a message depending on verbosity level. | |
| VEC-OR-PROC identifies the Tramp buffer to use. It can be either a | |
| vector or a process. LEVEL says to be quiet if `tramp-verbose' is | |
| less than LEVEL. The message is emitted only if `tramp-verbose' is | |
| greater than or equal to LEVEL. | |
| The message is also logged into the debug buffer when `tramp-verbose' | |
| is greater than or equal 4. | |
| Calls functions `message' and `tramp-debug-message' with FMT-STRING as | |
| control string and the remaining ARGUMENTS to actually emit the message (if | |
| applicable)." | |
| (ignore-errors | |
| (when (<= level tramp-verbose) | |
| ;; Display only when there is a minimum level. | |
| (when (<= level 3) | |
| (apply #'message | |
| (concat | |
| (cond | |
| ((= level 0) "") | |
| ((= level 1) "") | |
| ((= level 2) "Warning: ") | |
| (t "Tramp: ")) | |
| fmt-string) | |
| arguments)) | |
| ;; Log only when there is a minimum level. | |
| (when (>= tramp-verbose 4) | |
| (let ((tramp-verbose 0)) | |
| ;; Append connection buffer for error messages, if exists. | |
| (when (= level 1) | |
| (ignore-errors | |
| (with-current-buffer | |
| (if (processp vec-or-proc) | |
| (process-buffer vec-or-proc) | |
| (tramp-get-connection-buffer vec-or-proc 'dont-create)) | |
| (setq fmt-string (concat fmt-string "\n%s") | |
| arguments (append arguments (list (buffer-string))))))) | |
| ;; Translate proc to vec. | |
| (when (processp vec-or-proc) | |
| (setq vec-or-proc (process-get vec-or-proc 'vector)))) | |
| ;; Do it. | |
| (when (tramp-file-name-p vec-or-proc) | |
| (apply #'tramp-debug-message | |
| vec-or-proc | |
| (concat (format "(%d) # " level) fmt-string) | |
| arguments)))))) | |
| (put #'tramp-message 'tramp-suppress-trace t) | |
| (defsubst tramp-backtrace (&optional vec-or-proc) | |
| "Dump a backtrace into the debug buffer. | |
| If VEC-OR-PROC is nil, the buffer *debug tramp* is used. This | |
| function is meant for debugging purposes." | |
| (when (>= tramp-verbose 10) | |
| (if vec-or-proc | |
| (tramp-message | |
| vec-or-proc 10 "\n%s" (with-output-to-string (backtrace))) | |
| (with-output-to-temp-buffer "*debug tramp*" (backtrace))))) | |
| (put #'tramp-backtrace 'tramp-suppress-trace t) | |
| (defsubst tramp-error (vec-or-proc signal fmt-string &rest arguments) | |
| "Emit an error. | |
| VEC-OR-PROC identifies the connection to use, SIGNAL is the | |
| signal identifier to be raised, remaining arguments passed to | |
| `tramp-message'. Finally, signal SIGNAL is raised with | |
| FMT-STRING and ARGUMENTS." | |
| (let ((inhibit-message t) | |
| signal-hook-function) | |
| (tramp-backtrace vec-or-proc) | |
| (unless arguments | |
| ;; FMT-STRING could be just a file name, as in | |
| ;; `file-already-exists' errors. It could contain the ?\% | |
| ;; character, as in smb domain spec. | |
| (setq arguments (list fmt-string) | |
| fmt-string "%s")) | |
| (when vec-or-proc | |
| (tramp-message | |
| vec-or-proc 1 "%s" | |
| (error-message-string | |
| (list signal | |
| (get signal 'error-message) | |
| (apply #'format-message fmt-string arguments))))) | |
| (signal signal (list (substring-no-properties | |
| (apply #'format-message fmt-string arguments)))))) | |
| (put #'tramp-error 'tramp-suppress-trace t) | |
| (defsubst tramp-error-with-buffer | |
| (buf vec-or-proc signal fmt-string &rest arguments) | |
| "Emit an error, and show BUF. | |
| If BUF is nil, show the connection buf. Wait for 30\", or until | |
| an input event arrives. The other arguments are passed to `tramp-error'." | |
| (save-window-excursion | |
| (let* ((buf (or (and (bufferp buf) buf) | |
| (and (processp vec-or-proc) (process-buffer vec-or-proc)) | |
| (and (tramp-file-name-p vec-or-proc) | |
| (tramp-get-connection-buffer vec-or-proc)))) | |
| (vec (or (and (tramp-file-name-p vec-or-proc) vec-or-proc) | |
| (and buf (with-current-buffer buf | |
| (tramp-dissect-file-name default-directory)))))) | |
| (unwind-protect | |
| (apply #'tramp-error vec-or-proc signal fmt-string arguments) | |
| ;; Save exit. | |
| (when (and buf | |
| (not (zerop tramp-verbose)) | |
| ;; Do not show when flagged from outside. | |
| (not non-essential) | |
| ;; Show only when Emacs has started already. | |
| (current-message)) | |
| (let ((enable-recursive-minibuffers t) | |
| inhibit-message) | |
| ;; `tramp-error' does not show messages. So we must do it | |
| ;; ourselves. | |
| (apply #'message fmt-string arguments) | |
| ;; Show buffer. | |
| (pop-to-buffer buf) | |
| (discard-input) | |
| (sit-for 30))) | |
| ;; Reset timestamp. It would be wrong after waiting for a while. | |
| (when (tramp-file-name-equal-p vec (car tramp-current-connection)) | |
| (setcdr tramp-current-connection (current-time))))))) | |
| (put #'tramp-error-with-buffer 'tramp-suppress-trace t) | |
| ;; We must make it a defun, because it is used earlier already. | |
| (defun tramp-user-error (vec-or-proc fmt-string &rest arguments) | |
| "Signal a user error (or \"pilot error\")." | |
| (unwind-protect | |
| (apply #'tramp-error vec-or-proc 'user-error fmt-string arguments) | |
| ;; Save exit. | |
| (when (and (not (zerop tramp-verbose)) | |
| ;; Do not show when flagged from outside. | |
| (not non-essential) | |
| ;; Show only when Emacs has started already. | |
| (current-message)) | |
| (let ((enable-recursive-minibuffers t) | |
| inhibit-message) | |
| ;; `tramp-error' does not show messages. So we must do it ourselves. | |
| (apply #'message fmt-string arguments) | |
| (discard-input) | |
| (sit-for 30) | |
| ;; Reset timestamp. It would be wrong after waiting for a while. | |
| (when | |
| (tramp-file-name-equal-p vec-or-proc (car tramp-current-connection)) | |
| (setcdr tramp-current-connection (current-time))))))) | |
| (put #'tramp-user-error 'tramp-suppress-trace t) | |
| (defmacro tramp-with-demoted-errors (vec-or-proc format &rest body) | |
| "Execute BODY while redirecting the error message to `tramp-message'. | |
| BODY is executed like wrapped by `with-demoted-errors'. FORMAT | |
| is a format-string containing a %-sequence meaning to substitute | |
| the resulting error message." | |
| (declare (indent 2) (debug (symbolp form body))) | |
| (let ((err (make-symbol "err"))) | |
| `(condition-case-unless-debug ,err | |
| (progn ,@body) | |
| (error (tramp-message ,vec-or-proc 3 ,format ,err) nil)))) | |
| (put #'tramp-with-demoted-errors 'tramp-suppress-trace t) | |
| ;; This function provides traces in case of errors not triggered by | |
| ;; Tramp functions. | |
| (defun tramp-signal-hook-function (error-symbol data) | |
| "Function to be called via `signal-hook-function'." | |
| ;; `custom-initialize-*' functions provoke `void-variable' errors. | |
| ;; We don't want to see them in the backtrace. | |
| (unless (eq error-symbol 'void-variable) | |
| (tramp-error | |
| (car tramp-current-connection) error-symbol | |
| "%s" (mapconcat (lambda (x) (format "%s" x)) data " ")))) | |
| (put #'tramp-signal-hook-function 'tramp-suppress-trace t) | |
| (defmacro with-parsed-tramp-file-name (filename var &rest body) | |
| "Parse a Tramp filename and make components available in the body. | |
| First arg FILENAME is evaluated and dissected into its components. | |
| Second arg VAR is a symbol. It is used as a variable name to hold | |
| the filename structure. It is also used as a prefix for the variables | |
| holding the components. For example, if VAR is the symbol `foo', then | |
| `foo' will be bound to the whole structure, `foo-method' will be bound to | |
| the method component, and so on for `foo-user', `foo-domain', `foo-host', | |
| `foo-port', `foo-localname', `foo-hop'. | |
| Remaining args are Lisp expressions to be evaluated (inside an implicit | |
| `progn'). | |
| If VAR is nil, then we bind `v' to the structure and `method', `user', | |
| `domain', `host', `port', `localname', `hop' to the components." | |
| (declare (indent 2) (debug (form symbolp body))) | |
| (let ((bindings | |
| (mapcar | |
| (lambda (elem) | |
| `(,(if var (intern (format "%s-%s" var elem)) elem) | |
| (,(intern (format "tramp-file-name-%s" elem)) | |
| ,(or var 'v)))) | |
| (cdr (mapcar #'car (cl-struct-slot-info 'tramp-file-name)))))) | |
| `(let* ((,(or var 'v) (tramp-dissect-file-name ,filename)) | |
| ,@bindings) | |
| ;; We don't know which of those vars will be used, so we bind them all, | |
| ;; and then add here a dummy use of all those variables, so we don't get | |
| ;; flooded by warnings about those vars `body' didn't use. | |
| (ignore ,@(mapcar #'car bindings)) | |
| ,@body))) | |
| (font-lock-add-keywords 'emacs-lisp-mode '("\\<with-parsed-tramp-file-name\\>")) | |
| (defun tramp-progress-reporter-update (reporter &optional value suffix) | |
| "Report progress of an operation for Tramp." | |
| (let* ((parameters (cdr reporter)) | |
| (message (aref parameters 3))) | |
| (when (string-match-p message (or (current-message) "")) | |
| (tramp-compat-progress-reporter-update reporter value suffix)))) | |
| (defmacro with-tramp-progress-reporter (vec level message &rest body) | |
| "Execute BODY, spinning a progress reporter with MESSAGE in interactive mode. | |
| If LEVEL does not fit for visible messages, there are only traces | |
| without a visible progress reporter." | |
| (declare (indent 3) (debug t)) | |
| `(if (or noninteractive inhibit-message) | |
| (progn ,@body) | |
| (tramp-message ,vec ,level "%s..." ,message) | |
| (let ((cookie "failed") | |
| (tm | |
| ;; We start a pulsing progress reporter after 3 | |
| ;; seconds. Display only when there is a minimum level. | |
| (when-let ((pr (and (<= ,level (min tramp-verbose 3)) | |
| (make-progress-reporter ,message nil nil)))) | |
| (run-at-time 3 0.1 #'tramp-progress-reporter-update pr)))) | |
| (unwind-protect | |
| ;; Execute the body. | |
| (prog1 (progn ,@body) (setq cookie "done")) | |
| ;; Stop progress reporter. | |
| (if tm (cancel-timer tm)) | |
| (tramp-message ,vec ,level "%s...%s" ,message cookie))))) | |
| (font-lock-add-keywords | |
| 'emacs-lisp-mode '("\\<with-tramp-progress-reporter\\>")) | |
| (defmacro with-tramp-file-property (vec file property &rest body) | |
| "Check in Tramp cache for PROPERTY, otherwise execute BODY and set cache. | |
| FILE must be a local file name on a connection identified via VEC." | |
| (declare (indent 3) (debug t)) | |
| `(if (file-name-absolute-p ,file) | |
| (let ((value (tramp-get-file-property ,vec ,file ,property 'undef))) | |
| (when (eq value 'undef) | |
| ;; We cannot pass @body as parameter to | |
| ;; `tramp-set-file-property' because it mangles our | |
| ;; debug messages. | |
| (setq value (progn ,@body)) | |
| (tramp-set-file-property ,vec ,file ,property value)) | |
| value) | |
| ,@body)) | |
| (font-lock-add-keywords 'emacs-lisp-mode '("\\<with-tramp-file-property\\>")) | |
| (defmacro with-tramp-connection-property (key property &rest body) | |
| "Check in Tramp for property PROPERTY, otherwise execute BODY and set." | |
| (declare (indent 2) (debug t)) | |
| `(let ((value (tramp-get-connection-property ,key ,property 'undef))) | |
| (when (eq value 'undef) | |
| ;; We cannot pass ,@body as parameter to | |
| ;; `tramp-set-connection-property' because it mangles our debug | |
| ;; messages. | |
| (setq value (progn ,@body)) | |
| (tramp-set-connection-property ,key ,property value)) | |
| value)) | |
| (font-lock-add-keywords | |
| 'emacs-lisp-mode '("\\<with-tramp-connection-property\\>")) | |
| (defun tramp-drop-volume-letter (name) | |
| "Cut off unnecessary drive letter from file NAME. | |
| The functions `tramp-*-handle-expand-file-name' call `expand-file-name' | |
| locally on a remote file name. When the local system is a W32 system | |
| but the remote system is Unix, this introduces a superfluous drive | |
| letter into the file name. This function removes it." | |
| (save-match-data | |
| (let ((quoted (tramp-compat-file-name-quoted-p name 'top)) | |
| (result (tramp-compat-file-name-unquote name 'top))) | |
| (setq result (if (string-match "\\`[a-zA-Z]:/" result) | |
| (replace-match "/" nil t result) result)) | |
| (if quoted (tramp-compat-file-name-quote result 'top) result)))) | |
| ;;; Config Manipulation Functions: | |
| (defconst tramp-dns-sd-service-regexp "^_[-[:alnum:]]+\\._tcp$" | |
| "DNS-SD service regexp.") | |
| (defun tramp-set-completion-function (method function-list) | |
| "Set the list of completion functions for METHOD. | |
| FUNCTION-LIST is a list of entries of the form (FUNCTION FILE). | |
| The FUNCTION is intended to parse FILE according its syntax. | |
| It might be a predefined FUNCTION, or a user defined FUNCTION. | |
| For the list of predefined FUNCTIONs see `tramp-completion-function-alist'. | |
| Example: | |
| (tramp-set-completion-function | |
| \"ssh\" | |
| \\='((tramp-parse-sconfig \"/etc/ssh_config\") | |
| (tramp-parse-sconfig \"~/.ssh/config\")))" | |
| (let ((r function-list) | |
| (v function-list)) | |
| (setq tramp-completion-function-alist | |
| (delete (assoc method tramp-completion-function-alist) | |
| tramp-completion-function-alist)) | |
| (while v | |
| ;; Remove double entries. | |
| (when (member (car v) (cdr v)) | |
| (setcdr v (delete (car v) (cdr v)))) | |
| ;; Check for function and file or registry key. | |
| (unless (and (functionp (nth 0 (car v))) | |
| (cond | |
| ;; Windows registry. | |
| ((string-match-p "^HKEY_CURRENT_USER" (nth 1 (car v))) | |
| (and (memq system-type '(cygwin windows-nt)) | |
| (zerop | |
| (tramp-call-process | |
| v "reg" nil nil nil "query" (nth 1 (car v)))))) | |
| ;; DNS-SD service type. | |
| ((string-match-p | |
| tramp-dns-sd-service-regexp (nth 1 (car v)))) | |
| ;; Configuration file or empty string. | |
| (t (file-exists-p (nth 1 (car v)))))) | |
| (setq r (delete (car v) r))) | |
| (setq v (cdr v))) | |
| (when r | |
| (add-to-list 'tramp-completion-function-alist | |
| (cons method r))))) | |
| (defun tramp-get-completion-function (method) | |
| "Return a list of completion functions for METHOD. | |
| For definition of that list see `tramp-set-completion-function'." | |
| (append | |
| `(;; Default settings are taken into account. | |
| (tramp-parse-default-user-host ,method) | |
| ;; Hits from auth-sources. | |
| (tramp-parse-auth-sources ,method) | |
| ;; Hosts visited once shall be remembered. | |
| (tramp-parse-connection-properties ,method)) | |
| ;; The method related defaults. | |
| (cdr (assoc method tramp-completion-function-alist)))) | |
| ;; Inodes don't exist for some file systems. Therefore we must | |
| ;; generate virtual ones. Used in `find-buffer-visiting'. The method | |
| ;; applied might be not so efficient (Ange-FTP uses hashes). But | |
| ;; performance isn't the major issue given that file transfer will | |
| ;; take time. | |
| (defvar tramp-inodes 0 | |
| "Keeps virtual inodes numbers.") | |
| ;; Devices must distinguish physical file systems. The device numbers | |
| ;; provided by "lstat" aren't unique, because we operate on different hosts. | |
| ;; So we use virtual device numbers, generated by Tramp. Both Ange-FTP and | |
| ;; EFS use device number "-1". In order to be different, we use device number | |
| ;; (-1 . x), whereby "x" is unique for a given (method user host). | |
| (defvar tramp-devices 0 | |
| "Keeps virtual device numbers.") | |
| (defun tramp-default-file-modes (filename &optional flag) | |
| "Return file modes of FILENAME as integer. | |
| If optional FLAG is ‘nofollow’, do not follow FILENAME if it is a | |
| symbolic link. If the file modes of FILENAME cannot be | |
| determined, return the value of `default-file-modes', without | |
| execute permissions." | |
| (or (tramp-compat-file-modes filename flag) | |
| (logand (default-file-modes) #o0666))) | |
| (defun tramp-replace-environment-variables (filename) | |
| "Replace environment variables in FILENAME. | |
| Return the string with the replaced variables." | |
| (substitute-env-vars filename 'only-defined)) | |
| (defun tramp-find-file-name-coding-system-alist (filename tmpname) | |
| "Like `find-operation-coding-system' for Tramp filenames. | |
| Tramp's `insert-file-contents' and `write-region' work over | |
| temporary file names. If `file-coding-system-alist' contains an | |
| expression, which matches more than the file name suffix, the | |
| coding system might not be determined. This function repairs it." | |
| (let (result) | |
| (dolist (elt file-coding-system-alist (nreverse result)) | |
| (when (and (consp elt) (string-match-p (car elt) filename)) | |
| ;; We found a matching entry in `file-coding-system-alist'. | |
| ;; So we add a similar entry, but with the temporary file name | |
| ;; as regexp. | |
| (push (cons (regexp-quote tmpname) (cdr elt)) result))))) | |
| (defun tramp-run-real-handler (operation args) | |
| "Invoke normal file name handler for OPERATION. | |
| First arg specifies the OPERATION, second arg ARGS is a list of | |
| arguments to pass to the OPERATION." | |
| (let* ((inhibit-file-name-handlers | |
| `(tramp-file-name-handler | |
| tramp-vc-file-name-handler | |
| tramp-completion-file-name-handler | |
| tramp-archive-file-name-handler | |
| cygwin-mount-name-hook-function | |
| cygwin-mount-map-drive-hook-function | |
| . | |
| ,(and (eq inhibit-file-name-operation operation) | |
| inhibit-file-name-handlers))) | |
| (inhibit-file-name-operation operation) | |
| signal-hook-function) | |
| (apply operation args))) | |
| ;; We handle here all file primitives. Most of them have the file | |
| ;; name as first parameter; nevertheless we check for them explicitly | |
| ;; in order to be signaled if a new primitive appears. This | |
| ;; scenario is needed because there isn't a way to decide by | |
| ;; syntactical means whether a foreign method must be called. It would | |
| ;; ease the life if `file-name-handler-alist' would support a decision | |
| ;; function as well but regexp only. | |
| (defun tramp-file-name-for-operation (operation &rest args) | |
| "Return file name related to OPERATION file primitive. | |
| ARGS are the arguments OPERATION has been called with. | |
| It does not always return a Tramp file name, for example if the | |
| first argument of `expand-file-name' is absolute and not remote. | |
| Must be handled by the callers." | |
| (cond | |
| ;; FILE resp DIRECTORY. | |
| ((member operation | |
| '(access-file byte-compiler-base-file-name delete-directory | |
| delete-file diff-latest-backup-file directory-file-name | |
| directory-files directory-files-and-attributes | |
| dired-compress-file dired-uncache file-acl | |
| file-accessible-directory-p file-attributes | |
| file-directory-p file-executable-p file-exists-p | |
| file-local-copy file-modes file-name-as-directory | |
| file-name-directory file-name-nondirectory | |
| file-name-sans-versions file-notify-add-watch | |
| file-ownership-preserved-p file-readable-p | |
| file-regular-p file-remote-p file-selinux-context | |
| file-symlink-p file-truename file-writable-p | |
| find-backup-file-name get-file-buffer | |
| insert-directory insert-file-contents load | |
| make-directory make-directory-internal set-file-acl | |
| set-file-modes set-file-selinux-context set-file-times | |
| substitute-in-file-name unhandled-file-name-directory | |
| vc-registered | |
| ;; Emacs 26+ only. | |
| file-name-case-insensitive-p | |
| ;; Emacs 27+ only. | |
| file-system-info | |
| ;; Tramp internal magic file name function. | |
| tramp-set-file-uid-gid)) | |
| (if (file-name-absolute-p (nth 0 args)) | |
| (nth 0 args) | |
| default-directory)) | |
| ;; STRING FILE. | |
| ;; Starting with Emacs 26.1, just the 2nd argument of | |
| ;; `make-symbolic-link' matters. | |
| ((eq operation 'make-symbolic-link) (nth 1 args)) | |
| ;; FILE DIRECTORY resp FILE1 FILE2. | |
| ((member operation | |
| '(add-name-to-file copy-directory copy-file | |
| file-equal-p file-in-directory-p | |
| file-name-all-completions file-name-completion | |
| file-newer-than-file-p rename-file)) | |
| (cond | |
| ((tramp-tramp-file-p (nth 0 args)) (nth 0 args)) | |
| ((tramp-tramp-file-p (nth 1 args)) (nth 1 args)) | |
| (t default-directory))) | |
| ;; FILE DIRECTORY resp FILE1 FILE2. | |
| ((eq operation 'expand-file-name) | |
| (cond | |
| ((file-name-absolute-p (nth 0 args)) (nth 0 args)) | |
| ((tramp-tramp-file-p (nth 1 args)) (nth 1 args)) | |
| (t default-directory))) | |
| ;; START END FILE. | |
| ((eq operation 'write-region) | |
| (if (file-name-absolute-p (nth 2 args)) | |
| (nth 2 args) | |
| default-directory)) | |
| ;; BUFFER. | |
| ((member operation | |
| '(make-auto-save-file-name | |
| set-visited-file-modtime verify-visited-file-modtime)) | |
| (buffer-file-name | |
| (if (bufferp (nth 0 args)) (nth 0 args) (current-buffer)))) | |
| ;; COMMAND. | |
| ((member operation | |
| '(process-file shell-command start-file-process | |
| ;; Emacs 26+ only. | |
| make-nearby-temp-file temporary-file-directory | |
| ;; Emacs 27+ only. | |
| exec-path make-process)) | |
| default-directory) | |
| ;; PROC. | |
| ((member operation '(file-notify-rm-watch file-notify-valid-p)) | |
| (when (processp (nth 0 args)) | |
| (with-current-buffer (process-buffer (nth 0 args)) | |
| default-directory))) | |
| ;; Unknown file primitive. | |
| (t (error "Unknown file I/O primitive: %s" operation)))) | |
| (defun tramp-find-foreign-file-name-handler (filename &optional _operation) | |
| "Return foreign file name handler if exists." | |
| (when (tramp-tramp-file-p filename) | |
| (let ((handler tramp-foreign-file-name-handler-alist) | |
| elt res) | |
| (while handler | |
| (setq elt (car handler) | |
| handler (cdr handler)) | |
| (when (funcall (car elt) filename) | |
| (setq handler nil | |
| res (cdr elt)))) | |
| res))) | |
| ;; In Emacs, there is some concurrency due to timers. If a timer | |
| ;; interrupts Tramp and wishes to use the same connection buffer as | |
| ;; the "main" Emacs, then garbage might occur in the connection | |
| ;; buffer. Therefore, we need to make sure that a timer does not use | |
| ;; the same connection buffer as the "main" Emacs. We implement a | |
| ;; cheap global lock, instead of locking each connection buffer | |
| ;; separately. The global lock is based on two variables, | |
| ;; `tramp-locked' and `tramp-locker'. `tramp-locked' is set to true | |
| ;; (with setq) to indicate a lock. But Tramp also calls itself during | |
| ;; processing of a single file operation, so we need to allow | |
| ;; recursive calls. That's where the `tramp-locker' variable comes in | |
| ;; -- it is let-bound to t during the execution of the current | |
| ;; handler. So if `tramp-locked' is t and `tramp-locker' is also t, | |
| ;; then we should just proceed because we have been called | |
| ;; recursively. But if `tramp-locker' is nil, then we are a timer | |
| ;; interrupting the "main" Emacs, and then we signal an error. | |
| (defvar tramp-locked nil | |
| "If non-nil, then Tramp is currently busy. | |
| Together with `tramp-locker', this implements a locking mechanism | |
| preventing reentrant calls of Tramp.") | |
| (defvar tramp-locker nil | |
| "If non-nil, then a caller has locked Tramp. | |
| Together with `tramp-locked', this implements a locking mechanism | |
| preventing reentrant calls of Tramp.") | |
| ;; Mutexes have entered Emacs 26.1. | |
| (defvar tramp-mutex (tramp-compat-funcall 'make-mutex "tramp") | |
| "Global mutex for Tramp threads.") | |
| (defun tramp-get-mutex (vec) | |
| "Return the mutex locking Tramp threads for VEC." | |
| (if-let ((p (and (tramp-connectable-p vec) | |
| (tramp-get-connection-process vec)))) | |
| (with-tramp-connection-property p "mutex" | |
| (tramp-compat-funcall 'make-mutex (process-name p))) | |
| tramp-mutex)) | |
| ;; Main function. | |
| (defun tramp-file-name-handler (operation &rest args) | |
| "Invoke Tramp file name handler for OPERATION and ARGS. | |
| Fall back to normal file name handler if no Tramp file name handler exists. | |
| If Emacs is compiled --with-threads, the body is protected by a mutex." | |
| (let ((filename (apply #'tramp-file-name-for-operation operation args)) | |
| ;; `file-remote-p' is called for everything, even for symbolic | |
| ;; links which look remote. We don't want to get an error. | |
| (non-essential (or non-essential (eq operation 'file-remote-p)))) | |
| (if (tramp-tramp-file-p filename) | |
| (save-match-data | |
| (setq filename (tramp-replace-environment-variables filename)) | |
| (with-parsed-tramp-file-name filename nil | |
| ;; Give other threads a chance. | |
| (tramp-compat-thread-yield) | |
| ;; The mutex allows concurrent run of operations. It | |
| ;; guarantees, that the threads are not mixed. | |
| (tramp-compat-with-mutex (tramp-get-mutex v) | |
| (let ((current-connection tramp-current-connection) | |
| (foreign | |
| (tramp-find-foreign-file-name-handler filename operation)) | |
| (signal-hook-function #'tramp-signal-hook-function) | |
| result) | |
| ;; Set `tramp-current-connection'. | |
| (unless | |
| (tramp-file-name-equal-p v (car tramp-current-connection)) | |
| (setq tramp-current-connection (list v))) | |
| ;; Call the backend function. | |
| (unwind-protect | |
| (if foreign | |
| (let ((sf (symbol-function foreign)) | |
| p) | |
| ;; Some packages set the default directory | |
| ;; to a remote path, before respective Tramp | |
| ;; packages are already loaded. This | |
| ;; results in recursive loading. Therefore, | |
| ;; we load the Tramp packages locally. | |
| (when (autoloadp sf) | |
| ;; FIXME: Not clear why we need these bindings here. | |
| ;; The explanation above is not convincing and | |
| ;; the bug#9114 for which it was added doesn't | |
| ;; clarify the core of the problem. | |
| (let ((default-directory | |
| (tramp-compat-temporary-file-directory)) | |
| file-name-handler-alist) | |
| (autoload-do-load sf foreign))) | |
| ;; (tramp-message | |
| ;; v 4 "Running `%s'..." (cons operation args)) | |
| ;; Switch process thread. | |
| (when (and tramp-mutex | |
| (tramp-connectable-p v) | |
| (setq p (tramp-get-connection-process v))) | |
| (tramp-compat-funcall | |
| 'set-process-thread | |
| p (tramp-compat-current-thread))) | |
| ;; If `non-essential' is non-nil, Tramp | |
| ;; shall not open a new connection. | |
| ;; If Tramp detects that it shouldn't | |
| ;; continue to work, it throws the | |
| ;; `suppress' event. This could happen for | |
| ;; example, when Tramp tries to open the | |
| ;; same connection twice in a short time | |
| ;; frame. | |
| ;; In both cases, we try the default handler | |
| ;; then. | |
| (setq result | |
| (catch 'non-essential | |
| (catch 'suppress | |
| (when (and tramp-locked (not tramp-locker)) | |
| (setq tramp-locked nil) | |
| (tramp-error | |
| v 'file-error | |
| "Forbidden reentrant call of Tramp")) | |
| (let ((tl tramp-locked)) | |
| (setq tramp-locked t) | |
| (unwind-protect | |
| (let ((tramp-locker t)) | |
| (apply foreign operation args)) | |
| (setq tramp-locked tl)))))) | |
| ;; (tramp-message | |
| ;; v 4 "Running `%s'...`%s'" (cons operation args) result) | |
| (cond | |
| ((eq result 'non-essential) | |
| (tramp-message | |
| v 5 "Non-essential received in operation %s" | |
| (cons operation args)) | |
| (tramp-run-real-handler operation args)) | |
| ((eq result 'suppress) | |
| (let ((inhibit-message t)) | |
| (tramp-message | |
| v 1 "Suppress received in operation %s" | |
| (cons operation args)) | |
| (tramp-cleanup-connection v t) | |
| (tramp-run-real-handler operation args))) | |
| (t result))) | |
| ;; Nothing to do for us. However, since we are | |
| ;; in `tramp-mode', we must suppress the volume | |
| ;; letter on MS Windows. | |
| (setq result (tramp-run-real-handler operation args)) | |
| (if (stringp result) | |
| (tramp-drop-volume-letter result) | |
| result)) | |
| ;; Reset `tramp-current-connection'. | |
| (unless | |
| (tramp-file-name-equal-p | |
| (car current-connection) (car tramp-current-connection)) | |
| (setq tramp-current-connection current-connection))))))) | |
| ;; When `tramp-mode' is not enabled, or the file name is quoted, | |
| ;; we don't do anything. | |
| (tramp-run-real-handler operation args)))) | |
| (defun tramp-completion-file-name-handler (operation &rest args) | |
| "Invoke Tramp file name completion handler for OPERATION and ARGS. | |
| Falls back to normal file name handler if no Tramp file name handler exists." | |
| (if-let | |
| ((fn (and tramp-mode | |
| (assoc operation tramp-completion-file-name-handler-alist)))) | |
| (save-match-data (apply (cdr fn) args)) | |
| (tramp-run-real-handler operation args))) | |
| ;;;###autoload | |
| (progn (defun tramp-autoload-file-name-handler (operation &rest args) | |
| "Load Tramp file name handler, and perform OPERATION." | |
| (tramp-unload-file-name-handlers) | |
| (when tramp-mode | |
| (let ((default-directory temporary-file-directory)) | |
| (load "tramp" 'noerror 'nomessage))) | |
| (apply operation args))) | |
| ;; `tramp-autoload-file-name-handler' must be registered before | |
| ;; evaluation of site-start and init files, because there might exist | |
| ;; remote files already, f.e. files kept via recentf-mode. | |
| ;;;###autoload | |
| (progn (defun tramp-register-autoload-file-name-handlers () | |
| "Add Tramp file name handlers to `file-name-handler-alist' during autoload." | |
| (add-to-list 'file-name-handler-alist | |
| (cons tramp-autoload-file-name-regexp | |
| 'tramp-autoload-file-name-handler)) | |
| (put #'tramp-autoload-file-name-handler 'safe-magic t))) | |
| ;;;###autoload (tramp-register-autoload-file-name-handlers) | |
| (defun tramp-use-absolute-autoload-file-names () | |
| "Change Tramp autoload objects to use absolute file names. | |
| This avoids problems during autoload, when `load-path' contains | |
| remote file names." | |
| ;; We expect all other Tramp files in the same directory as tramp.el. | |
| (let* ((dir (expand-file-name (file-name-directory (locate-library "tramp")))) | |
| (files-regexp | |
| (format | |
| "^%s$" | |
| (regexp-opt | |
| (mapcar | |
| #'file-name-sans-extension | |
| (directory-files dir nil "^tramp.+\\.elc?$")) | |
| 'paren)))) | |
| (mapatoms | |
| (lambda (atom) | |
| (when (and (functionp atom) | |
| (autoloadp (symbol-function atom)) | |
| (string-match-p files-regexp (cadr (symbol-function atom)))) | |
| (ignore-errors | |
| (setf (cadr (symbol-function atom)) | |
| (expand-file-name (cadr (symbol-function atom)) dir)))))))) | |
| (tramp--with-startup (tramp-use-absolute-autoload-file-names)) | |
| (defun tramp-register-file-name-handlers () | |
| "Add Tramp file name handlers to `file-name-handler-alist'." | |
| ;; Remove autoloaded handlers from file name handler alist. Useful, | |
| ;; if `tramp-syntax' has been changed. | |
| (tramp-unload-file-name-handlers) | |
| ;; Add the handlers. We do not add anything to the `operations' | |
| ;; property of `tramp-file-name-handler' and | |
| ;; `tramp-archive-file-name-handler', this shall be done by the | |
| ;; respective foreign handlers. | |
| (add-to-list 'file-name-handler-alist | |
| (cons tramp-file-name-regexp #'tramp-file-name-handler)) | |
| (put #'tramp-file-name-handler 'safe-magic t) | |
| (add-to-list 'file-name-handler-alist | |
| (cons tramp-completion-file-name-regexp | |
| #'tramp-completion-file-name-handler)) | |
| (put #'tramp-completion-file-name-handler 'safe-magic t) | |
| ;; Mark `operations' the handler is responsible for. | |
| (put #'tramp-completion-file-name-handler 'operations | |
| (mapcar #'car tramp-completion-file-name-handler-alist)) | |
| (when (bound-and-true-p tramp-archive-enabled) | |
| (add-to-list 'file-name-handler-alist | |
| (cons tramp-archive-file-name-regexp | |
| #'tramp-archive-file-name-handler)) | |
| (put #'tramp-archive-file-name-handler 'safe-magic t)) | |
| ;; If jka-compr or epa-file are already loaded, move them to the | |
| ;; front of `file-name-handler-alist'. | |
| (dolist (fnh '(epa-file-handler jka-compr-handler)) | |
| (when-let ((entry (rassoc fnh file-name-handler-alist))) | |
| (setq file-name-handler-alist | |
| (cons entry (delete entry file-name-handler-alist)))))) | |
| (tramp--with-startup (tramp-register-file-name-handlers)) | |
| (defun tramp-register-foreign-file-name-handler | |
| (func handler &optional append) | |
| "Register (FUNC . HANDLER) in `tramp-foreign-file-name-handler-alist'. | |
| FUNC is the function, which determines whether HANDLER is to be called. | |
| Add operations defined in `HANDLER-alist' to `tramp-file-name-handler'." | |
| (add-to-list | |
| 'tramp-foreign-file-name-handler-alist `(,func . ,handler) append) | |
| ;; Mark `operations' the handler is responsible for. | |
| (put #'tramp-file-name-handler | |
| 'operations | |
| (delete-dups | |
| (append | |
| (get 'tramp-file-name-handler 'operations) | |
| (mapcar | |
| #'car | |
| (symbol-value (intern (concat (symbol-name handler) "-alist")))))))) | |
| (defun tramp-exists-file-name-handler (operation &rest args) | |
| "Check, whether OPERATION runs a file name handler." | |
| ;; The file name handler is determined on base of either an | |
| ;; argument, `buffer-file-name', or `default-directory'. | |
| (ignore-errors | |
| (let* ((buffer-file-name "/") | |
| (default-directory "/") | |
| (fnha file-name-handler-alist) | |
| (check-file-name-operation operation) | |
| (file-name-handler-alist | |
| (list | |
| (cons "/" | |
| (lambda (operation &rest args) | |
| "Returns OPERATION if it is the one to be checked." | |
| (if (equal check-file-name-operation operation) | |
| operation | |
| (let ((file-name-handler-alist fnha)) | |
| (apply operation args)))))))) | |
| (equal (apply operation args) operation)))) | |
| ;;;###autoload | |
| (progn (defun tramp-unload-file-name-handlers () | |
| "Unload Tramp file name handlers from `file-name-handler-alist'." | |
| (dolist (fnh file-name-handler-alist) | |
| (when (and (symbolp (cdr fnh)) | |
| (string-prefix-p "tramp-" (symbol-name (cdr fnh)))) | |
| (setq file-name-handler-alist (delq fnh file-name-handler-alist)))))) | |
| (add-hook 'tramp-unload-hook #'tramp-unload-file-name-handlers) | |
| ;;; File name handler functions for completion mode: | |
| (defun tramp-connectable-p (vec-or-filename) | |
| "Check, whether it is possible to connect the remote host w/o side-effects. | |
| This is true, if either the remote host is already connected, or if we are | |
| not in completion mode." | |
| (let ((tramp-verbose 0) | |
| (vec | |
| (cond | |
| ((tramp-file-name-p vec-or-filename) vec-or-filename) | |
| ((tramp-tramp-file-p vec-or-filename) | |
| (tramp-dissect-file-name vec-or-filename))))) | |
| (or ;; We check this for the process related to | |
| ;; `tramp-buffer-name'; otherwise `start-file-process' | |
| ;; wouldn't run ever when `non-essential' is non-nil. | |
| (and vec (process-live-p (get-process (tramp-buffer-name vec)))) | |
| (not non-essential)))) | |
| ;; Method, host name and user name completion. | |
| ;; `tramp-completion-dissect-file-name' returns a list of | |
| ;; `tramp-file-name' structures. For all of them we return possible | |
| ;; completions. | |
| (defun tramp-completion-handle-file-name-all-completions (filename directory) | |
| "Like `file-name-all-completions' for partial Tramp files." | |
| (let ((fullname | |
| (tramp-drop-volume-letter (expand-file-name filename directory))) | |
| hop result result1) | |
| ;; Suppress hop from completion. | |
| (when (string-match | |
| (concat | |
| tramp-prefix-regexp | |
| "\\(" "\\(" tramp-remote-file-name-spec-regexp | |
| tramp-postfix-hop-regexp | |
| "\\)+" "\\)") | |
| fullname) | |
| (setq hop (match-string 1 fullname) | |
| fullname (replace-match "" nil nil fullname 1))) | |
| ;; Possible completion structures. | |
| (dolist (elt (tramp-completion-dissect-file-name fullname)) | |
| (let* ((method (tramp-file-name-method elt)) | |
| (user (tramp-file-name-user elt)) | |
| (host (tramp-file-name-host elt)) | |
| (localname (tramp-file-name-localname elt)) | |
| (m (tramp-find-method method user host)) | |
| all-user-hosts) | |
| (unless localname ;; Nothing to complete. | |
| (if (or user host) | |
| ;; Method dependent user / host combinations. | |
| (progn | |
| (mapc | |
| (lambda (x) | |
| (setq all-user-hosts | |
| (append all-user-hosts | |
| (funcall (nth 0 x) (nth 1 x))))) | |
| (tramp-get-completion-function m)) | |
| (setq result | |
| (append result | |
| (mapcar | |
| (lambda (x) | |
| (tramp-get-completion-user-host | |
| method user host (nth 0 x) (nth 1 x))) | |
| (delq nil all-user-hosts))))) | |
| ;; Possible methods. | |
| (setq result | |
| (append result (tramp-get-completion-methods m))))))) | |
| ;; Unify list, add hop, remove nil elements. | |
| (dolist (elt result) | |
| (when elt | |
| (string-match tramp-prefix-regexp elt) | |
| (setq elt (replace-match (concat tramp-prefix-format hop) nil nil elt)) | |
| (push | |
| (substring elt (length (tramp-drop-volume-letter directory))) | |
| result1))) | |
| ;; Complete local parts. | |
| (append | |
| result1 | |
| (ignore-errors | |
| (tramp-run-real-handler | |
| 'file-name-all-completions (list filename directory)))))) | |
| ;; Method, host name and user name completion for a file. | |
| (defun tramp-completion-handle-file-name-completion | |
| (filename directory &optional predicate) | |
| "Like `file-name-completion' for partial Tramp files." | |
| ;; Suppress eager completion on not connected hosts. | |
| (let ((non-essential t)) | |
| (try-completion | |
| filename | |
| (mapcar #'list (file-name-all-completions filename directory)) | |
| (when (and predicate (tramp-connectable-p directory)) | |
| (lambda (x) (funcall predicate (expand-file-name (car x) directory))))))) | |
| ;; I misuse a little bit the `tramp-file-name' structure in order to | |
| ;; handle completion possibilities for partial methods / user names / | |
| ;; host names. Return value is a list of `tramp-file-name' structures | |
| ;; according to possible completions. If "localname" is non-nil it | |
| ;; means there shouldn't be a completion anymore. | |
| ;; Expected results: | |
| ;; "/x" "/[x" | |
| ;; ["x" nil nil nil] | |
| ;; "/x:" "/[x/" "/x:y" "/[x/y" "/x:y:" "/[x/y]" | |
| ;; ["x" nil "" nil] ["x" nil "y" nil] ["x" nil "y" ""] | |
| ;; ["x" "" nil nil] ["x" "y" nil nil] | |
| ;; "/x:y@""/[x/y@" "/x:y@z" "/[x/y@z" "/x:y@z:" "/[x/y@z]" | |
| ;;["x" "y" nil nil] ["x" "y" "z" nil] ["x" "y" "z" ""] | |
| (defun tramp-completion-dissect-file-name (name) | |
| "Return a list of `tramp-file-name' structures for NAME. | |
| They are collected by `tramp-completion-dissect-file-name1'." | |
| (let* ((x-nil "\\|\\(\\)") | |
| (tramp-completion-ipv6-regexp | |
| (format | |
| "[^%s]*" | |
| (if (zerop (length tramp-postfix-ipv6-format)) | |
| tramp-postfix-host-format | |
| tramp-postfix-ipv6-format))) | |
| ;; "/method" "/[method" | |
| (tramp-completion-file-name-structure1 | |
| (list | |
| (concat | |
| tramp-prefix-regexp | |
| "\\(" tramp-method-regexp x-nil "\\)$") | |
| 1 nil nil nil)) | |
| ;; "/method:user" "/[method/user" | |
| (tramp-completion-file-name-structure2 | |
| (list | |
| (concat | |
| tramp-prefix-regexp | |
| "\\(" tramp-method-regexp "\\)" tramp-postfix-method-regexp | |
| "\\(" tramp-user-regexp x-nil "\\)$") | |
| 1 2 nil nil)) | |
| ;; "/method:host" "/[method/host" | |
| (tramp-completion-file-name-structure3 | |
| (list | |
| (concat | |
| tramp-prefix-regexp | |
| "\\(" tramp-method-regexp "\\)" tramp-postfix-method-regexp | |
| "\\(" tramp-host-regexp x-nil "\\)$") | |
| 1 nil 2 nil)) | |
| ;; "/method:[ipv6" "/[method/ipv6" | |
| (tramp-completion-file-name-structure4 | |
| (list | |
| (concat | |
| tramp-prefix-regexp | |
| "\\(" tramp-method-regexp "\\)" tramp-postfix-method-regexp | |
| tramp-prefix-ipv6-regexp | |
| "\\(" tramp-completion-ipv6-regexp x-nil "\\)$") | |
| 1 nil 2 nil)) | |
| ;; "/method:user@host" "/[method/user@host" | |
| (tramp-completion-file-name-structure5 | |
| (list | |
| (concat | |
| tramp-prefix-regexp | |
| "\\(" tramp-method-regexp "\\)" tramp-postfix-method-regexp | |
| "\\(" tramp-user-regexp "\\)" tramp-postfix-user-regexp | |
| "\\(" tramp-host-regexp x-nil "\\)$") | |
| 1 2 3 nil)) | |
| ;; "/method:user@[ipv6" "/[method/user@ipv6" | |
| (tramp-completion-file-name-structure6 | |
| (list | |
| (concat | |
| tramp-prefix-regexp | |
| "\\(" tramp-method-regexp "\\)" tramp-postfix-method-regexp | |
| "\\(" tramp-user-regexp "\\)" tramp-postfix-user-regexp | |
| tramp-prefix-ipv6-regexp | |
| "\\(" tramp-completion-ipv6-regexp x-nil "\\)$") | |
| 1 2 3 nil))) | |
| (delq | |
| nil | |
| (mapcar | |
| (lambda (structure) (tramp-completion-dissect-file-name1 structure name)) | |
| (list | |
| tramp-completion-file-name-structure1 | |
| tramp-completion-file-name-structure2 | |
| tramp-completion-file-name-structure3 | |
| tramp-completion-file-name-structure4 | |
| tramp-completion-file-name-structure5 | |
| tramp-completion-file-name-structure6))))) | |
| (defun tramp-completion-dissect-file-name1 (structure name) | |
| "Return a `tramp-file-name' structure for NAME matching STRUCTURE. | |
| The structure consists of remote method, remote user, | |
| remote host and localname (filename on remote host)." | |
| (save-match-data | |
| (when (string-match (nth 0 structure) name) | |
| (make-tramp-file-name | |
| :method (and (nth 1 structure) | |
| (match-string (nth 1 structure) name)) | |
| :user (and (nth 2 structure) | |
| (match-string (nth 2 structure) name)) | |
| :host (and (nth 3 structure) | |
| (match-string (nth 3 structure) name)))))) | |
| ;; This function returns all possible method completions, adding the | |
| ;; trailing method delimiter. | |
| (defun tramp-get-completion-methods (partial-method) | |
| "Return all method completions for PARTIAL-METHOD." | |
| (mapcar | |
| (lambda (method) | |
| (and method | |
| (string-match-p (concat "^" (regexp-quote partial-method)) method) | |
| (tramp-completion-make-tramp-file-name method nil nil nil))) | |
| (mapcar #'car tramp-methods))) | |
| ;; Compares partial user and host names with possible completions. | |
| (defun tramp-get-completion-user-host | |
| (method partial-user partial-host user host) | |
| "Return the most expanded string for user and host name completion. | |
| PARTIAL-USER must match USER, PARTIAL-HOST must match HOST." | |
| (cond | |
| ((and partial-user partial-host) | |
| (if (and host | |
| (string-match-p (concat "^" (regexp-quote partial-host)) host) | |
| (string-equal partial-user (or user partial-user))) | |
| (setq user partial-user) | |
| (setq user nil | |
| host nil))) | |
| (partial-user | |
| (setq host nil) | |
| (unless | |
| (and user | |
| (string-match-p (concat "^" (regexp-quote partial-user)) user)) | |
| (setq user nil))) | |
| (partial-host | |
| (setq user nil) | |
| (unless | |
| (and host | |
| (string-match-p (concat "^" (regexp-quote partial-host)) host)) | |
| (setq host nil))) | |
| (t (setq user nil | |
| host nil))) | |
| (unless (zerop (+ (length user) (length host))) | |
| (tramp-completion-make-tramp-file-name method user host nil))) | |
| (defun tramp-parse-default-user-host (method) | |
| "Return a list of (user host) tuples allowed to access for METHOD. | |
| This function is added always in `tramp-get-completion-function' | |
| for all methods. Resulting data are derived from default settings." | |
| `((,(tramp-find-user method nil nil) ,(tramp-find-host method nil nil)))) | |
| (defcustom tramp-completion-use-auth-sources auth-source-do-cache | |
| "Whether to use `auth-source-search' for completion of user and host names. | |
| This could be disturbing, if it requires a password / passphrase, | |
| as for \"~/.authinfo.gpg\"." | |
| :version "27.1" | |
| :type 'boolean) | |
| (defun tramp-parse-auth-sources (method) | |
| "Return a list of (user host) tuples allowed to access for METHOD. | |
| This function is added always in `tramp-get-completion-function' | |
| for all methods. Resulting data are derived from default settings." | |
| (and tramp-completion-use-auth-sources | |
| (mapcar | |
| (lambda (x) `(,(plist-get x :user) ,(plist-get x :host))) | |
| (auth-source-search | |
| :port method :require '(:port) :max most-positive-fixnum)))) | |
| ;; Generic function. | |
| (defun tramp-parse-group (regexp match-level skip-chars) | |
| "Return a (user host) tuple allowed to access. | |
| User is always nil." | |
| (let (result) | |
| (when (re-search-forward regexp (point-at-eol) t) | |
| (setq result (list nil (match-string match-level)))) | |
| (or | |
| (> (skip-chars-forward skip-chars) 0) | |
| (forward-line 1)) | |
| result)) | |
| ;; Generic function. | |
| (defun tramp-parse-file (filename function) | |
| "Return a list of (user host) tuples allowed to access. | |
| User is always nil." | |
| ;; On Windows, there are problems in completion when | |
| ;; `default-directory' is remote. | |
| (let ((default-directory (tramp-compat-temporary-file-directory))) | |
| (when (file-readable-p filename) | |
| (with-temp-buffer | |
| (insert-file-contents-literally filename) | |
| (goto-char (point-min)) | |
| (cl-loop while (not (eobp)) collect (funcall function)))))) | |
| (defun tramp-parse-rhosts (filename) | |
| "Return a list of (user host) tuples allowed to access. | |
| Either user or host may be nil." | |
| (tramp-parse-file filename #'tramp-parse-rhosts-group)) | |
| (defun tramp-parse-rhosts-group () | |
| "Return a (user host) tuple allowed to access. | |
| Either user or host may be nil." | |
| (let (result | |
| (regexp | |
| (concat | |
| "^\\(" tramp-host-regexp "\\)" | |
| "\\([ \t]+" "\\(" tramp-user-regexp "\\)" "\\)?"))) | |
| (when (re-search-forward regexp (point-at-eol) t) | |
| (setq result (append (list (match-string 3) (match-string 1))))) | |
| (forward-line 1) | |
| result)) | |
| (defun tramp-parse-shosts (filename) | |
| "Return a list of (user host) tuples allowed to access. | |
| User is always nil." | |
| (tramp-parse-file filename #'tramp-parse-shosts-group)) | |
| (defun tramp-parse-shosts-group () | |
| "Return a (user host) tuple allowed to access. | |
| User is always nil." | |
| (tramp-parse-group (concat "^\\(" tramp-host-regexp "\\)") 1 ",")) | |
| (defun tramp-parse-sconfig (filename) | |
| "Return a list of (user host) tuples allowed to access. | |
| User is always nil." | |
| (tramp-parse-file filename #'tramp-parse-sconfig-group)) | |
| (defun tramp-parse-sconfig-group () | |
| "Return a (user host) tuple allowed to access. | |
| User is always nil." | |
| (tramp-parse-group | |
| (concat "\\(?:^[ \t]*Host\\)" "\\|" "\\(?:^.+\\)" | |
| "\\|" "\\(" tramp-host-regexp "\\)") | |
| 1 " \t")) | |
| ;; Generic function. | |
| (defun tramp-parse-shostkeys-sknownhosts (dirname regexp) | |
| "Return a list of (user host) tuples allowed to access. | |
| User is always nil." | |
| ;; On Windows, there are problems in completion when | |
| ;; `default-directory' is remote. | |
| (let* ((default-directory (tramp-compat-temporary-file-directory)) | |
| (files (and (file-directory-p dirname) (directory-files dirname)))) | |
| (cl-loop | |
| for f in files | |
| when (and (not (string-match "^\\.\\.?$" f)) (string-match regexp f)) | |
| collect (list nil (match-string 1 f))))) | |
| (defun tramp-parse-shostkeys (dirname) | |
| "Return a list of (user host) tuples allowed to access. | |
| User is always nil." | |
| (tramp-parse-shostkeys-sknownhosts | |
| dirname (concat "^key_[0-9]+_\\(" tramp-host-regexp "\\)\\.pub$"))) | |
| (defun tramp-parse-sknownhosts (dirname) | |
| "Return a list of (user host) tuples allowed to access. | |
| User is always nil." | |
| (tramp-parse-shostkeys-sknownhosts | |
| dirname | |
| (concat "^\\(" tramp-host-regexp "\\)\\.ssh-\\(dss\\|rsa\\)\\.pub$"))) | |
| (defun tramp-parse-hosts (filename) | |
| "Return a list of (user host) tuples allowed to access. | |
| User is always nil." | |
| (tramp-parse-file filename #'tramp-parse-hosts-group)) | |
| (defun tramp-parse-hosts-group () | |
| "Return a (user host) tuple allowed to access. | |
| User is always nil." | |
| (tramp-parse-group | |
| (concat "^\\(" tramp-ipv6-regexp "\\|" tramp-host-regexp "\\)") 1 " \t")) | |
| (defun tramp-parse-passwd (filename) | |
| "Return a list of (user host) tuples allowed to access. | |
| Host is always \"localhost\"." | |
| (with-tramp-connection-property nil "parse-passwd" | |
| (if (executable-find "getent") | |
| (with-temp-buffer | |
| (when (zerop (tramp-call-process nil "getent" nil t nil "passwd")) | |
| (goto-char (point-min)) | |
| (cl-loop while (not (eobp)) collect | |
| (tramp-parse-etc-group-group)))) | |
| (tramp-parse-file filename #'tramp-parse-passwd-group)))) | |
| (defun tramp-parse-passwd-group () | |
| "Return a (user host) tuple allowed to access. | |
| Host is always \"localhost\"." | |
| (let (result | |
| (regexp (concat "^\\(" tramp-user-regexp "\\):"))) | |
| (when (re-search-forward regexp (point-at-eol) t) | |
| (setq result (list (match-string 1) "localhost"))) | |
| (forward-line 1) | |
| result)) | |
| (defun tramp-parse-etc-group (filename) | |
| "Return a list of (group host) tuples allowed to access. | |
| Host is always \"localhost\"." | |
| (with-tramp-connection-property nil "parse-group" | |
| (if (executable-find "getent") | |
| (with-temp-buffer | |
| (when (zerop (tramp-call-process nil "getent" nil t nil "group")) | |
| (goto-char (point-min)) | |
| (cl-loop while (not (eobp)) collect | |
| (tramp-parse-etc-group-group)))) | |
| (tramp-parse-file filename #'tramp-parse-etc-group-group)))) | |
| (defun tramp-parse-etc-group-group () | |
| "Return a (group host) tuple allowed to access. | |
| Host is always \"localhost\"." | |
| (let (result | |
| (split (split-string (buffer-substring (point) (point-at-eol)) ":"))) | |
| (when (member (user-login-name) (split-string (nth 3 split) "," 'omit)) | |
| (setq result (list (nth 0 split) "localhost"))) | |
| (forward-line 1) | |
| result)) | |
| (defun tramp-parse-netrc (filename) | |
| "Return a list of (user host) tuples allowed to access. | |
| User may be nil." | |
| ;; The declaration is not sufficient at runtime, because netrc.el is | |
| ;; not autoloaded. | |
| (autoload 'netrc-parse "netrc") | |
| (mapcar | |
| (lambda (item) | |
| (and (assoc "machine" item) | |
| `(,(cdr (assoc "login" item)) ,(cdr (assoc "machine" item))))) | |
| (netrc-parse filename))) | |
| (defun tramp-parse-putty (registry-or-dirname) | |
| "Return a list of (user host) tuples allowed to access. | |
| User is always nil." | |
| (if (memq system-type '(windows-nt)) | |
| (with-tramp-connection-property nil "parse-putty" | |
| (with-temp-buffer | |
| (when (zerop (tramp-call-process | |
| nil "reg" nil t nil "query" registry-or-dirname)) | |
| (goto-char (point-min)) | |
| (cl-loop while (not (eobp)) collect | |
| (tramp-parse-putty-group registry-or-dirname))))) | |
| ;; UNIX case. | |
| (tramp-parse-shostkeys-sknownhosts | |
| registry-or-dirname (concat "^\\(" tramp-host-regexp "\\)$")))) | |
| (defun tramp-parse-putty-group (registry) | |
| "Return a (user host) tuple allowed to access. | |
| User is always nil." | |
| (let (result | |
| (regexp (concat (regexp-quote registry) "\\\\\\(.+\\)"))) | |
| (when (re-search-forward regexp (point-at-eol) t) | |
| (setq result (list nil (match-string 1)))) | |
| (forward-line 1) | |
| result)) | |
| ;;; Common file name handler functions for different backends: | |
| (defvar tramp-handle-file-local-copy-hook nil | |
| "Normal hook to be run at the end of `tramp-*-handle-file-local-copy'.") | |
| (defvar tramp-handle-write-region-hook nil | |
| "Normal hook to be run at the end of `tramp-*-handle-write-region'.") | |
| (defun tramp-handle-access-file (filename string) | |
| "Like `access-file' for Tramp files." | |
| (unless (file-readable-p (file-truename filename)) | |
| (tramp-error | |
| (tramp-dissect-file-name filename) tramp-file-missing | |
| "%s: No such file or directory %s" string filename))) | |
| (defun tramp-handle-add-name-to-file | |
| (filename newname &optional ok-if-already-exists) | |
| "Like `add-name-to-file' for Tramp files." | |
| (with-parsed-tramp-file-name | |
| (if (tramp-tramp-file-p newname) newname filename) nil | |
| (unless (tramp-equal-remote filename newname) | |
| (tramp-error | |
| v 'file-error | |
| "add-name-to-file: %s" | |
| "only implemented for same method, same user, same host")) | |
| ;; Do the 'confirm if exists' thing. | |
| (when (file-exists-p newname) | |
| ;; What to do? | |
| (if (or (null ok-if-already-exists) ; not allowed to exist | |
| (and (numberp ok-if-already-exists) | |
| (not (yes-or-no-p | |
| (format | |
| "File %s already exists; make it a link anyway? " | |
| localname))))) | |
| (tramp-error v 'file-already-exists newname) | |
| (delete-file newname))) | |
| (tramp-flush-file-properties v localname) | |
| (copy-file | |
| filename newname 'ok-if-already-exists 'keep-time | |
| 'preserve-uid-gid 'preserve-permissions))) | |
| (defun tramp-handle-copy-directory | |
| (directory newname &optional keep-date parents copy-contents) | |
| "Like `copy-directory' for Tramp files." | |
| ;; `copy-directory' creates NEWNAME before running this check. So | |
| ;; we do it ourselves. | |
| (unless (file-exists-p directory) | |
| (tramp-error | |
| (tramp-dissect-file-name directory) tramp-file-missing | |
| "No such file or directory" directory)) | |
| ;; We must do it file-wise. | |
| (tramp-run-real-handler | |
| 'copy-directory | |
| (list directory newname keep-date parents copy-contents))) | |
| (defun tramp-handle-directory-file-name (directory) | |
| "Like `directory-file-name' for Tramp files." | |
| ;; If localname component of filename is "/", leave it unchanged. | |
| ;; Otherwise, remove any trailing slash from localname component. | |
| ;; Method, host, etc, are unchanged. | |
| (while (with-parsed-tramp-file-name directory nil | |
| (and (not (zerop (length localname))) | |
| (eq (aref localname (1- (length localname))) ?/) | |
| (not (string= localname "/")))) | |
| (setq directory (substring directory 0 -1))) | |
| directory) | |
| (defun tramp-handle-directory-files (directory &optional full match nosort) | |
| "Like `directory-files' for Tramp files." | |
| (unless (file-exists-p directory) | |
| (tramp-error | |
| (tramp-dissect-file-name directory) tramp-file-missing | |
| "No such file or directory" directory)) | |
| (when (file-directory-p directory) | |
| (setq directory (file-name-as-directory (expand-file-name directory))) | |
| (let ((temp (nreverse (file-name-all-completions "" directory))) | |
| result item) | |
| (while temp | |
| (setq item (directory-file-name (pop temp))) | |
| (when (or (null match) (string-match-p match item)) | |
| (push (if full (concat directory item) item) | |
| result))) | |
| (if nosort result (sort result #'string<))))) | |
| (defun tramp-handle-directory-files-and-attributes | |
| (directory &optional full match nosort id-format) | |
| "Like `directory-files-and-attributes' for Tramp files." | |
| (mapcar | |
| (lambda (x) | |
| (cons x (file-attributes | |
| (if full x (expand-file-name x directory)) id-format))) | |
| (directory-files directory full match nosort))) | |
| (defun tramp-handle-dired-uncache (dir) | |
| "Like `dired-uncache' for Tramp files." | |
| (with-parsed-tramp-file-name | |
| (if (file-directory-p dir) dir (file-name-directory dir)) nil | |
| (tramp-flush-directory-properties v localname))) | |
| (defun tramp-handle-expand-file-name (name &optional dir) | |
| "Like `expand-file-name' for Tramp files." | |
| ;; If DIR is not given, use DEFAULT-DIRECTORY or "/". | |
| (setq dir (or dir default-directory "/")) | |
| ;; Handle empty NAME. | |
| (when (zerop (length name)) (setq name ".")) | |
| ;; Unless NAME is absolute, concat DIR and NAME. | |
| (unless (file-name-absolute-p name) | |
| (setq name (concat (file-name-as-directory dir) name))) | |
| ;; If NAME is not a Tramp file, run the real handler. | |
| (if (not (tramp-tramp-file-p name)) | |
| (tramp-run-real-handler #'expand-file-name (list name nil)) | |
| ;; Dissect NAME. | |
| (with-parsed-tramp-file-name name nil | |
| (unless (tramp-run-real-handler #'file-name-absolute-p (list localname)) | |
| (setq localname (concat "/" localname))) | |
| ;; Do normal `expand-file-name' (this does "/./" and "/../"). | |
| ;; `default-directory' is bound, because on Windows there would | |
| ;; be problems with UNC shares or Cygwin mounts. | |
| (let ((default-directory (tramp-compat-temporary-file-directory))) | |
| (tramp-make-tramp-file-name | |
| v (tramp-drop-volume-letter | |
| (tramp-run-real-handler #'expand-file-name (list localname)))))))) | |
| (defun tramp-handle-file-accessible-directory-p (filename) | |
| "Like `file-accessible-directory-p' for Tramp files." | |
| (and (file-directory-p filename) | |
| (file-readable-p filename))) | |
| (defun tramp-handle-file-directory-p (filename) | |
| "Like `file-directory-p' for Tramp files." | |
| (eq (tramp-compat-file-attribute-type | |
| (file-attributes (file-truename filename))) | |
| t)) | |
| (defun tramp-handle-file-equal-p (filename1 filename2) | |
| "Like `file-equalp-p' for Tramp files." | |
| ;; Native `file-equalp-p' calls `file-truename', which requires a | |
| ;; remote connection. This can be avoided, if FILENAME1 and | |
| ;; FILENAME2 are not located on the same remote host. | |
| (when (tramp-equal-remote | |
| (expand-file-name filename1) (expand-file-name filename2)) | |
| (tramp-run-real-handler #'file-equal-p (list filename1 filename2)))) | |
| (defun tramp-handle-file-exists-p (filename) | |
| "Like `file-exists-p' for Tramp files." | |
| ;; `file-exists-p' is used as predicate in file name completion. | |
| ;; We don't want to run it when `non-essential' is t, or there is | |
| ;; no connection process yet. | |
| (when (tramp-connectable-p filename) | |
| (not (null (file-attributes filename))))) | |
| (defun tramp-handle-file-in-directory-p (filename directory) | |
| "Like `file-in-directory-p' for Tramp files." | |
| ;; Native `file-in-directory-p' calls `file-truename', which | |
| ;; requires a remote connection. This can be avoided, if FILENAME | |
| ;; and DIRECTORY are not located on the same remote host. | |
| (when (tramp-equal-remote | |
| (expand-file-name filename) (expand-file-name directory)) | |
| (tramp-run-real-handler #'file-in-directory-p (list filename directory)))) | |
| (defun tramp-handle-file-local-copy (filename) | |
| "Like `file-local-copy' for Tramp files." | |
| (with-parsed-tramp-file-name filename nil | |
| (unless (file-exists-p filename) | |
| (tramp-error | |
| v tramp-file-missing | |
| "Cannot make local copy of non-existing file `%s'" filename)) | |
| (let ((tmpfile (tramp-compat-make-temp-file filename))) | |
| (copy-file filename tmpfile 'ok-if-already-exists 'keep-time) | |
| tmpfile))) | |
| (defun tramp-handle-file-modes (filename &optional flag) | |
| "Like `file-modes' for Tramp files." | |
| (when-let ((attrs (file-attributes filename)) | |
| (mode-string (tramp-compat-file-attribute-modes attrs))) | |
| (if (and (not (eq flag 'nofollow)) (eq ?l (aref mode-string 0))) | |
| (file-modes (file-truename filename)) | |
| (tramp-mode-string-to-int mode-string)))) | |
| ;; Localname manipulation functions that grok Tramp localnames... | |
| (defun tramp-handle-file-name-as-directory (file) | |
| "Like `file-name-as-directory' for Tramp files." | |
| ;; `file-name-as-directory' would be sufficient except localname is | |
| ;; the empty string. | |
| (let ((v (tramp-dissect-file-name file t))) | |
| ;; Run the command on the localname portion only unless we are in | |
| ;; completion mode. | |
| (tramp-make-tramp-file-name | |
| v (or (and (zerop (length (tramp-file-name-localname v))) | |
| (not (tramp-connectable-p file))) | |
| (tramp-run-real-handler | |
| #'file-name-as-directory | |
| (list (tramp-file-name-localname v))))))) | |
| (defun tramp-handle-file-name-case-insensitive-p (filename) | |
| "Like `file-name-case-insensitive-p' for Tramp files." | |
| ;; We make it a connection property, assuming that all file systems | |
| ;; on the remote host behave similar. This might be wrong for | |
| ;; mounted NFS directories or SMB/AFP shares; such more granular | |
| ;; tests will be added in case they are needed. | |
| (setq filename (expand-file-name filename)) | |
| (with-parsed-tramp-file-name filename nil | |
| (or ;; Maybe there is a default value. | |
| (tramp-get-method-parameter v 'tramp-case-insensitive) | |
| ;; There isn't. So we must check, in case there's a connection already. | |
| (and (file-remote-p filename nil 'connected) | |
| (with-tramp-connection-property v "case-insensitive" | |
| (ignore-errors | |
| (with-tramp-progress-reporter v 5 "Checking case-insensitive" | |
| ;; The idea is to compare a file with lower case | |
| ;; letters with the same file with upper case letters. | |
| (let ((candidate | |
| (tramp-compat-file-name-unquote | |
| (directory-file-name filename))) | |
| tmpfile) | |
| ;; Check, whether we find an existing file with | |
| ;; lower case letters. This avoids us to create a | |
| ;; temporary file. | |
| (while (and (string-match-p | |
| "[a-z]" (tramp-file-local-name candidate)) | |
| (not (file-exists-p candidate))) | |
| (setq candidate | |
| (directory-file-name | |
| (file-name-directory candidate)))) | |
| ;; Nothing found, so we must use a temporary file | |
| ;; for comparison. `make-nearby-temp-file' is added | |
| ;; to Emacs 26+ like `file-name-case-insensitive-p', | |
| ;; so there is no compatibility problem calling it. | |
| (unless | |
| (string-match-p "[a-z]" (tramp-file-local-name candidate)) | |
| (setq tmpfile | |
| (let ((default-directory | |
| (file-name-directory filename))) | |
| (tramp-compat-funcall | |
| 'make-nearby-temp-file "tramp.")) | |
| candidate tmpfile)) | |
| ;; Check for the existence of the same file with | |
| ;; upper case letters. | |
| (unwind-protect | |
| (file-exists-p | |
| (concat | |
| (file-remote-p candidate) | |
| (upcase (tramp-file-local-name candidate)))) | |
| ;; Cleanup. | |
| (when tmpfile (delete-file tmpfile))))))))))) | |
| (defun tramp-handle-file-name-completion | |
| (filename directory &optional predicate) | |
| "Like `file-name-completion' for Tramp files." | |
| (let (hits-ignored-extensions fnac) | |
| (setq fnac (file-name-all-completions filename directory)) | |
| ;; "." and ".." are never interesting as completions, and are | |
| ;; actually in the way in a directory with only one file. See | |
| ;; file_name_completion() in dired.c. | |
| (when (and (consp fnac) (= (length (delete "./" (delete "../" fnac))) 1)) | |
| (setq fnac (delete "./" (delete "../" fnac)))) | |
| (or | |
| (try-completion | |
| filename fnac | |
| (lambda (x) | |
| (when (funcall (or predicate #'identity) (expand-file-name x directory)) | |
| (not | |
| (and | |
| completion-ignored-extensions | |
| (string-match-p | |
| (concat (regexp-opt completion-ignored-extensions 'paren) "$") x) | |
| ;; We remember the hit. | |
| (push x hits-ignored-extensions)))))) | |
| ;; No match. So we try again for ignored files. | |
| (try-completion filename hits-ignored-extensions)))) | |
| (defun tramp-handle-file-name-directory (file) | |
| "Like `file-name-directory' for Tramp files." | |
| ;; Everything except the last filename thing is the directory. We | |
| ;; cannot apply `with-parsed-tramp-file-name', because this expands | |
| ;; the remote file name parts. | |
| (let ((v (tramp-dissect-file-name file t))) | |
| ;; Run the command on the localname portion only. If this returns | |
| ;; nil, mark also the localname part of `v' as nil. | |
| (tramp-make-tramp-file-name | |
| v (or (tramp-run-real-handler | |
| #'file-name-directory (list (tramp-file-name-localname v))) | |
| 'noloc)))) | |
| (defun tramp-handle-file-name-nondirectory (file) | |
| "Like `file-name-nondirectory' for Tramp files." | |
| (with-parsed-tramp-file-name file nil | |
| (tramp-run-real-handler #'file-name-nondirectory (list localname)))) | |
| (defun tramp-handle-file-newer-than-file-p (file1 file2) | |
| "Like `file-newer-than-file-p' for Tramp files." | |
| (cond | |
| ((not (file-exists-p file1)) nil) | |
| ((not (file-exists-p file2)) t) | |
| (t (time-less-p | |
| (tramp-compat-file-attribute-modification-time (file-attributes file2)) | |
| (tramp-compat-file-attribute-modification-time | |
| (file-attributes file1)))))) | |
| (defun tramp-handle-file-regular-p (filename) | |
| "Like `file-regular-p' for Tramp files." | |
| (and (file-exists-p filename) | |
| ;; Sometimes, `file-attributes' does not return a proper value | |
| ;; even if `file-exists-p' does. | |
| (when-let ((attr (file-attributes filename))) | |
| (eq ?- (aref (tramp-compat-file-attribute-modes attr) 0))))) | |
| (defun tramp-handle-file-remote-p (filename &optional identification connected) | |
| "Like `file-remote-p' for Tramp files." | |
| ;; We do not want traces in the debug buffer. | |
| (let ((tramp-verbose (min tramp-verbose 3))) | |
| (when (tramp-tramp-file-p filename) | |
| (let* ((v (tramp-dissect-file-name filename)) | |
| (p (tramp-get-connection-process v)) | |
| (c (and (process-live-p p) | |
| (tramp-get-connection-property p "connected" nil)))) | |
| ;; We expand the file name only, if there is already a connection. | |
| (with-parsed-tramp-file-name | |
| (if c (expand-file-name filename) filename) nil | |
| (and (or (not connected) c) | |
| (cond | |
| ((eq identification 'method) method) | |
| ;; Domain and port are appended to user and host, | |
| ;; respectively. | |
| ((eq identification 'user) (tramp-file-name-user-domain v)) | |
| ((eq identification 'host) (tramp-file-name-host-port v)) | |
| ((eq identification 'localname) localname) | |
| ((eq identification 'hop) hop) | |
| (t (tramp-make-tramp-file-name v 'noloc))))))))) | |
| (defun tramp-handle-file-selinux-context (_filename) | |
| "Like `file-selinux-context' for Tramp files." | |
| ;; Return nil context. | |
| '(nil nil nil nil)) | |
| (defun tramp-handle-file-symlink-p (filename) | |
| "Like `file-symlink-p' for Tramp files." | |
| (let ((x (tramp-compat-file-attribute-type (file-attributes filename)))) | |
| (and (stringp x) x))) | |
| (defun tramp-handle-file-truename (filename) | |
| "Like `file-truename' for Tramp files." | |
| ;; Preserve trailing "/". | |
| (funcall | |
| (if (directory-name-p filename) #'file-name-as-directory #'identity) | |
| ;; Quote properly. | |
| (funcall | |
| (if (tramp-compat-file-name-quoted-p filename) | |
| #'tramp-compat-file-name-quote #'identity) | |
| (let ((result (tramp-compat-file-name-unquote (expand-file-name filename))) | |
| (numchase 0) | |
| ;; Don't make the following value larger than necessary. | |
| ;; People expect an error message in a timely fashion when | |
| ;; something is wrong; otherwise they might think that Emacs | |
| ;; is hung. Of course, correctness has to come first. | |
| (numchase-limit 20) | |
| symlink-target) | |
| (with-parsed-tramp-file-name result v1 | |
| ;; We cache only the localname. | |
| (tramp-make-tramp-file-name | |
| v1 | |
| (with-tramp-file-property v1 v1-localname "file-truename" | |
| (while (and (setq symlink-target (file-symlink-p result)) | |
| (< numchase numchase-limit)) | |
| (setq numchase (1+ numchase) | |
| result | |
| (with-parsed-tramp-file-name (expand-file-name result) v2 | |
| (tramp-make-tramp-file-name | |
| v2 | |
| (if (stringp symlink-target) | |
| (if (file-remote-p symlink-target) | |
| (tramp-compat-file-name-quote symlink-target 'top) | |
| (expand-file-name | |
| symlink-target (file-name-directory v2-localname))) | |
| v2-localname) | |
| 'nohop))) | |
| (when (>= numchase numchase-limit) | |
| (tramp-error | |
| v1 'file-error | |
| "Maximum number (%d) of symlinks exceeded" numchase-limit))) | |
| (tramp-file-local-name (directory-file-name result))))))))) | |
| (defun tramp-handle-file-writable-p (filename) | |
| "Like `file-writable-p' for Tramp files." | |
| (with-parsed-tramp-file-name filename nil | |
| (with-tramp-file-property v localname "file-writable-p" | |
| (if (file-exists-p filename) | |
| (tramp-check-cached-permissions v ?w) | |
| ;; If file doesn't exist, check if directory is writable. | |
| (and (file-directory-p (file-name-directory filename)) | |
| (file-writable-p (file-name-directory filename))))))) | |
| (defun tramp-handle-find-backup-file-name (filename) | |
| "Like `find-backup-file-name' for Tramp files." | |
| (with-parsed-tramp-file-name filename nil | |
| (let ((backup-directory-alist | |
| (if tramp-backup-directory-alist | |
| (mapcar | |
| (lambda (x) | |
| (cons | |
| (car x) | |
| (if (and (stringp (cdr x)) | |
| (file-name-absolute-p (cdr x)) | |
| (not (tramp-tramp-file-p (cdr x)))) | |
| (tramp-make-tramp-file-name v (cdr x)) | |
| (cdr x)))) | |
| tramp-backup-directory-alist) | |
| backup-directory-alist))) | |
| (tramp-run-real-handler #'find-backup-file-name (list filename))))) | |
| (defun tramp-handle-insert-directory | |
| (filename switches &optional wildcard full-directory-p) | |
| "Like `insert-directory' for Tramp files." | |
| (unless switches (setq switches "")) | |
| ;; Mark trailing "/". | |
| (when (and (directory-name-p filename) | |
| (not full-directory-p)) | |
| (setq switches (concat switches "F"))) | |
| ;; Check, whether directory is accessible. | |
| (unless wildcard | |
| (access-file filename "Reading directory")) | |
| (with-parsed-tramp-file-name (expand-file-name filename) nil | |
| (with-tramp-progress-reporter v 0 (format "Opening directory %s" filename) | |
| (let (ls-lisp-use-insert-directory-program start) | |
| ;; Silence byte compiler. | |
| (ignore ls-lisp-use-insert-directory-program) | |
| (tramp-run-real-handler | |
| #'insert-directory | |
| (list filename switches wildcard full-directory-p)) | |
| ;; `ls-lisp' always returns full listings. We must remove | |
| ;; superfluous parts. | |
| (unless (string-match-p "l" switches) | |
| (save-excursion | |
| (goto-char (point-min)) | |
| (while (setq start | |
| (text-property-not-all | |
| (point) (point-at-eol) 'dired-filename t)) | |
| (delete-region | |
| start | |
| (or (text-property-any start (point-at-eol) 'dired-filename t) | |
| (point-at-eol))) | |
| (if (= (point-at-bol) (point-at-eol)) | |
| ;; Empty line. | |
| (delete-region (point) (progn (forward-line) (point))) | |
| (forward-line))))))))) | |
| (defun tramp-handle-insert-file-contents | |
| (filename &optional visit beg end replace) | |
| "Like `insert-file-contents' for Tramp files." | |
| (barf-if-buffer-read-only) | |
| (setq filename (expand-file-name filename)) | |
| (let (result local-copy remote-copy) | |
| (with-parsed-tramp-file-name filename nil | |
| (unwind-protect | |
| (if (not (file-exists-p filename)) | |
| (tramp-error | |
| v tramp-file-missing | |
| "File `%s' not found on remote host" filename) | |
| (with-tramp-progress-reporter | |
| v 3 (format-message "Inserting `%s'" filename) | |
| (condition-case err | |
| (if (and (tramp-local-host-p v) | |
| (let (file-name-handler-alist) | |
| (file-readable-p localname))) | |
| ;; Short track: if we are on the local host, we can | |
| ;; run directly. | |
| (setq result | |
| (tramp-run-real-handler | |
| #'insert-file-contents | |
| (list localname visit beg end replace))) | |
| ;; When we shall insert only a part of the file, we | |
| ;; copy this part. This works only for the shell file | |
| ;; name handlers. | |
| (when (and (or beg end) | |
| (tramp-get-method-parameter | |
| v 'tramp-login-program)) | |
| (setq remote-copy (tramp-make-tramp-temp-file v)) | |
| ;; This is defined in tramp-sh.el. Let's assume | |
| ;; this is loaded already. | |
| (tramp-compat-funcall | |
| 'tramp-send-command | |
| v | |
| (cond | |
| ((and beg end) | |
| (format "dd bs=1 skip=%d if=%s count=%d of=%s" | |
| beg (tramp-shell-quote-argument localname) | |
| (- end beg) remote-copy)) | |
| (beg | |
| (format "dd bs=1 skip=%d if=%s of=%s" | |
| beg (tramp-shell-quote-argument localname) | |
| remote-copy)) | |
| (end | |
| (format "dd bs=1 count=%d if=%s of=%s" | |
| end (tramp-shell-quote-argument localname) | |
| remote-copy)))) | |
| (setq tramp-temp-buffer-file-name nil beg nil end nil)) | |
| ;; `insert-file-contents-literally' takes care to | |
| ;; avoid calling jka-compr.el and epa.el. By | |
| ;; let-binding `inhibit-file-name-operation', we | |
| ;; propagate that care to the `file-local-copy' | |
| ;; operation. | |
| (setq local-copy | |
| (let ((inhibit-file-name-operation | |
| (when (eq inhibit-file-name-operation | |
| 'insert-file-contents) | |
| 'file-local-copy))) | |
| (cond | |
| ((stringp remote-copy) | |
| (file-local-copy | |
| (tramp-make-tramp-file-name | |
| v remote-copy 'nohop))) | |
| ((stringp tramp-temp-buffer-file-name) | |
| (copy-file | |
| filename tramp-temp-buffer-file-name 'ok) | |
| tramp-temp-buffer-file-name) | |
| (t (file-local-copy filename))))) | |
| ;; When the file is not readable for the owner, it | |
| ;; cannot be inserted, even if it is readable for the | |
| ;; group or for everybody. | |
| (set-file-modes local-copy #o0600) | |
| (when (and (null remote-copy) | |
| (tramp-get-method-parameter | |
| v 'tramp-copy-keep-tmpfile)) | |
| ;; We keep the local file for performance reasons, | |
| ;; useful for "rsync". | |
| (setq tramp-temp-buffer-file-name local-copy)) | |
| ;; We must ensure that `file-coding-system-alist' | |
| ;; matches `local-copy'. | |
| (let ((file-coding-system-alist | |
| (tramp-find-file-name-coding-system-alist | |
| filename local-copy))) | |
| (setq result | |
| (insert-file-contents | |
| local-copy visit beg end replace)))) | |
| (error | |
| (add-hook 'find-file-not-found-functions | |
| `(lambda () (signal ',(car err) ',(cdr err))) | |
| nil t) | |
| (signal (car err) (cdr err)))))) | |
| ;; Save exit. | |
| (progn | |
| (when visit | |
| (setq buffer-file-name filename | |
| buffer-read-only (not (file-writable-p filename))) | |
| (set-visited-file-modtime) | |
| (set-buffer-modified-p nil)) | |
| (when (and (stringp local-copy) | |
| (or remote-copy (null tramp-temp-buffer-file-name))) | |
| (delete-file local-copy)) | |
| (when (stringp remote-copy) | |
| (delete-file (tramp-make-tramp-file-name v remote-copy 'nohop))))) | |
| ;; Result. | |
| (list (expand-file-name filename) | |
| (cadr result))))) | |
| (defun tramp-handle-load (file &optional noerror nomessage nosuffix must-suffix) | |
| "Like `load' for Tramp files." | |
| (with-parsed-tramp-file-name (expand-file-name file) nil | |
| (unless nosuffix | |
| (cond ((file-exists-p (concat file ".elc")) | |
| (setq file (concat file ".elc"))) | |
| ((file-exists-p (concat file ".el")) | |
| (setq file (concat file ".el"))))) | |
| (when must-suffix | |
| ;; The first condition is always true for absolute file names. | |
| ;; Included for safety's sake. | |
| (unless (or (file-name-directory file) | |
| (string-match-p "\\.elc?\\'" file)) | |
| (tramp-error | |
| v 'file-error | |
| "File `%s' does not include a `.el' or `.elc' suffix" file))) | |
| (unless (or noerror (file-exists-p file)) | |
| (tramp-error | |
| v tramp-file-missing "Cannot load nonexistent file `%s'" file)) | |
| (if (not (file-exists-p file)) | |
| nil | |
| (let ((inhibit-message nomessage)) | |
| (with-tramp-progress-reporter v 0 (format "Loading %s" file) | |
| (let ((local-copy (file-local-copy file))) | |
| (unwind-protect | |
| (load local-copy noerror t nosuffix must-suffix) | |
| (delete-file local-copy))))) | |
| t))) | |
| (defun tramp-handle-make-symbolic-link | |
| (target linkname &optional ok-if-already-exists) | |
| "Like `make-symbolic-link' for Tramp files. | |
| This is the fallback implementation for backends which do not | |
| support symbolic links." | |
| (if (tramp-tramp-file-p (expand-file-name linkname)) | |
| (tramp-error | |
| (tramp-dissect-file-name (expand-file-name linkname)) 'file-error | |
| "make-symbolic-link not supported") | |
| ;; This is needed prior Emacs 26.1, where TARGET has also be | |
| ;; checked for a file name handler. | |
| (tramp-run-real-handler | |
| #'make-symbolic-link (list target linkname ok-if-already-exists)))) | |
| (defun tramp-handle-shell-command | |
| (command &optional output-buffer error-buffer) | |
| "Like `shell-command' for Tramp files." | |
| (let* ((asynchronous (string-match-p "[ \t]*&[ \t]*\\'" command)) | |
| (command (substring command 0 asynchronous)) | |
| current-buffer-p | |
| (output-buffer-p output-buffer) | |
| (output-buffer | |
| (cond | |
| ((bufferp output-buffer) | |
| (setq current-buffer-p (eq (current-buffer) output-buffer)) | |
| output-buffer) | |
| ((stringp output-buffer) | |
| (setq current-buffer-p | |
| (eq (buffer-name (current-buffer)) output-buffer)) | |
| (get-buffer-create output-buffer)) | |
| (output-buffer | |
| (setq current-buffer-p t) | |
| (current-buffer)) | |
| (t (get-buffer-create | |
| (if asynchronous | |
| "*Async Shell Command*" | |
| "*Shell Command Output*"))))) | |
| (error-buffer | |
| (cond | |
| ((bufferp error-buffer) error-buffer) | |
| ((stringp error-buffer) (get-buffer-create error-buffer)))) | |
| (error-file | |
| (and error-buffer | |
| (with-parsed-tramp-file-name default-directory nil | |
| (tramp-make-tramp-file-name | |
| v (tramp-make-tramp-temp-file v))))) | |
| (bname (buffer-name output-buffer)) | |
| (p (get-buffer-process output-buffer)) | |
| (dir default-directory) | |
| buffer) | |
| ;; The following code is taken from `shell-command', slightly | |
| ;; adapted. Shouldn't it be factored out? | |
| (when (and (integerp asynchronous) p) | |
| (cond | |
| ((eq async-shell-command-buffer 'confirm-kill-process) | |
| ;; If will kill a process, query first. | |
| (if (yes-or-no-p | |
| "A command is running in the default buffer. Kill it? ") | |
| (kill-process p) | |
| (tramp-user-error p "Shell command in progress"))) | |
| ((eq async-shell-command-buffer 'confirm-new-buffer) | |
| ;; If will create a new buffer, query first. | |
| (if (yes-or-no-p | |
| "A command is running in the default buffer. Use a new buffer? ") | |
| (setq output-buffer (generate-new-buffer bname)) | |
| (tramp-user-error p "Shell command in progress"))) | |
| ((eq async-shell-command-buffer 'new-buffer) | |
| ;; It will create a new buffer. | |
| (setq output-buffer (generate-new-buffer bname))) | |
| ((eq async-shell-command-buffer 'confirm-rename-buffer) | |
| ;; If will rename the buffer, query first. | |
| (if (yes-or-no-p | |
| "A command is running in the default buffer. Rename it? ") | |
| (progn | |
| (with-current-buffer output-buffer | |
| (rename-uniquely)) | |
| (setq output-buffer (get-buffer-create bname))) | |
| (tramp-user-error p "Shell command in progress"))) | |
| ((eq async-shell-command-buffer 'rename-buffer) | |
| ;; It will rename the buffer. | |
| (with-current-buffer output-buffer | |
| (rename-uniquely)) | |
| (setq output-buffer (get-buffer-create bname))))) | |
| (unless output-buffer-p | |
| (with-current-buffer output-buffer | |
| (setq default-directory dir))) | |
| (setq buffer (if error-file (list output-buffer error-file) output-buffer)) | |
| (with-current-buffer output-buffer | |
| (when current-buffer-p | |
| (barf-if-buffer-read-only) | |
| (push-mark nil t)) | |
| ;; `shell-command-save-pos-or-erase' has been introduced with | |
| ;; Emacs 27.1. | |
| (if (fboundp 'shell-command-save-pos-or-erase) | |
| (tramp-compat-funcall | |
| 'shell-command-save-pos-or-erase current-buffer-p) | |
| (setq buffer-read-only nil) | |
| (erase-buffer))) | |
| (if (integerp asynchronous) | |
| (let ((tramp-remote-process-environment | |
| ;; `async-shell-command-width' has been introduced with | |
| ;; Emacs 27.1. | |
| (if (natnump (bound-and-true-p async-shell-command-width)) | |
| (cons (format "COLUMNS=%d" | |
| (bound-and-true-p async-shell-command-width)) | |
| tramp-remote-process-environment) | |
| tramp-remote-process-environment))) | |
| (prog1 | |
| ;; Run the process. | |
| (setq p (start-file-process-shell-command | |
| (buffer-name output-buffer) buffer command)) | |
| ;; Insert error messages if they were separated. | |
| (when error-file | |
| (with-current-buffer error-buffer | |
| (insert-file-contents-literally error-file))) | |
| (if (process-live-p p) | |
| ;; Display output. | |
| (with-current-buffer output-buffer | |
| (setq mode-line-process '(":%s")) | |
| (unless (eq major-mode 'shell-mode) | |
| (shell-mode)) | |
| (set-process-filter p #'comint-output-filter) | |
| (set-process-sentinel p #'shell-command-sentinel) | |
| (when error-file | |
| (add-function | |
| :after (process-sentinel p) | |
| (lambda (_proc _string) | |
| (with-current-buffer error-buffer | |
| (insert-file-contents-literally | |
| error-file nil nil nil 'replace)) | |
| (delete-file error-file)))) | |
| (display-buffer output-buffer '(nil (allow-no-window . t)))) | |
| (when error-file | |
| (delete-file error-file))))) | |
| (prog1 | |
| ;; Run the process. | |
| (process-file-shell-command command nil buffer nil) | |
| ;; Insert error messages if they were separated. | |
| (when error-file | |
| (with-current-buffer error-buffer | |
| (insert-file-contents-literally error-file)) | |
| (delete-file error-file)) | |
| (if current-buffer-p | |
| ;; This is like exchange-point-and-mark, but doesn't | |
| ;; activate the mark. It is cleaner to avoid activation, | |
| ;; even though the command loop would deactivate the mark | |
| ;; because we inserted text. | |
| (progn | |
| (goto-char (prog1 (mark t) | |
| (set-marker (mark-marker) (point) | |
| (current-buffer)))) | |
| ;; `shell-command-set-point-after-cmd' has been | |
| ;; introduced with Emacs 27.1. | |
| (if (fboundp 'shell-command-set-point-after-cmd) | |
| (tramp-compat-funcall | |
| 'shell-command-set-point-after-cmd))) | |
| ;; There's some output, display it. | |
| (when (with-current-buffer output-buffer (> (point-max) (point-min))) | |
| (display-message-or-buffer output-buffer))))))) | |
| (defun tramp-handle-start-file-process (name buffer program &rest args) | |
| "Like `start-file-process' for Tramp files. | |
| BUFFER might be a list, in this case STDERR is separated." | |
| ;; `make-process' knows the `:file-handler' argument since Emacs 27.1 only. | |
| (tramp-file-name-handler | |
| 'make-process | |
| :name name | |
| :buffer (if (consp buffer) (car buffer) buffer) | |
| :command (and program (cons program args)) | |
| ;; `shell-command' adds an errfile to `buffer'. | |
| :stderr (when (consp buffer) (cadr buffer)) | |
| :noquery nil | |
| :file-handler t)) | |
| (defun tramp-handle-substitute-in-file-name (filename) | |
| "Like `substitute-in-file-name' for Tramp files. | |
| \"//\" and \"/~\" substitute only in the local filename part." | |
| ;; Check, whether the local part is a quoted file name. | |
| (if (tramp-compat-file-name-quoted-p filename) | |
| filename | |
| ;; First, we must replace environment variables. | |
| (setq filename (tramp-replace-environment-variables filename)) | |
| (with-parsed-tramp-file-name filename nil | |
| ;; We do not want to replace environment variables, again. "//" | |
| ;; has a special meaning at the beginning of a file name on | |
| ;; Cygwin and MS-Windows, we must remove it. | |
| (let (process-environment) | |
| ;; Ignore in LOCALNAME everything before "//" or "/~". | |
| (when (stringp localname) | |
| (if (string-match "//\\(/\\|~\\)" localname) | |
| (setq filename | |
| (replace-regexp-in-string | |
| "\\`/+" "/" (substitute-in-file-name localname))) | |
| (setq filename | |
| (concat (file-remote-p filename) | |
| (replace-regexp-in-string | |
| "\\`/+" "/" | |
| ;; We must disable cygwin-mount file name | |
| ;; handlers and alike. | |
| (tramp-run-real-handler | |
| #'substitute-in-file-name (list localname)))))))) | |
| ;; "/m:h:~" does not work for completion. We use "/m:h:~/". | |
| (if (and (stringp localname) (string-equal "~" localname)) | |
| (concat filename "/") | |
| filename)))) | |
| (defconst tramp-time-dont-know '(0 0 0 1000) | |
| "An invalid time value, used as \"Don't know\" value.") | |
| (defconst tramp-time-doesnt-exist '(-1 65535) | |
| "An invalid time value, used as \"Doesn't exist\" value.") | |
| (defun tramp-handle-set-visited-file-modtime (&optional time-list) | |
| "Like `set-visited-file-modtime' for Tramp files." | |
| (unless (buffer-file-name) | |
| (error "Can't set-visited-file-modtime: buffer `%s' not visiting a file" | |
| (buffer-name))) | |
| (unless time-list | |
| (let ((remote-file-name-inhibit-cache t)) | |
| (setq time-list | |
| (or (tramp-compat-file-attribute-modification-time | |
| (file-attributes (buffer-file-name))) | |
| tramp-time-doesnt-exist)))) | |
| (unless (tramp-compat-time-equal-p time-list tramp-time-dont-know) | |
| (tramp-run-real-handler #'set-visited-file-modtime (list time-list)))) | |
| (defun tramp-handle-verify-visited-file-modtime (&optional buf) | |
| "Like `verify-visited-file-modtime' for Tramp files. | |
| At the time `verify-visited-file-modtime' calls this function, we | |
| already know that the buffer is visiting a file and that | |
| `visited-file-modtime' does not return 0. Do not call this | |
| function directly, unless those two cases are already taken care | |
| of." | |
| (with-current-buffer (or buf (current-buffer)) | |
| (let ((f (buffer-file-name))) | |
| ;; There is no file visiting the buffer, or the buffer has no | |
| ;; recorded last modification time, or there is no established | |
| ;; connection. | |
| (if (or (not f) | |
| (eq (visited-file-modtime) 0) | |
| (not (file-remote-p f nil 'connected))) | |
| t | |
| (let* ((remote-file-name-inhibit-cache t) | |
| (attr (file-attributes f)) | |
| (modtime (tramp-compat-file-attribute-modification-time attr)) | |
| (mt (visited-file-modtime))) | |
| (cond | |
| ;; File exists, and has a known modtime. | |
| ((and attr | |
| (not (tramp-compat-time-equal-p modtime tramp-time-dont-know))) | |
| (< (abs (tramp-time-diff modtime mt)) 2)) | |
| ;; Modtime has the don't know value. | |
| (attr t) | |
| ;; If file does not exist, say it is not modified if and | |
| ;; only if that agrees with the buffer's record. | |
| (t (tramp-compat-time-equal-p mt tramp-time-doesnt-exist)))))))) | |
| (defun tramp-handle-write-region | |
| (start end filename &optional append visit lockname mustbenew) | |
| "Like `write-region' for Tramp files." | |
| (setq filename (expand-file-name filename)) | |
| (with-parsed-tramp-file-name filename nil | |
| (when (and mustbenew (file-exists-p filename) | |
| (or (eq mustbenew 'excl) | |
| (not | |
| (y-or-n-p | |
| (format "File %s exists; overwrite anyway? " filename))))) | |
| (tramp-error v 'file-already-exists filename)) | |
| (let ((tmpfile (tramp-compat-make-temp-file filename)) | |
| (modes (tramp-default-file-modes | |
| filename (and (eq mustbenew 'excl) 'nofollow)))) | |
| (when (and append (file-exists-p filename)) | |
| (copy-file filename tmpfile 'ok)) | |
| ;; The permissions of the temporary file should be set. If | |
| ;; FILENAME does not exist (eq modes nil) it has been | |
| ;; renamed to the backup file. This case `save-buffer' | |
| ;; handles permissions. | |
| ;; Ensure that it is still readable. | |
| (set-file-modes tmpfile (logior (or modes 0) #o0400)) | |
| ;; We say `no-message' here because we don't want the visited file | |
| ;; modtime data to be clobbered from the temp file. We call | |
| ;; `set-visited-file-modtime' ourselves later on. | |
| (tramp-run-real-handler | |
| #'write-region (list start end tmpfile append 'no-message lockname)) | |
| (condition-case nil | |
| (rename-file tmpfile filename 'ok-if-already-exists) | |
| (error | |
| (delete-file tmpfile) | |
| (tramp-error | |
| v 'file-error "Couldn't write region to `%s'" filename)))) | |
| (tramp-flush-file-properties v localname) | |
| ;; Set file modification time. | |
| (when (or (eq visit t) (stringp visit)) | |
| (set-visited-file-modtime | |
| (tramp-compat-file-attribute-modification-time | |
| (file-attributes filename)))) | |
| ;; The end. | |
| (when (and (null noninteractive) | |
| (or (eq visit t) (null visit) (stringp visit))) | |
| (tramp-message v 0 "Wrote %s" filename)) | |
| (run-hooks 'tramp-handle-write-region-hook))) | |
| ;; This is used in tramp-sh.el and tramp-sudoedit.el. | |
| (defconst tramp-stat-marker "/////" | |
| "Marker in stat commands for file attributes.") | |
| (defconst tramp-stat-quoted-marker "\\/\\/\\/\\/\\/" | |
| "Quoted marker in stat commands for file attributes.") | |
| ;; This is used in tramp-gvfs.el and tramp-sh.el. | |
| (defconst tramp-gio-events | |
| '("attribute-changed" "changed" "changes-done-hint" | |
| "created" "deleted" "moved" "pre-unmount" "unmounted") | |
| "List of events \"gio monitor\" could send.") | |
| ;; This is the default handler. tramp-gvfs.el and tramp-sh.el have | |
| ;; their own one. | |
| (defun tramp-handle-file-notify-add-watch (filename _flags _callback) | |
| "Like `file-notify-add-watch' for Tramp files." | |
| (setq filename (expand-file-name filename)) | |
| (with-parsed-tramp-file-name filename nil | |
| (tramp-error | |
| v 'file-notify-error "File notification not supported for `%s'" filename))) | |
| (defun tramp-handle-file-notify-rm-watch (proc) | |
| "Like `file-notify-rm-watch' for Tramp files." | |
| ;; The descriptor must be a process object. | |
| (unless (processp proc) | |
| (tramp-error proc 'file-notify-error "Not a valid descriptor %S" proc)) | |
| ;; There might |
View raw
(Sorry about that, but we can’t show files that are this big right now.)
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment