From: Stefan Kangas Date: Fri, 17 Jun 2022 09:52:20 +0000 (+0200) Subject: Delete most libraries obsolete since 24.1 and 24.3 X-Git-Tag: emacs-29.0.90~1447^2~1689 X-Git-Url: http://git.eshelyaron.com/gitweb/?a=commitdiff_plain;h=17b3f8d56e254f8f0478ce583451f02e6034ed48;p=emacs.git Delete most libraries obsolete since 24.1 and 24.3 Emacs 24.3 was released 10 years ago. * lisp/obsolete/abbrevlist.el: * lisp/obsolete/assoc.el: * lisp/obsolete/complete.el: * lisp/obsolete/cust-print.el: * lisp/obsolete/erc-hecomplete.el: * lisp/obsolete/mailpost.el: * lisp/obsolete/mouse-sel.el: * lisp/obsolete/old-emacs-lock.el: * lisp/obsolete/patcomp.el: * lisp/obsolete/pc-select.el: * lisp/obsolete/s-region.el: Delete files. These libraries have been obsolete since Emacs 24.1 or 24.3. (Bug#50999) * etc/NEWS: Announce their deletion. * lisp/minibuffer.el (minibuffer-confirm-exit-commands): * lisp/textmodes/rst.el: Remove references to above obsolete libraries. --- diff --git a/etc/NEWS b/etc/NEWS index e19b2f5ebaf..dd7996b2775 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -2004,6 +2004,12 @@ functions. --- ** '?\' at the end of a line now signals an error. Previously it produced a nonsense value, -1, that was never intended. + +** Some libraries obsolete since Emacs 24.1 and 24.3 have been removed: +abbrevlist.el, assoc.el, complete.el, cust-print.el, +erc-hecomplete.el, mailpost.el, mouse-sel.el, old-emacs-lock.el, +patcomp.el, pc-select.el, s-region.el, and sregex.el. + * Lisp Changes in Emacs 29.1 diff --git a/lisp/minibuffer.el b/lisp/minibuffer.el index 23251a54746..e42d83af342 100644 --- a/lisp/minibuffer.el +++ b/lisp/minibuffer.el @@ -1677,8 +1677,8 @@ DONT-CYCLE tells the function not to setup cycling." map))))))))) (defvar minibuffer-confirm-exit-commands - '(completion-at-point minibuffer-complete - minibuffer-complete-word PC-complete PC-complete-word) + '( completion-at-point minibuffer-complete + minibuffer-complete-word) "List of commands which cause an immediately following `minibuffer-complete-and-exit' to ask for extra confirmation.") diff --git a/lisp/obsolete/abbrevlist.el b/lisp/obsolete/abbrevlist.el deleted file mode 100644 index ca508a15544..00000000000 --- a/lisp/obsolete/abbrevlist.el +++ /dev/null @@ -1,56 +0,0 @@ -;;; abbrevlist.el --- list one abbrev table alphabetically ordered -*- lexical-binding: t; -*- - -;; Copyright (C) 1986, 1992, 2001-2022 Free Software Foundation, Inc. -;; Suggested by a previous version by Gildea. - -;; Maintainer: emacs-devel@gnu.org -;; Keywords: abbrev -;; Package: emacs -;; Obsolete-since: 24.1 - -;; 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 . - -;;; Commentary: - -;;; Code: - -;;;###autoload -(defun list-one-abbrev-table (abbrev-table output-buffer) - "Display alphabetical listing of ABBREV-TABLE in buffer OUTPUT-BUFFER." - (with-output-to-temp-buffer output-buffer - (save-excursion - (let ((abbrev-list nil) (first-column 0)) - (set-buffer standard-output) - (mapatoms - (function (lambda (abbrev) - (setq abbrev-list (cons abbrev abbrev-list)))) - abbrev-table) - (setq abbrev-list (sort abbrev-list #'string-lessp)) - (while abbrev-list - (if (> (+ first-column 40) (window-width)) - (progn - (insert "\n") - (setq first-column 0))) - (indent-to first-column) - (insert (symbol-name (car abbrev-list))) - (indent-to (+ first-column 8)) - (insert (symbol-value (car abbrev-list))) - (setq first-column (+ first-column 40)) - (setq abbrev-list (cdr abbrev-list))))))) - -(provide 'abbrevlist) - -;;; abbrevlist.el ends here diff --git a/lisp/obsolete/assoc.el b/lisp/obsolete/assoc.el deleted file mode 100644 index 76fcb4b78b8..00000000000 --- a/lisp/obsolete/assoc.el +++ /dev/null @@ -1,140 +0,0 @@ -;;; assoc.el --- insert/delete functions on association lists -*- lexical-binding: t -*- - -;; Copyright (C) 1996, 2001-2022 Free Software Foundation, Inc. - -;; Author: Barry A. Warsaw -;; Keywords: extensions -;; Obsolete-since: 24.3 - -;; 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 . - -;;; Commentary: - -;; Association list utilities providing insertion, deletion, sorting -;; fetching off key-value pairs in association lists. - -;;; Code: - -(defun asort (alist-symbol key) - "Move a specified key-value pair to the head of an alist. -The alist is referenced by ALIST-SYMBOL. Key-value pair to move to -head is one matching KEY. Returns the sorted list and doesn't affect -the order of any other key-value pair. Side effect sets alist to new -sorted list." - (set alist-symbol - (sort (copy-alist (symbol-value alist-symbol)) - (lambda (a _b) (equal (car a) key))))) - - -(defun aelement (key value) - "Make a list of a cons cell containing car of KEY and cdr of VALUE. -The returned list is suitable for concatenating with an existing -alist, via `nconc'." - (list (cons key value))) - - -(defun aheadsym (alist) - "Return the key symbol at the head of ALIST." - (car (car alist))) - - -(defun anot-head-p (alist key) - "Find out if a specified key-value pair is not at the head of an alist. -The alist to check is specified by ALIST and the key-value pair is the -one matching the supplied KEY. Returns nil if ALIST is nil, or if -key-value pair is at the head of the alist. Returns t if key-value -pair is not at the head of alist. ALIST is not altered." - (not (equal (aheadsym alist) key))) - - -(defun aput (alist-symbol key &optional value) - "Insert a key-value pair into an alist. -The alist is referenced by ALIST-SYMBOL. The key-value pair is made -from KEY and optionally, VALUE. Returns the altered alist. - -If the key-value pair referenced by KEY can be found in the alist, and -VALUE is supplied non-nil, then the value of KEY will be set to VALUE. -If VALUE is not supplied, or is nil, the key-value pair will not be -modified, but will be moved to the head of the alist. If the key-value -pair cannot be found in the alist, it will be inserted into the head -of the alist (with value nil if VALUE is nil or not supplied)." - (let ((elem (aelement key value)) - alist) - (asort alist-symbol key) - (setq alist (symbol-value alist-symbol)) - (cond ((null alist) (set alist-symbol elem)) - ((anot-head-p alist key) (set alist-symbol (nconc elem alist))) - (value (setcar alist (car elem)) alist) - (t alist)))) - - -(defun adelete (alist-symbol key) - "Delete a key-value pair from the alist. -Alist is referenced by ALIST-SYMBOL and the key-value pair to remove -is pair matching KEY. Returns the altered alist." - (asort alist-symbol key) - (let ((alist (symbol-value alist-symbol))) - (cond ((null alist) nil) - ((anot-head-p alist key) alist) - (t (set alist-symbol (cdr alist)))))) - - -(defun aget (alist key &optional keynil-p) - "Return the value in ALIST that is associated with KEY. -Optional KEYNIL-P describes what to do if the value associated with -KEY is nil. If KEYNIL-P is not supplied or is nil, and the value is -nil, then KEY is returned. If KEYNIL-P is non-nil, then nil would be -returned. - -If no key-value pair matching KEY could be found in ALIST, or ALIST is -nil then nil is returned. ALIST is not altered." - (defvar assoc--copy) - (let ((assoc--copy (copy-alist alist))) - (cond ((null alist) nil) - ((progn (asort 'assoc--copy key) ; dynamic binding - (anot-head-p assoc--copy key)) nil) - ((cdr (car assoc--copy))) - (keynil-p nil) - ((car (car assoc--copy))) - (t nil)))) - - -(defun amake (alist-symbol keylist &optional valuelist) - "Make an association list. -The association list is attached to the alist referenced by -ALIST-SYMBOL. Each element in the KEYLIST becomes a key and is -associated with the value in VALUELIST with the same index. If -VALUELIST is not supplied or is nil, then each key in KEYLIST is -associated with nil. - -KEYLIST and VALUELIST should have the same number of elements, but -this isn't enforced. If VALUELIST is smaller than KEYLIST, remaining -keys are associated with nil. If VALUELIST is larger than KEYLIST, -extra values are ignored. Returns the created alist." - (let ((keycar (car keylist)) - (keycdr (cdr keylist)) - (valcar (car valuelist)) - (valcdr (cdr valuelist))) - (cond ((null keycdr) - (aput alist-symbol keycar valcar)) - (t - (amake alist-symbol keycdr valcdr) - (aput alist-symbol keycar valcar)))) - (symbol-value alist-symbol)) - -(provide 'assoc) - -;;; assoc.el ends here diff --git a/lisp/obsolete/complete.el b/lisp/obsolete/complete.el deleted file mode 100644 index 1b4c39b159d..00000000000 --- a/lisp/obsolete/complete.el +++ /dev/null @@ -1,1122 +0,0 @@ -;;; complete.el --- partial completion mechanism plus other goodies -*- lexical-binding: t; -*- - -;; Copyright (C) 1990-1993, 1999-2022 Free Software Foundation, Inc. - -;; Author: Dave Gillespie -;; Keywords: abbrev convenience -;; Obsolete-since: 24.1 -;; -;; Special thanks to Hallvard Furuseth for his many ideas and contributions. - -;; 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 . - -;;; Commentary: - -;; Extended completion for the Emacs minibuffer. -;; -;; The basic idea is that the command name or other completable text is -;; divided into words and each word is completed separately, so that -;; "M-x p-b" expands to "M-x print-buffer". If the entry is ambiguous -;; each word is completed as much as possible and then the cursor is -;; left at the first position where typing another letter will resolve -;; the ambiguity. -;; -;; Word separators for this purpose are hyphen, space, and period. -;; These would most likely occur in command names, Info menu items, -;; and file names, respectively. But all word separators are treated -;; alike at all times. -;; -;; This completion package replaces the old-style completer's key -;; bindings for TAB, SPC, RET, and `?'. The old completer is still -;; available on the Meta versions of those keys. If you set -;; PC-meta-flag to nil, the old completion keys will be left alone -;; and the partial completer will use the Meta versions of the keys. - - -;; Usage: M-x partial-completion-mode. During completable minibuffer entry, -;; -;; TAB means to do a partial completion; -;; SPC means to do a partial complete-word; -;; RET means to do a partial complete-and-exit; -;; ? means to do a partial completion-help. -;; -;; If you set PC-meta-flag to nil, then TAB, SPC, RET, and ? perform -;; original Emacs completions, and M-TAB etc. do partial completion. -;; To do this, put the command, -;; -;; (setq PC-meta-flag nil) -;; -;; in your .emacs file. To load partial completion automatically, put -;; -;; (partial-completion-mode t) -;; -;; in your .emacs file, too. Things will be faster if you byte-compile -;; this file when you install it. -;; -;; As an extra feature, in cases where RET would not normally -;; complete (such as `C-x b'), the M-RET key will always do a partial -;; complete-and-exit. Thus `C-x b f.c RET' will select or create a -;; buffer called "f.c", but `C-x b f.c M-RET' will select the existing -;; buffer whose name matches that pattern (perhaps "filing.c"). -;; (PC-meta-flag does not affect this behavior; M-RET used to be -;; undefined in this situation.) -;; -;; The regular M-TAB (lisp-complete-symbol) command also supports -;; partial completion in this package. - -;; In addition, this package includes a feature for accessing include -;; files. For example, `C-x C-f RET' reads the file -;; /usr/include/sys/time.h. The variable PC-include-file-path is a -;; list of directories in which to search for include files. Completion -;; is supported in include file names. - - -;;; Code: - -(defgroup partial-completion nil - "Partial Completion of items." - :prefix "pc-" - :group 'minibuffer - :group 'convenience) - -(defcustom PC-first-char 'find-file - "Control how the first character of a string is to be interpreted. -If nil, the first character of a string is not taken literally if it is a word -delimiter, so that \".e\" matches \"*.e*\". -If t, the first character of a string is always taken literally even if it is a -word delimiter, so that \".e\" matches \".e*\". -If non-nil and non-t, the first character is taken literally only for file name -completion." - :type '(choice (const :tag "delimiter" nil) - (const :tag "literal" t) - (other :tag "find-file" find-file))) - -(defcustom PC-meta-flag t - "If non-nil, TAB means PC completion and M-TAB means normal completion. -Otherwise, TAB means normal completion and M-TAB means Partial Completion." - :type 'boolean) - -(defcustom PC-word-delimiters "-_. " - "A string of characters treated as word delimiters for completion. -Some arcane rules: -If `]' is in this string, it must come first. -If `^' is in this string, it must not come first. -If `-' is in this string, it must come first or right after `]'. -In other words, if S is this string, then `[S]' must be a valid Emacs regular -expression (not containing character ranges like `a-z')." - :type 'string) - -(defcustom PC-include-file-path '("/usr/include" "/usr/local/include") - "A list of directories in which to look for include files. -If nil, means use the colon-separated path in the variable $INCPATH instead." - :type '(repeat directory)) - -(defcustom PC-disable-includes nil - "If non-nil, include-file support in \\[find-file] is disabled." - :type 'boolean) - -(defvar PC-default-bindings t - "If non-nil, default partial completion key bindings are suppressed.") - -(defvar PC-env-vars-alist nil - "A list of the environment variable names and values.") - - -(defun PC-bindings (bind) - (let ((completion-map minibuffer-local-completion-map) - (must-match-map minibuffer-local-must-match-map)) - (cond ((not bind) - ;; These bindings are the default bindings. It would be better to - ;; restore the previous bindings. - (define-key read-expression-map "\e\t" #'completion-at-point) - - (define-key completion-map "\t" #'minibuffer-complete) - (define-key completion-map " " #'minibuffer-complete-word) - (define-key completion-map "?" #'minibuffer-completion-help) - - (define-key must-match-map "\r" #'minibuffer-complete-and-exit) - (define-key must-match-map "\n" #'minibuffer-complete-and-exit) - - (define-key global-map [remap lisp-complete-symbol] nil)) - (PC-default-bindings - (define-key read-expression-map "\e\t" #'PC-lisp-complete-symbol) - - (define-key completion-map "\t" #'PC-complete) - (define-key completion-map " " #'PC-complete-word) - (define-key completion-map "?" #'PC-completion-help) - - (define-key completion-map "\e\t" #'PC-complete) - (define-key completion-map "\e " #'PC-complete-word) - (define-key completion-map "\e\r" #'PC-force-complete-and-exit) - (define-key completion-map "\e\n" #'PC-force-complete-and-exit) - (define-key completion-map "\e?" #'PC-completion-help) - - (define-key must-match-map "\r" #'PC-complete-and-exit) - (define-key must-match-map "\n" #'PC-complete-and-exit) - - (define-key must-match-map "\e\r" #'PC-complete-and-exit) - (define-key must-match-map "\e\n" #'PC-complete-and-exit) - - (define-key global-map [remap lisp-complete-symbol] #'PC-lisp-complete-symbol))))) - -(defvar PC-do-completion-end nil - "Internal variable used by `PC-do-completion'.") - -(make-variable-buffer-local 'PC-do-completion-end) - -(defvar PC-goto-end nil - "Internal variable set in `PC-do-completion', used in -`choose-completion-string-functions'.") - -(make-variable-buffer-local 'PC-goto-end) - -;;;###autoload -(define-minor-mode partial-completion-mode - "Toggle Partial Completion mode. - -When Partial Completion mode is enabled, TAB (or M-TAB if `PC-meta-flag' is -nil) is enhanced so that if some string is divided into words and each word is -delimited by a character in `PC-word-delimiters', partial words are completed -as much as possible and `*' characters are treated likewise in file names. - -For example, M-x p-c-m expands to M-x partial-completion-mode since no other -command begins with that sequence of characters, and -\\[find-file] f_b.c TAB might complete to foo_bar.c if that file existed and no -other file in that directory begins with that sequence of characters. - -Unless `PC-disable-includes' is non-nil, the `<...>' sequence is interpreted -specially in \\[find-file]. For example, -\\[find-file] RET finds the file `/usr/include/sys/time.h'. -See also the variable `PC-include-file-path'. - -Partial Completion mode extends the meaning of `completion-auto-help' (which -see), so that if it is neither nil nor t, Emacs shows the `*Completions*' -buffer only on the second attempt to complete. That is, if TAB finds nothing -to complete, the first TAB just says \"Next char not unique\" and the -second TAB brings up the `*Completions*' buffer." - :global t - ;; Deal with key bindings... - (PC-bindings partial-completion-mode) - ;; Deal with include file feature... - (cond ((not partial-completion-mode) - (remove-hook 'find-file-not-found-functions - #'PC-look-for-include-file)) - ((not PC-disable-includes) - (add-hook 'find-file-not-found-functions #'PC-look-for-include-file))) - ;; Adjust the completion selection in *Completion* buffers to the way - ;; we work. The default minibuffer completion code only completes the - ;; text before point and leaves the text after point alone (new in - ;; Emacs-22). In contrast we use the whole text and we even sometimes - ;; move point to a place before EOB, to indicate the first position where - ;; there's a difference, so when the user uses choose-completion, we have - ;; to trick choose-completion into replacing the whole minibuffer text - ;; rather than only the text before point. --Stef - (funcall - (if partial-completion-mode #'add-hook #'remove-hook) - 'choose-completion-string-functions - (lambda (_choice buffer &rest _) - ;; When completing M-: (lisp- ) with point before the ), it is - ;; not appropriate to go to point-max (unlike the filename case). - (if (and (not PC-goto-end) - (minibufferp buffer)) - (goto-char (point-max)) - ;; Need a similar hack for the non-minibuffer-case -- gm. - (when PC-do-completion-end - (goto-char PC-do-completion-end) - (setq PC-do-completion-end nil))) - (setq PC-goto-end nil) - nil)) - ;; Build the env-completion and mapping table. - (when (and partial-completion-mode (null PC-env-vars-alist)) - (setq PC-env-vars-alist - (mapcar (lambda (string) - (let ((d (string-search "=" string))) - (cons (concat "$" (substring string 0 d)) - (and d (substring string (1+ d)))))) - process-environment)))) - - -(defun PC-complete () - "Like minibuffer-complete, but allows \"b--di\"-style abbreviations. -For example, \"M-x b--di\" would match `byte-recompile-directory', or any -name which consists of three or more words, the first beginning with \"b\" -and the third beginning with \"di\". - -The pattern \"b--d\" is ambiguous for `byte-recompile-directory' and -`beginning-of-defun', so this would produce a list of completions -just like when normal Emacs completions are ambiguous. - -Word-delimiters for the purposes of Partial Completion are \"-\", \"_\", -\".\", and SPC." - (interactive) - (if (PC-was-meta-key) - (minibuffer-complete) - ;; If the previous command was not this one, - ;; never scroll, always retry completion. - (or (eq last-command this-command) - (setq minibuffer-scroll-window nil)) - (let ((window minibuffer-scroll-window)) - ;; If there's a fresh completion window with a live buffer, - ;; and this command is repeated, scroll that window. - (if (and window (window-buffer window) - (buffer-name (window-buffer window))) - (with-current-buffer (window-buffer window) - (if (pos-visible-in-window-p (point-max) window) - (set-window-start window (point-min) nil) - (scroll-other-window))) - (PC-do-completion nil))))) - - -(defun PC-complete-word () - "Like `minibuffer-complete-word', but allows \"b--di\"-style abbreviations. -See `PC-complete' for details. -This can be bound to other keys, like `-' and `.', if you wish." - (interactive) - (if (eq (PC-was-meta-key) PC-meta-flag) - (if (eq last-command-event ? ) - (minibuffer-complete-word) - (self-insert-command 1)) - (self-insert-command 1) - (if (eobp) - (PC-do-completion 'word)))) - - -(defun PC-complete-space () - "Like `minibuffer-complete-word', but allows \"b--di\"-style abbreviations. -See `PC-complete' for details. -This is suitable for binding to other keys which should act just like SPC." - (interactive) - (if (eq (PC-was-meta-key) PC-meta-flag) - (minibuffer-complete-word) - (insert " ") - (if (eobp) - (PC-do-completion 'word)))) - - -(defun PC-complete-and-exit () - "Like `minibuffer-complete-and-exit', but allows \"b--di\"-style abbreviations. -See `PC-complete' for details." - (interactive) - (if (eq (PC-was-meta-key) PC-meta-flag) - (minibuffer-complete-and-exit) - (PC-do-complete-and-exit))) - -(defun PC-force-complete-and-exit () - "Like `minibuffer-complete-and-exit', but allows \"b--di\"-style abbreviations. -See `PC-complete' for details." - (interactive) - (let ((minibuffer-completion-confirm nil)) - (PC-do-complete-and-exit))) - -(defun PC-do-complete-and-exit () - (cond - ((= (point-max) (minibuffer-prompt-end)) - ;; Duplicate the "bug" that Info-menu relies on... - (exit-minibuffer)) - ((eq minibuffer-completion-confirm 'confirm) - (if (or (eq last-command this-command) - (test-completion (field-string) - minibuffer-completion-table - minibuffer-completion-predicate)) - (exit-minibuffer) - (PC-temp-minibuffer-message " [Confirm]"))) - ((eq minibuffer-completion-confirm 'confirm-after-completion) - ;; Similar to the above, but only if trying to exit immediately - ;; after typing TAB (this catches most minibuffer typos). - (if (and (memq last-command minibuffer-confirm-exit-commands) - (not (test-completion (field-string) - minibuffer-completion-table - minibuffer-completion-predicate))) - (PC-temp-minibuffer-message " [Confirm]") - (exit-minibuffer))) - (t - (let ((flag (PC-do-completion 'exit))) - (and flag - (if (or (eq flag 'complete) - (not minibuffer-completion-confirm)) - (exit-minibuffer) - (PC-temp-minibuffer-message " [Confirm]"))))))) - - -(defun PC-completion-help () - "Like `minibuffer-completion-help', but allows \"b--di\"-style abbreviations. -See `PC-complete' for details." - (interactive) - (if (eq (PC-was-meta-key) PC-meta-flag) - (minibuffer-completion-help) - (PC-do-completion 'help))) - -(defun PC-was-meta-key () - (or (/= (length (this-command-keys)) 1) - (let ((key (aref (this-command-keys) 0))) - (if (integerp key) - (>= key 128) - (not (null (memq 'meta (event-modifiers key)))))))) - - -(defvar PC-ignored-extensions 'empty-cache) -(defvar PC-delims 'empty-cache) -(defvar PC-ignored-regexp nil) -(defvar PC-word-failed-flag nil) -(defvar PC-delim-regex nil) -(defvar PC-ndelims-regex nil) -(defvar PC-delims-list nil) - -(defvar PC-completion-as-file-name-predicate - (lambda () minibuffer-completing-file-name) - "A function testing whether a minibuffer completion now will work filename-style. -The function takes no arguments, and typically looks at the value -of `minibuffer-completion-table' and the minibuffer contents.") - -;; Returns the sequence of non-delimiter characters that follow regexp in string. -(defun PC-chunk-after (string regexp) - (if (not (string-match regexp string)) - (let ((message "String %s didn't match regexp %s")) - (message message string regexp) - (error message string regexp))) - (let ((result (substring string (match-end 0)))) - ;; result may contain multiple chunks - (if (string-match PC-delim-regex result) - (setq result (substring result 0 (match-beginning 0)))) - result)) - -(defun test-completion-ignore-case (str table pred) - "Like `test-completion', but ignores case when possible." - ;; Binding completion-ignore-case to nil ensures, for compatibility with - ;; standard completion, that the return value is exactly one of the - ;; possibilities. Do this binding only if pred is nil, out of paranoia; - ;; perhaps it is safe even if pred is non-nil. - (if pred - (test-completion str table pred) - (let ((completion-ignore-case nil)) - (test-completion str table pred)))) - -;; The following function is an attempt to work around two problems: - -;; (1) When complete.el was written, (try-completion "" '(("") (""))) used to -;; return the value "". With a change from 2002-07-07 it returns t which caused -;; `PC-lisp-complete-symbol' to fail with a "Wrong type argument: sequencep, t" -;; error. `PC-try-completion' returns STRING in this case. - -;; (2) (try-completion "" '((""))) returned t before the above-mentioned change. -;; Since `PC-chop-word' operates on the return value of `try-completion' this -;; case might have provoked a similar error as in (1). `PC-try-completion' -;; returns "" instead. I don't know whether this is a real problem though. - -;; Since `PC-try-completion' is not a guaranteed to fix these bugs reliably, you -;; should try to look at the following discussions when you encounter problems: -;; - emacs-pretest-bug ("Partial Completion" starting 2007-02-23), -;; - emacs-devel ("[address-of-OP: Partial completion]" starting 2007-02-24), -;; - emacs-devel ("[address-of-OP: EVAL and mouse selection in *Completions*]" -;; starting 2007-03-05). -(defun PC-try-completion (string alist &optional predicate) - "Like `try-completion' but return STRING instead of t." - (let ((result (try-completion string alist predicate))) - (if (eq result t) string result))) - -(defvar completion-base-size) - -;; TODO document MODE magic... -(defun PC-do-completion (&optional mode beg end goto-end) - "Internal function to do the work of partial completion. -Text to be completed lies between BEG and END. Normally when -replacing text in the minibuffer, this function replaces up to -point-max (as is appropriate for completing a file name). If -GOTO-END is non-nil, however, it instead replaces up to END." - (or beg (setq beg (minibuffer-prompt-end))) - (or end (setq end (point-max))) - (let* ((table (if (eq minibuffer-completion-table 'read-file-name-internal) - 'PC-read-file-name-internal - minibuffer-completion-table)) - (pred minibuffer-completion-predicate) - (filename (funcall PC-completion-as-file-name-predicate)) - (dirname nil) ; non-nil only if a filename is being completed - ;; The following used to be "(dirlength 0)" which caused the erasure of - ;; the entire buffer text before `point' when inserting a completion - ;; into a buffer. - dirlength - (str (buffer-substring beg end)) - (incname (and filename (string-match "<\\([^\"<>]*\\)>?$" str))) - (ambig nil) - basestr origstr - env-on - regex - p offset - abbreviated - (poss nil) - helpposs - (case-fold-search completion-ignore-case)) - - ;; Check if buffer contents can already be considered complete - (if (and (eq mode 'exit) - (test-completion str table pred)) - 'complete - - ;; Do substitutions in directory names - (and filename - (setq basestr (or (file-name-directory str) "")) - (setq dirlength (length basestr)) - ;; Do substitutions in directory names - (setq p (substitute-in-file-name basestr)) - (not (string-equal basestr p)) - (setq str (concat p (file-name-nondirectory str))) - (progn - (delete-region beg end) - (insert str) - (setq end (+ beg (length str))))) - - ;; Prepare various delimiter strings - (or (equal PC-word-delimiters PC-delims) - (setq PC-delims PC-word-delimiters - PC-delim-regex (concat "[" PC-delims "]") - PC-ndelims-regex (concat "[^" PC-delims "]*") - PC-delims-list (append PC-delims nil))) - - ;; Add wildcards if necessary - (and filename - (let ((dir (file-name-directory str)) - (file (file-name-nondirectory str)) - ;; The base dir for file-completion was passed in `predicate'. - (default-directory (if (stringp pred) (expand-file-name pred) - default-directory))) - (while (and (stringp dir) (not (file-directory-p dir))) - (setq dir (directory-file-name dir)) - (setq file (concat (replace-regexp-in-string - PC-delim-regex "*\\&" - (file-name-nondirectory dir)) - "*/" file)) - (setq dir (file-name-directory dir))) - (setq origstr str str (concat dir file)))) - - ;; Look for wildcard expansions in directory name - (and filename - (string-match "\\*.*/" str) - (let ((pat str) - ;; The base dir for file-completion was passed in `predicate'. - (default-directory (if (stringp pred) (expand-file-name pred) - default-directory)) - files) - (setq p (1+ (string-match "/[^/]*\\'" pat))) - (while (setq p (string-match PC-delim-regex pat p)) - (setq pat (concat (substring pat 0 p) - "*" - (substring pat p)) - p (+ p 2))) - (setq files (file-expand-wildcards (concat pat "*"))) - (if files - (let ((dir (file-name-directory (car files))) - (p files)) - (while (and (setq p (cdr p)) - (equal dir (file-name-directory (car p))))) - (if p - (setq filename nil table nil - pred (if (stringp pred) nil pred) - ambig t) - (delete-region beg end) - (setq str (concat dir (file-name-nondirectory str))) - (insert str) - (setq end (+ beg (length str))))) - (if origstr - ;; If the wildcards were introduced by us, it's - ;; possible that PC-read-file-name-internal can - ;; still find matches for the original string - ;; even if we couldn't, so remove the added - ;; wildcards. - (setq str origstr) - (setq filename nil table nil - pred (if (stringp pred) nil pred)))))) - - ;; Strip directory name if appropriate - (if filename - (if incname - (setq basestr (substring str incname) - dirname (substring str 0 incname)) - (setq basestr (file-name-nondirectory str) - dirname (file-name-directory str)) - ;; Make sure str is consistent with its directory and basename - ;; parts. This is important on DOZe'NT systems when str only - ;; includes a drive letter, like in "d:". - (setq str (concat dirname basestr))) - (setq basestr str)) - - ;; Convert search pattern to a standard regular expression - (setq regex (regexp-quote basestr) - offset (if (and (> (length regex) 0) - (not (eq (aref basestr 0) ?\*)) - (or (eq PC-first-char t) - (and PC-first-char filename))) 1 0) - p offset) - (while (setq p (string-match PC-delim-regex regex p)) - (if (eq (aref regex p) ? ) - (setq regex (concat (substring regex 0 p) - PC-ndelims-regex - PC-delim-regex - (substring regex (1+ p))) - p (+ p (length PC-ndelims-regex) (length PC-delim-regex))) - (let ((bump (if (memq (aref regex p) - '(?$ ?^ ?\. ?* ?+ ?? ?\[ ?\] ?\\)) - -1 0))) - (setq regex (concat (substring regex 0 (+ p bump)) - PC-ndelims-regex - (substring regex (+ p bump))) - p (+ p (length PC-ndelims-regex) 1))))) - (setq p 0) - (if filename - (while (setq p (string-search "\\*" regex p)) - (setq regex (concat (substring regex 0 p) - "[^/]*" - (substring regex (+ p 2)))))) - ;;(setq the-regex regex) - (setq regex (concat "\\`" regex)) - - (and (> (length basestr) 0) - (= (aref basestr 0) ?$) - (setq env-on t - table PC-env-vars-alist - pred nil)) - - ;; Find an initial list of possible completions - (unless (setq p (string-match (concat PC-delim-regex - (if filename "\\|\\*" "")) - str - (+ (length dirname) offset))) - - ;; Minibuffer contains no hyphens -- simple case! - (setq poss (all-completions (if env-on basestr str) - table - pred)) - (unless (or poss (string-equal str "")) - ;; Try completion as an abbreviation, e.g. "mvb" -> - ;; "m-v-b" -> "multiple-value-bind", but only for - ;; non-empty strings. - (setq origstr str - abbreviated t) - (if filename - (cond - ;; "alpha" or "/alpha" -> expand whole path. - ((string-match "^/?\\([A-Za-z0-9]+\\)$" str) - (setq - basestr "" - p nil - poss (file-expand-wildcards - (concat "/" - (mapconcat #'list (match-string 1 str) "*/") - "*")) - beg (1- beg))) - ;; Alphanumeric trailer -> expand trailing file - ((string-match "^\\(.+/\\)\\([A-Za-z0-9]+\\)$" str) - (setq regex (concat "\\`" - (mapconcat #'list - (match-string 2 str) - "[A-Za-z0-9]*[^A-Za-z0-9]")) - p (1+ (length (match-string 1 str)))))) - (setq regex (concat "\\`" (mapconcat (lambda (c) - (regexp-quote (string c))) - str "[^-]*-")) - p 1)))) - (when p - ;; Use all-completions to do an initial cull. This is a big win, - ;; since all-completions is written in C! - (let ((compl (all-completions (if env-on - (file-name-nondirectory (substring str 0 p)) - (substring str 0 p)) - table - pred))) - (setq p compl) - (when (and compl abbreviated) - (if filename - (progn - (setq p nil) - (dolist (x compl) - (when (string-match regex x) - (push x p))) - (setq basestr (try-completion "" p))) - (setq basestr (mapconcat #'list str "-")) - (delete-region beg end) - (setq end (+ beg (length basestr))) - (insert basestr)))) - (while p - (and (string-match regex (car p)) - (progn - (set-text-properties 0 (length (car p)) '() (car p)) - (setq poss (cons (car p) poss)))) - (setq p (cdr p)))) - - ;; If table had duplicates, they can be here. - (delete-dups poss) - - ;; Handle completion-ignored-extensions - (and filename - (not (eq mode 'help)) - (let ((p2 poss)) - - ;; Build a regular expression representing the extensions list - (or (equal completion-ignored-extensions PC-ignored-extensions) - (setq PC-ignored-regexp - (concat "\\(" - (mapconcat - #'regexp-quote - (setq PC-ignored-extensions - completion-ignored-extensions) - "\\|") - "\\)\\'"))) - - ;; Check if there are any without an ignored extension. - ;; Also ignore `.' and `..'. - (setq p nil) - (while p2 - (or (string-match PC-ignored-regexp (car p2)) - (string-match "\\(\\`\\|/\\)[.][.]?/?\\'" (car p2)) - (setq p (cons (car p2) p))) - (setq p2 (cdr p2))) - - ;; If there are "good" names, use them - (and p (setq poss p)))) - - ;; Now we have a list of possible completions - - (cond - - ;; No valid completions found - ((null poss) - (if (and (eq mode 'word) - (not PC-word-failed-flag)) - (let ((PC-word-failed-flag t)) - (delete-char -1) - (PC-do-completion 'word)) - (when abbreviated - (delete-region beg end) - (insert origstr)) - (beep) - (PC-temp-minibuffer-message (if ambig - " [Ambiguous dir name]" - (if (eq mode 'help) - " [No completions]" - " [No match]"))) - nil)) - - ;; More than one valid completion found - ((or (cdr (setq helpposs poss)) - (memq mode '(help word))) - - ;; Is the actual string one of the possible completions? - (setq p (and (not (eq mode 'help)) poss)) - (while (and p - (not (string-equal (car p) basestr))) - (setq p (cdr p))) - (and p (null mode) - (PC-temp-minibuffer-message " [Complete, but not unique]")) - (if (and p - (not (and (null mode) - (eq this-command last-command)))) - t - - ;; If ambiguous, try for a partial completion - (let ((improved nil) - prefix - (pt nil) - (skip "\\`")) - - ;; Check if next few letters are the same in all cases - (if (and (not (eq mode 'help)) - (setq prefix (PC-try-completion - (PC-chunk-after basestr skip) poss))) - (let ((first t) i) - (if (eq mode 'word) - (setq prefix (PC-chop-word prefix basestr))) - (goto-char (+ beg (length dirname))) - (while (and (progn - (setq i 0) ; index into prefix string - (while (< i (length prefix)) - (if (and (< (point) end) - (or (eq (downcase (aref prefix i)) - (downcase (following-char))) - (and (looking-at " ") - (memq (aref prefix i) - PC-delims-list)))) - ;; replace " " by the actual delimiter - ;; or input char by prefix char - (progn - (delete-char 1) - (insert (substring prefix i (1+ i)))) - ;; insert a new character - (progn - (and filename (looking-at "\\*") - (progn - (delete-char 1) - (setq end (1- end)))) - (setq improved t) - (insert (substring prefix i (1+ i))) - (setq end (1+ end)))) - (setq i (1+ i))) - (or pt (setq pt (point))) - (looking-at PC-delim-regex)) - (setq skip (concat skip - (regexp-quote prefix) - PC-ndelims-regex) - prefix (PC-try-completion - (PC-chunk-after - ;; not basestr, because that does - ;; not reflect insertions - (buffer-substring - (+ beg (length dirname)) end) - skip) - (mapcar - (lambda (x) - (when (string-match skip x) - (substring x (match-end 0)))) - poss))) - (or (> i 0) (> (length prefix) 0)) - (or (not (eq mode 'word)) - (and first (> (length prefix) 0) - (setq first nil - prefix (substring prefix 0 1)))))) - (goto-char (if (eq mode 'word) end - (or pt beg))))) - - (if (and (eq mode 'word) - (not PC-word-failed-flag)) - - (if improved - - ;; We changed it... would it be complete without the space? - (if (test-completion (buffer-substring - (field-beginning) (1- end)) - table pred) - (delete-region (1- end) end))) - - (if improved - - ;; We changed it... enough to be complete? - (and (eq mode 'exit) - (test-completion-ignore-case (field-string) table pred)) - - ;; If totally ambiguous, display a list of completions - (if (or (eq completion-auto-help t) - (and completion-auto-help - (eq last-command this-command)) - (eq mode 'help)) - (let ((prompt-end (minibuffer-prompt-end))) - (with-output-to-temp-buffer "*Completions*" - (display-completion-list (sort helpposs #'string-lessp)) - (setq PC-do-completion-end end - PC-goto-end goto-end) - (with-current-buffer standard-output - ;; Record which part of the buffer we are completing - ;; so that choosing a completion from the list - ;; knows how much old text to replace. - ;; This was briefly nil in the non-dirname case. - ;; However, if one calls PC-lisp-complete-symbol - ;; on "(ne-f" with point on the hyphen, PC offers - ;; all completions starting with "(ne", some of - ;; which do not match the "-f" part (maybe it - ;; should not, but it does). In such cases, - ;; completion gets confused trying to figure out - ;; how much to replace, so we tell it explicitly - ;; (ie, the number of chars in the buffer before beg). - ;; - ;; Note that choose-completion-string-functions - ;; plays around with point. - (with-suppressed-warnings ((obsolete - completion-base-size)) - (setq completion-base-size - (if dirname - dirlength - (- beg prompt-end))))))) - (PC-temp-minibuffer-message " [Next char not unique]")) - ;; Expansion of filenames is not reversible, - ;; so just keep the prefix. - (when (and abbreviated filename) - (delete-region (point) end)) - nil))))) - - ;; Only one possible completion - (t - (if (and (equal basestr (car poss)) - (not (and env-on filename)) - (not abbreviated)) - (if (null mode) - (PC-temp-minibuffer-message " [Sole completion]")) - (delete-region beg end) - (insert (format "%s" - (if filename - (substitute-in-file-name (concat dirname (car poss))) - (car poss))))) - t))))) - -(defun PC-chop-word (new old) - (let ((i -1) - (j -1)) - (while (and (setq i (string-match PC-delim-regex old (1+ i))) - (setq j (string-match PC-delim-regex new (1+ j))))) - (if (and j - (or (not PC-word-failed-flag) - (setq j (string-match PC-delim-regex new (1+ j))))) - (substring new 0 (1+ j)) - new))) - -(defvar PC-not-minibuffer nil) - -(defun PC-temp-minibuffer-message (message) - "A Lisp version of `temp_minibuffer_message' from minibuf.c." - (cond (PC-not-minibuffer - (message "%s" message) - (sit-for 2) - (message "")) - ((fboundp 'temp-minibuffer-message) - (temp-minibuffer-message message)) - (t - (let ((point-max (point-max))) - (save-excursion - (goto-char point-max) - (insert message)) - (let ((inhibit-quit t)) - (sit-for 2) - (delete-region point-max (point-max)) - (when quit-flag - (setq quit-flag nil - unread-command-events '(7)))))))) - -;; Does not need to be buffer-local (?) because only used when one -;; PC-l-c-s immediately follows another. -(defvar PC-lisp-complete-end nil - "Internal variable used by `PC-lisp-complete-symbol'.") - -(defun PC-lisp-complete-symbol () - "Perform completion on Lisp symbol preceding point. -That symbol is compared against the symbols that exist -and any additional characters determined by what is there -are inserted. -If the symbol starts just after an open-parenthesis, -only symbols with function definitions are considered. -Otherwise, all symbols with function definitions, values -or properties are considered." - (interactive) - (let* ((end - (save-excursion - (with-syntax-table lisp-mode-syntax-table - (skip-syntax-forward "_w") - (point)))) - (beg (save-excursion - (with-syntax-table lisp-mode-syntax-table - (backward-sexp 1) - (while (= (char-syntax (following-char)) ?\') - (forward-char 1)) - (point)))) - (minibuffer-completion-table obarray) - (minibuffer-completion-predicate - (if (eq (char-after (1- beg)) ?\() - 'fboundp - (function (lambda (sym) - (or (boundp sym) (fboundp sym) - (symbol-plist sym)))))) - (PC-not-minibuffer t)) - ;; https://lists.gnu.org/r/emacs-devel/2007-03/msg01211.html - ;; - ;; This deals with cases like running PC-l-c-s on "M-: (n-f". - ;; The first call to PC-l-c-s expands this to "(ne-f", and moves - ;; point to the hyphen [1]. If one calls PC-l-c-s immediately after, - ;; then without the last-command check, one is offered all - ;; completions of "(ne", which is presumably not what one wants. - ;; - ;; This is arguably (at least, it seems to be the existing intended - ;; behavior) what one _does_ want if point has been explicitly - ;; positioned on the hyphen. Note that if PC-do-completion (qv) binds - ;; completion-base-size to nil, then completion does not replace the - ;; correct amount of text in such cases. - ;; - ;; Neither of these problems occur when using PC for filenames in the - ;; minibuffer, because in that case PC-do-completion is called without - ;; an explicit value for END, and so uses (point-max). This is fine for - ;; a filename, because the end of the filename must be at the end of - ;; the minibuffer. The same is not true for lisp symbols. - ;; - ;; [1] An alternate fix would be to not move point to the hyphen - ;; in such cases, but that would make the behavior different from - ;; that for filenames. It seems PC moves point to the site of the - ;; first difference between the possible completions. - ;; - ;; Alternatively alternatively, maybe end should be computed in - ;; the same way as beg. That would change the behavior though. - (if (equal last-command 'PC-lisp-complete-symbol) - (PC-do-completion nil beg PC-lisp-complete-end t) - (if PC-lisp-complete-end - (move-marker PC-lisp-complete-end end) - (setq PC-lisp-complete-end (copy-marker end t))) - (PC-do-completion nil beg end t)))) - -(defun PC-complete-as-file-name () - "Perform completion on file names preceding point. - Environment vars are converted to their values." - (interactive) - (let* ((end (point)) - (beg (if (re-search-backward "[^\\][ \t\n\"`'][^ \t\n\"`']" - (point-min) t) - (+ (point) 2) - (point-min))) - (minibuffer-completion-table 'PC-read-file-name-internal) - (minibuffer-completion-predicate nil) - (PC-not-minibuffer t)) - (goto-char end) - (PC-do-completion nil beg end))) - -;; Facilities for loading C header files. This is independent from the -;; main completion code. See also the variable `PC-include-file-path' -;; at top of this file. - -(defun PC-look-for-include-file () - (if (string-match "[\"<]\\([^\"<>]*\\)[\">]?$" (buffer-file-name)) - (let ((name (substring (buffer-file-name) - (match-beginning 1) (match-end 1))) - (punc (aref (buffer-file-name) (match-beginning 0))) - (path nil) - new-buf) - (kill-buffer (current-buffer)) - (if (equal name "") - (with-current-buffer (car (buffer-list)) - (save-excursion - (beginning-of-line) - (if (looking-at - "[ \t]*#[ \t]*include[ \t]+[<\"]\\(.+\\)[>\"][ \t]*[\n/]") - (setq name (buffer-substring (match-beginning 1) - (match-end 1)) - punc (char-after (1- (match-beginning 1)))) - ;; Suggested by Frank Siebenlist: - (if (or (looking-at - "[ \t]*([ \t]*load[ \t]+\"\\([^\"]+\\)\"") - (looking-at - "[ \t]*([ \t]*load-library[ \t]+\"\\([^\"]+\\)\"") - (looking-at - "[ \t]*([ \t]*require[ \t]+'\\([^\t )]+\\)[\t )]")) - (progn - (setq name (buffer-substring (match-beginning 1) - (match-end 1)) - punc ?\< - path load-path) - (if (string-match "\\.elc$" name) - (setq name (substring name 0 -1)) - (or (string-match "\\.el$" name) - (setq name (concat name ".el"))))) - (error "Not on an #include line")))))) - (or (string-match "\\.[[:alnum:]]+$" name) - (setq name (concat name ".h"))) - (if (eq punc ?\<) - (let ((path (or path (PC-include-file-path)))) - (while (and path - (not (file-exists-p - (concat (file-name-as-directory (car path)) - name)))) - (setq path (cdr path))) - (if path - (setq name (concat (file-name-as-directory (car path)) name)) - (error "No such include file: <%s>" name))) - (let ((dir (with-current-buffer (car (buffer-list)) - default-directory))) - (if (file-exists-p (concat dir name)) - (setq name (concat dir name)) - (error "No such include file: `%s'" name)))) - (setq new-buf (get-file-buffer name)) - (if new-buf - ;; no need to verify last-modified time for this! - (set-buffer new-buf) - (set-buffer (create-file-buffer name)) - (erase-buffer) - (insert-file-contents name t)) - ;; Returning non-nil with the new buffer current - ;; is sufficient to tell find-file to use it. - t) - nil)) - -(defun PC-include-file-path () - (or PC-include-file-path - (let ((env (getenv "INCPATH")) - (path nil) - pos) - (or env (error "No include file path specified")) - (while (setq pos (string-match ":[^:]+$" env)) - (setq path (cons (substring env (1+ pos)) path) - env (substring env 0 pos))) - path))) - -;; This is adapted from lib-complete.el, by Mike Williams. -(defun PC-include-file-all-completions (file search-path &optional full) - "Return all completions for FILE in any directory on SEARCH-PATH. -If optional third argument FULL is non-nil, returned pathnames should be -absolute rather than relative to some directory on the SEARCH-PATH." - (setq search-path - (mapcar (lambda (dir) - (if dir (file-name-as-directory dir) default-directory)) - search-path)) - (if (file-name-absolute-p file) - ;; It's an absolute file name, so don't need search-path - (progn - (setq file (expand-file-name file)) - (file-name-all-completions - (file-name-nondirectory file) (file-name-directory file))) - (let ((subdir (file-name-directory file)) - (ndfile (file-name-nondirectory file)) - file-lists) - ;; Append subdirectory part to each element of search-path - (if subdir - (setq search-path - (mapcar (lambda (dir) (concat dir subdir)) - search-path) - file nil)) - ;; Make list of completions in each directory on search-path - (while search-path - (let* ((dir (car search-path)) - (subdir (if full dir subdir))) - (if (file-directory-p dir) - (progn - (setq file-lists - (cons - (mapcar (lambda (file) (concat subdir file)) - (file-name-all-completions ndfile - (car search-path))) - file-lists)))) - (setq search-path (cdr search-path)))) - ;; Compress out duplicates while building complete list (slloooow!) - (let ((sorted (sort (apply #'nconc file-lists) - (lambda (x y) (not (string-lessp x y))))) - compressed) - (while sorted - (if (equal (car sorted) (car compressed)) nil - (setq compressed (cons (car sorted) compressed))) - (setq sorted (cdr sorted))) - compressed)))) - -(defun PC-read-file-name-internal (string pred action) - "Extend `read-file-name-internal' to handle include files. -This is only used by " - (if (string-match "<\\([^\"<>]*\\)>?\\'" string) - (let* ((name (match-string 1 string)) - (str2 (substring string (match-beginning 0))) - (completion-table - (mapcar (lambda (x) - (format (if (string-match "/\\'" x) "<%s" "<%s>") x)) - (PC-include-file-all-completions - name (PC-include-file-path))))) - (cond - ((not completion-table) nil) - ((eq action 'lambda) (test-completion str2 completion-table nil)) - ((eq action nil) (PC-try-completion str2 completion-table nil)) - ((eq action t) (all-completions str2 completion-table nil)))) - (read-file-name-internal string pred action))) - - -(provide 'complete) - -;;; complete.el ends here diff --git a/lisp/obsolete/cust-print.el b/lisp/obsolete/cust-print.el deleted file mode 100644 index 80ded086545..00000000000 --- a/lisp/obsolete/cust-print.el +++ /dev/null @@ -1,674 +0,0 @@ -;;; cust-print.el --- handles print-level and print-circle -*- lexical-binding: t; -*- - -;; Copyright (C) 1992, 2001-2022 Free Software Foundation, Inc. - -;; Author: Daniel LaLiberte -;; Adapted-By: ESR -;; Keywords: extensions -;; Obsolete-since: 24.3 - -;; LCD Archive Entry: -;; cust-print|Daniel LaLiberte|liberte@holonexus.org -;; |Handle print-level, print-circle and more. - -;; 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 . - -;;; Commentary: - -;; This package provides a general print handler for prin1 and princ -;; that supports print-level and print-circle, and by the way, -;; print-length since the standard routines are being replaced. Also, -;; to print custom types constructed from lists and vectors, use -;; custom-print-list and custom-print-vector. See the documentation -;; strings of these variables for more details. - -;; If the results of your expressions contain circular references to -;; other parts of the same structure, the standard Emacs print -;; subroutines may fail to print with an untrappable error, -;; "Apparently circular structure being printed". If you only use cdr -;; circular lists (where cdrs of lists point back; what is the right -;; term here?), you can limit the length of printing with -;; print-length. But car circular lists and circular vectors generate -;; the above mentioned error in Emacs version 18. Version -;; 19 supports print-level, but it is often useful to get a better -;; print representation of circular and shared structures; the print-circle -;; option may be used to print more concise representations. - -;; There are three main ways to use this package. First, you may -;; replace prin1, princ, and some subroutines that use them by calling -;; install-custom-print so that any use of these functions in -;; Lisp code will be affected; you can later reset with -;; uninstall-custom-print. Second, you may temporarily install -;; these functions with the macro with-custom-print. Third, you -;; could call the custom routines directly, thus only affecting the -;; printing that requires them. - -;; Note that subroutines which call print subroutines directly will -;; not use the custom print functions. In particular, the evaluation -;; functions like eval-region call the print subroutines directly. -;; Therefore, if you evaluate (aref circ-list 0), where circ-list is a -;; circular list rather than an array, aref calls error directly which -;; will jump to the top level instead of printing the circular list. - -;; Uninterned symbols are recognized when print-circle is non-nil, -;; but they are not printed specially here. Use the cl-packages package -;; to print according to print-gensym. - -;; Obviously the right way to implement this custom-print facility is -;; in C or with hooks into the standard printer. Please volunteer -;; since I don't have the time or need. More CL-like printing -;; capabilities could be added in the future. - -;; Implementation design: we want to use the same list and vector -;; processing algorithm for all versions of prin1 and princ, since how -;; the processing is done depends on print-length, print-level, and -;; print-circle. For circle printing, a preprocessing step is -;; required before the final printing. Thanks to Jamie Zawinski -;; for motivation and algorithms. - - -;;; Code: - -(defgroup cust-print nil - "Handles print-level and print-circle." - :prefix "print-" - :group 'lisp - :group 'extensions) - -;; If using cl-packages: - -'(defpackage "cust-print" - (:nicknames "CP" "custom-print") - (:use "el") - (:export - print-level - print-circle - - custom-print-install - custom-print-uninstall - custom-print-installed-p - with-custom-print - - custom-prin1 - custom-princ - custom-prin1-to-string - custom-print - custom-format - custom-message - custom-error - - custom-printers - add-custom-printer - )) - -'(in-package cust-print) - -;; Emacs 18 doesn't have defalias. -;; Provide def for byte compiler. - -;; Variables: -;;========================================================= - -;;(defvar print-length nil -;; "*Controls how many elements of a list, at each level, are printed. -;;This is defined by emacs.") - -(defcustom print-level nil - "Controls how many levels deep a nested data object will print. - -If nil, printing proceeds recursively and may lead to -max-lisp-eval-depth being exceeded or an error may occur: -`Apparently circular structure being printed.' -Also see `print-length' and `print-circle'. - -If non-nil, components at levels equal to or greater than `print-level' -are printed simply as `#'. The object to be printed is at level 0, -and if the object is a list or vector, its top-level components are at -level 1." - :type '(choice (const nil) integer)) - - -(defcustom print-circle nil - "Controls the printing of recursive structures. - -If nil, printing proceeds recursively and may lead to -`max-lisp-eval-depth' being exceeded or an error may occur: -\"Apparently circular structure being printed.\" Also see -`print-length' and `print-level'. - -If non-nil, shared substructures anywhere in the structure are printed -with `#N=' before the first occurrence (in the order of the print -representation) and `#N#' in place of each subsequent occurrence, -where N is a positive decimal integer." - :type 'boolean) - - -(defcustom custom-print-vectors nil - "Non-nil if printing of vectors should obey `print-level' and `print-length'." - :type 'boolean) - - -;; Custom printers -;;========================================================== - -(defvar custom-printers nil - ;; e.g. '((symbolp . pkg::print-symbol)) - "An alist for custom printing of any type. -Pairs are of the form (PREDICATE . PRINTER). If PREDICATE is true -for an object, then PRINTER is called with the object. -PRINTER should print to `standard-output' using cust-print-original-princ -if the standard printer is sufficient, or cust-print-prin for complex things. -The PRINTER should return the object being printed. - -Don't modify this variable directly. Use `add-custom-printer' and -`delete-custom-printer'") -;; Should cust-print-original-princ and cust-print-prin be exported symbols? -;; Or should the standard printers functions be replaced by -;; CP ones in Emacs Lisp so that CP internal functions need not be called? - -(defun add-custom-printer (pred printer) - "Add a pair of PREDICATE and PRINTER to `custom-printers'. -Any pair that has the same PREDICATE is first removed." - (setq custom-printers (cons (cons pred printer) - (delq (assq pred custom-printers) - custom-printers))) - ;; Rather than updating here, we could wait until cust-print-top-level is called. - (cust-print-update-custom-printers)) - -(defun delete-custom-printer (pred) - "Delete the custom printer associated with PREDICATE." - (setq custom-printers (delq (assq pred custom-printers) - custom-printers)) - (cust-print-update-custom-printers)) - - -(defun cust-print-use-custom-printer (_object) - ;; Default function returns nil. - nil) - -(defun cust-print-update-custom-printers () - ;; Modify the definition of cust-print-use-custom-printer - (defalias 'cust-print-use-custom-printer - ;; We don't really want to require the byte-compiler. - ;; (byte-compile - `(lambda (object) - (cond - ,@(mapcar (function - (lambda (pair) - `((,(car pair) object) - (,(cdr pair) object)))) - custom-printers) - ;; Otherwise return nil. - (t nil) - )) - ;; ) - )) - - -;; Saving and restoring emacs printing routines. -;;==================================================== - -(defun cust-print-set-function-cell (symbol-pair) - (defalias (car symbol-pair) - (symbol-function (car (cdr symbol-pair))))) - -(defun cust-print-original-princ (_object &optional _stream) nil) ; dummy def - -;; Save emacs routines. -(if (not (fboundp 'cust-print-original-prin1)) - (mapc #'cust-print-set-function-cell - '((cust-print-original-prin1 prin1) - (cust-print-original-princ princ) - (cust-print-original-print print) - (cust-print-original-prin1-to-string prin1-to-string) - (cust-print-original-format format) - (cust-print-original-message message) - (cust-print-original-error error)))) -(declare-function cust-print-original-format "cust-print") -(declare-function cust-print-original-message "cust-print") - -(defun custom-print-install () - "Replace print functions with general, customizable, Lisp versions. -The Emacs subroutines are saved away, and you can reinstall them -by running `custom-print-uninstall'." - (interactive) - (mapc #'cust-print-set-function-cell - '((prin1 custom-prin1) - (princ custom-princ) - (print custom-print) - (prin1-to-string custom-prin1-to-string) - (format custom-format) - (message custom-message) - (error custom-error) - )) - t) - -(defun custom-print-uninstall () - "Reset print functions to their Emacs subroutines." - (interactive) - (mapc #'cust-print-set-function-cell - '((prin1 cust-print-original-prin1) - (princ cust-print-original-princ) - (print cust-print-original-print) - (prin1-to-string cust-print-original-prin1-to-string) - (format cust-print-original-format) - (message cust-print-original-message) - (error cust-print-original-error) - )) - t) - -(defalias 'custom-print-funcs-installed-p #'custom-print-installed-p) -(defun custom-print-installed-p () - "Return t if custom-print is currently installed, nil otherwise." - (eq (symbol-function 'custom-prin1) (symbol-function 'prin1))) - -(defmacro with-custom-print (&rest body) - "Temporarily install the custom print package while executing BODY." - (declare (debug t)) - `(unwind-protect - (progn - (custom-print-install) - ,@body) - (custom-print-uninstall))) -(defalias 'with-custom-print-funcs #'with-custom-print) - - -;; Lisp replacements for prin1 and princ, and for some subrs that use them -;;=============================================================== -;; - so far only the printing and formatting subrs. - -(defun custom-prin1 (object &optional stream) - "Output the printed representation of OBJECT, any Lisp object. -Quoting characters are printed when needed to make output that `read' -can handle, whenever this is possible. -Output stream is STREAM, or value of `standard-output' (which see). - -This is the custom-print replacement for the standard `prin1'. It -uses the appropriate printer depending on the values of `print-level' -and `print-circle' (which see)." - (cust-print-top-level object stream 'cust-print-original-prin1)) - - -(defun custom-princ (object &optional stream) - "Output the printed representation of OBJECT, any Lisp object. -No quoting characters are used; no delimiters are printed around -the contents of strings. -Output stream is STREAM, or value of `standard-output' (which see). - -This is the custom-print replacement for the standard `princ'." - (cust-print-top-level object stream 'cust-print-original-princ)) - - -(defun custom-prin1-to-string (object &optional noescape) - "Return a string containing the printed representation of OBJECT, -any Lisp object. Quoting characters are used when needed to make output -that `read' can handle, whenever this is possible, unless the optional -second argument NOESCAPE is non-nil. - -This is the custom-print replacement for the standard `prin1-to-string'." - (let ((buf (get-buffer-create " *custom-print-temp*"))) - ;; We must erase the buffer before printing in case an error - ;; occurred during the last prin1-to-string and we are in debugger. - (with-current-buffer buf - (erase-buffer)) - ;; We must be in the current-buffer when the print occurs. - (if noescape - (custom-princ object buf) - (custom-prin1 object buf)) - (with-current-buffer buf - (buffer-string) - ;; We could erase the buffer again, but why bother? - ))) - - -(defun custom-print (object &optional stream) - "Output the printed representation of OBJECT, with newlines around it. -Quoting characters are printed when needed to make output that `read' -can handle, whenever this is possible. -Output stream is STREAM, or value of `standard-output' (which see). - -This is the custom-print replacement for the standard `print'." - (cust-print-original-princ "\n" stream) - (custom-prin1 object stream) - (cust-print-original-princ "\n" stream)) - - -(defun custom-format (fmt &rest args) - "Format a string out of a control-string and arguments. -The first argument is a control string. It, and subsequent arguments -substituted into it, become the value, which is a string. -It may contain %s or %d or %c to substitute successive following arguments. -%s means print an argument as a string, %d means print as number in decimal, -%c means print a number as a single character. -The argument used by %s must be a string or a symbol; -the argument used by %d, %b, %o, %x or %c must be a number. - -This is the custom-print replacement for the standard `format'. It -calls the Emacs `format' after first making strings for list, -vector, or symbol args. The format specification for such args should -be `%s' in any case, so a string argument will also work. The string -is generated with `custom-prin1-to-string', which quotes quotable -characters." - (apply #'cust-print-original-format fmt - (mapcar (function (lambda (arg) - (if (or (listp arg) (vectorp arg) (symbolp arg)) - (custom-prin1-to-string arg) - arg))) - args))) - - -(defun custom-message (fmt &rest args) - "Print a one-line message at the bottom of the screen. -The first argument is a control string. -It may contain %s or %d or %c to print successive following arguments. -%s means print an argument as a string, %d means print as number in decimal, -%c means print a number as a single character. -The argument used by %s must be a string or a symbol; -the argument used by %d or %c must be a number. - -This is the custom-print replacement for the standard `message'. -See `custom-format' for the details." - ;; It doesn't work to princ the result of custom-format as in: - ;; (cust-print-original-princ (apply 'custom-format fmt args)) - ;; because the echo area requires special handling - ;; to avoid duplicating the output. - ;; cust-print-original-message does it right. - (apply #'cust-print-original-message fmt - (mapcar (function (lambda (arg) - (if (or (listp arg) (vectorp arg) (symbolp arg)) - (custom-prin1-to-string arg) - arg))) - args))) - - -(defun custom-error (fmt &rest args) - "Signal an error, making error message by passing all args to `format'. - -This is the custom-print replacement for the standard `error'. -See `custom-format' for the details." - (signal 'error (list (apply #'custom-format fmt args)))) - - - -;; Support for custom prin1 and princ -;;========================================= - -;; Defs to quiet byte-compiler. -(defvar circle-table) -(defvar cust-print-current-level) - -(defun cust-print-original-printer (_object) nil) ; One of the standard printers. -(defun cust-print-low-level-prin (_object) nil) ; Used internally. -(defun cust-print-prin (_object) nil) ; Call this to print recursively. - -(defun cust-print-top-level (object stream emacs-printer) - ;; Set up for printing. - (let ((standard-output (or stream standard-output)) - ;; circle-table will be non-nil if anything is circular. - (circle-table (and print-circle - (cust-print-preprocess-circle-tree object))) - (cust-print-current-level (or print-level -1))) - - (defalias 'cust-print-original-printer emacs-printer) - (defalias 'cust-print-low-level-prin - (cond - ((or custom-printers - circle-table - print-level ; comment out for version 19 - ;; Emacs doesn't use print-level or print-length - ;; for vectors, but custom-print can. - (if custom-print-vectors - (or print-level print-length))) - 'cust-print-print-object) - (t 'cust-print-original-printer))) - (defalias 'cust-print-prin - (if circle-table 'cust-print-print-circular 'cust-print-low-level-prin)) - - (cust-print-prin object) - object)) - - -(defun cust-print-print-object (object) - ;; Test object type and print accordingly. - ;; Could be called as either cust-print-low-level-prin or cust-print-prin. - (cond - ((null object) (cust-print-original-printer object)) - ((cust-print-use-custom-printer object) object) - ((consp object) (cust-print-list object)) - ((vectorp object) (cust-print-vector object)) - ;; All other types, just print. - (t (cust-print-original-printer object)))) - - -(defun cust-print-print-circular (object) - ;; Printer for `prin1' and `princ' that handles circular structures. - ;; If OBJECT appears multiply, and has not yet been printed, - ;; prefix with label; if it has been printed, use `#N#' instead. - ;; Otherwise, print normally. - (let ((tag (assq object circle-table))) - (if tag - (let ((id (cdr tag))) - (if (> id 0) - (progn - ;; Already printed, so just print id. - (cust-print-original-princ "#") - (cust-print-original-princ id) - (cust-print-original-princ "#")) - ;; Not printed yet, so label with id and print object. - (setcdr tag (- id)) ; mark it as printed - (cust-print-original-princ "#") - (cust-print-original-princ (- id)) - (cust-print-original-princ "=") - (cust-print-low-level-prin object) - )) - ;; Not repeated in structure. - (cust-print-low-level-prin object)))) - - -;;================================================ -;; List and vector processing for print functions. - -(defun cust-print-list (list) - ;; Print a list using print-length, print-level, and print-circle. - (if (= cust-print-current-level 0) - (cust-print-original-princ "#") - (let ((cust-print-current-level (1- cust-print-current-level))) - (cust-print-original-princ "(") - (let ((length (or print-length 0))) - - ;; Print the first element always (even if length = 0). - (cust-print-prin (car list)) - (setq list (cdr list)) - (if list (cust-print-original-princ " ")) - (setq length (1- length)) - - ;; Print the rest of the elements. - (while (and list (/= 0 length)) - (if (and (listp list) - (not (assq list circle-table))) - (progn - (cust-print-prin (car list)) - (setq list (cdr list))) - - ;; cdr is not a list, or it is in circle-table. - (cust-print-original-princ ". ") - (cust-print-prin list) - (setq list nil)) - - (setq length (1- length)) - (if list (cust-print-original-princ " "))) - - (if (and list (= length 0)) (cust-print-original-princ "...")) - (cust-print-original-princ ")")))) - list) - - -(defun cust-print-vector (vector) - ;; Print a vector according to print-length, print-level, and print-circle. - (if (= cust-print-current-level 0) - (cust-print-original-princ "#") - (let ((cust-print-current-level (1- cust-print-current-level)) - (i 0) - (len (length vector))) - (cust-print-original-princ "[") - - (if print-length - (setq len (min print-length len))) - ;; Print the elements - (while (< i len) - (cust-print-prin (aref vector i)) - (setq i (1+ i)) - (if (< i (length vector)) (cust-print-original-princ " "))) - - (if (< i (length vector)) (cust-print-original-princ "...")) - (cust-print-original-princ "]") - )) - vector) - - - -;; Circular structure preprocessing -;;================================== - -(defun cust-print-preprocess-circle-tree (object) - ;; Fill up the table. - (let (;; Table of tags for each object in an object to be printed. - ;; A tag is of the form: - ;; ( ) - ;; The id-number is generated after the entire table has been computed. - ;; During walk through, the real circle-table lives in the cdr so we - ;; can use setcdr to add new elements instead of having to setq the - ;; variable sometimes (poor man's locf). - (circle-table (list nil))) - (cust-print-walk-circle-tree object) - - ;; Reverse table so it is in the order that the objects will be printed. - ;; This pass could be avoided if we always added to the end of the - ;; table with setcdr in walk-circle-tree. - (setcdr circle-table (nreverse (cdr circle-table))) - - ;; Walk through the table, assigning id-numbers to those - ;; objects which will be printed using #N= syntax. Delete those - ;; objects which will be printed only once (to speed up assq later). - (let ((rest circle-table) - (id -1)) - (while (cdr rest) - (let ((tag (car (cdr rest)))) - (cond ((cdr tag) - (setcdr tag id) - (setq id (1- id)) - (setq rest (cdr rest))) - ;; Else delete this object. - (t (setcdr rest (cdr (cdr rest)))))) - )) - ;; Drop the car. - (cdr circle-table) - )) - - - -(defun cust-print-walk-circle-tree (object) - (let (read-equivalent-p tag) - (while object - (setq read-equivalent-p - (or (numberp object) - (and (symbolp object) - ;; Check if it is uninterned. - (eq object (intern-soft (symbol-name object))))) - tag (and (not read-equivalent-p) - (assq object (cdr circle-table)))) - (cond (tag - ;; Seen this object already, so note that. - (setcdr tag t)) - - ((not read-equivalent-p) - ;; Add a tag for this object. - (setcdr circle-table - (cons (list object) - (cdr circle-table))))) - (setq object - (cond - (tag ;; No need to descend since we have already. - nil) - - ((consp object) - ;; Walk the car of the list recursively. - (cust-print-walk-circle-tree (car object)) - ;; But walk the cdr with the above while loop - ;; to avoid problems with max-lisp-eval-depth. - ;; And it should be faster than recursion. - (cdr object)) - - ((vectorp object) - ;; Walk the vector. - (let ((i (length object)) - (j 0)) - (while (< j i) - (cust-print-walk-circle-tree (aref object j)) - (setq j (1+ j)))))))))) - - -;; Example. -;;======================================= - -'(progn - (progn - ;; Create some circular structures. - (setq circ-sym (let ((x (make-symbol "FOO"))) (list x x))) - (setq circ-list (list 'a 'b (vector 1 2 3 4) 'd 'e 'f)) - (setcar (nthcdr 3 circ-list) circ-list) - (aset (nth 2 circ-list) 2 circ-list) - (setq dotted-circ-list (list 'a 'b 'c)) - (setcdr (cdr (cdr dotted-circ-list)) dotted-circ-list) - (setq circ-vector (vector 1 2 3 4 (list 'a 'b 'c 'd) 6 7)) - (aset circ-vector 5 (make-symbol "-gensym-")) - (setcar (cdr (aref circ-vector 4)) (aref circ-vector 5)) - nil) - - (install-custom-print) - ;; (setq print-circle t) - - (let ((print-circle t)) - (or (equal (prin1-to-string circ-list) "#1=(a b [1 2 #1# 4] #1# e f)") - (error "Circular object with array printing"))) - - (let ((print-circle t)) - (or (equal (prin1-to-string dotted-circ-list) "#1=(a b c . #1#)") - (error "Circular object with array printing"))) - - (let* ((print-circle t) - (x (list 'p 'q)) - (y (list (list 'a 'b) x 'foo x))) - (setcdr (cdr (cdr (cdr y))) (cdr y)) - (or (equal (prin1-to-string y) "((a b) . #1=(#2=(p q) foo #2# . #1#))" - ) - (error "Circular list example from CL manual"))) - - (let ((print-circle nil)) - ;; cl-packages.el is required to print uninterned symbols like #:FOO. - ;; (require 'cl-packages) - (or (equal (prin1-to-string circ-sym) "(#:FOO #:FOO)") - (error "Uninterned symbols in list"))) - (let ((print-circle t)) - (or (equal (prin1-to-string circ-sym) "(#1=FOO #1#)") - (error "Circular uninterned symbols in list"))) - - (uninstall-custom-print) - ) - -(provide 'cust-print) - -;;; cust-print.el ends here diff --git a/lisp/obsolete/erc-hecomplete.el b/lisp/obsolete/erc-hecomplete.el deleted file mode 100644 index 79ccf804409..00000000000 --- a/lisp/obsolete/erc-hecomplete.el +++ /dev/null @@ -1,218 +0,0 @@ -;;; erc-hecomplete.el --- Provides Nick name completion for ERC -*- lexical-binding: t; -*- - -;; Copyright (C) 2001-2002, 2004, 2006-2022 Free Software Foundation, -;; Inc. - -;; Author: Alex Schroeder -;; URL: https://www.emacswiki.org/cgi-bin/wiki.pl?ErcCompletion -;; Obsolete-since: 24.1 - -;; 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 . - -;;; Commentary: - -;; This file is considered obsolete. It is recommended to use -;; completion from erc-pcomplete instead. - -;; This file is based on hippie-expand, while the new file is based on -;; pcomplete. - -;;; Code: - -(require 'erc) -(require 'erc-match); for erc-pals -(require 'hippie-exp); for the hippie expand stuff - -;;;###autoload (autoload 'erc-hecomplete-mode "erc-hecomplete" nil t) -(define-erc-module hecomplete nil - "Complete nick at point." - ((add-hook 'erc-complete-functions #'erc-hecomplete)) - ((remove-hook 'erc-complete-functions #'erc-hecomplete))) - -(defun erc-hecomplete () - "Complete nick at point. -See `erc-try-complete-nick' for more technical info. -This function is obsolete, use `erc-pcomplete' instead." - (interactive) - (let ((hippie-expand-try-functions-list '(erc-try-complete-nick))) - (hippie-expand nil))) - -(defgroup erc-hecomplete nil - "Nick completion. It is recommended to use `erc-pcomplete' instead." - :group 'erc) - -(defcustom erc-nick-completion 'all - "Determine how the list of nicks is determined during nick completion. -See `erc-complete-nick' for information on how to activate this. - -pals: Use `erc-pals'. -all: All channel members. - -You may also provide your own function that returns a list of completions. -One example is `erc-nick-completion-exclude-myself', -or you may use an arbitrary lisp expression." - :type '(choice (const :tag "List of pals" pals) - (const :tag "All channel members" all) - (const :tag "All channel members except yourself" - erc-nick-completion-exclude-myself) - (repeat :tag "List" (string :tag "Nick")) - function - sexp)) - -(defcustom erc-nick-completion-ignore-case t - "Non-nil means don't consider case significant in nick completion. -Case will be automatically corrected when non-nil. -For instance if you type \"dely TAB\" the word completes and changes to -\"delYsid\"." - :type 'boolean) - -(defun erc-nick-completion-exclude-myself () - "Get a list of all the channel members except you. - -This function returns a list of all the members in the channel, except -your own nick. This way if you're named foo and someone is called foobar, -typing \"f o TAB\" will directly give you foobar. Use this with -`erc-nick-completion'." - (remove - (erc-current-nick) - (erc-get-channel-nickname-list))) - -(defcustom erc-nick-completion-postfix ": " - "When `erc-complete' is used in the first word after the prompt, -add this string when a unique expansion was found." - :type 'string) - -(defun erc-command-list () - "Return a list of strings of the defined user commands." - (let ((case-fold-search nil)) - (mapcar (lambda (x) - (concat "/" (downcase (substring (symbol-name x) 8)))) - (apropos-internal "erc-cmd-[A-Z]+")))) - -(defun erc-try-complete-nick (old) - "Complete nick at point. -This is a function to put on `hippie-expand-try-functions-list'. -Then use \\[hippie-expand] to expand nicks. -The type of completion depends on `erc-nick-completion'." - (try-complete-erc-nick old (cond ((eq erc-nick-completion 'pals) erc-pals) - ((eq erc-nick-completion 'all) - (append - (erc-get-channel-nickname-list) - (erc-command-list))) - ((functionp erc-nick-completion) - (funcall erc-nick-completion)) - (t erc-nick-completion)))) - -(defvar try-complete-erc-nick-window-configuration nil - "The window configuration for `try-complete-erc-nick'. -When called the first time, a window config is stored here, -and when completion is done, the window config is restored -from here. See `try-complete-erc-nick-restore' and -`try-complete-erc-nick'.") - -(defun try-complete-erc-nick-restore () - "Restore window configuration." - (if (not try-complete-erc-nick-window-configuration) - (when (get-buffer "*Completions*") - (delete-windows-on "*Completions*")) - (set-window-configuration - try-complete-erc-nick-window-configuration) - (setq try-complete-erc-nick-window-configuration nil))) - -(defun try-complete-erc-nick (old completions) - "Try to complete current word depending on `erc-try-complete-nick'. -The argument OLD has to be nil the first call of this function, and t -for subsequent calls (for further possible completions of the same -string). It returns t if a new completion is found, nil otherwise. The -second argument COMPLETIONS is a list of completions to use. Actually, -it is only used when OLD is nil. It will be copied to `he-expand-list' -on the first call. After that, it is no longer used. -Window configurations are stored in -`try-complete-erc-nick-window-configuration'." - (let (expansion - final - (alist (if (consp (car completions)) - completions - (mapcar (lambda (s) - (if (and (erc-complete-at-prompt) - (and (not (= (length s) 0)) - (not (eq (elt s 0) ?/)))) - (list (concat s erc-nick-completion-postfix)) - (list (concat s " ")))) - completions))) ; make alist if required - (completion-ignore-case erc-nick-completion-ignore-case)) - (he-init-string (he-dabbrev-beg) (point)) - ;; If there is a string to complete, complete it using alist. - ;; expansion is the possible expansion, or t. If expansion is t - ;; or if expansion is the "real" thing, we are finished (final is - ;; t). Take care -- expansion can also be nil! - (unless (string= he-search-string "") - (setq expansion (try-completion he-search-string alist) - final (or (eq t expansion) - (and expansion - (eq t (try-completion expansion alist)))))) - (cond ((not expansion) - ;; There is no expansion at all. - (try-complete-erc-nick-restore) - (he-reset-string) - nil) - ((eq t expansion) - ;; The user already has the correct expansion. - (try-complete-erc-nick-restore) - (he-reset-string) - t) - ((and old (string= expansion he-search-string)) - ;; This is the second time around and nothing changed, - ;; ie. the user tried to expand something incomplete - ;; without making a choice -- hitting TAB twice, for - ;; example. - (try-complete-erc-nick-restore) - (he-reset-string) - nil) - (final - ;; The user has found the correct expansion. - (try-complete-erc-nick-restore) - (he-substitute-string expansion) - t) - (t - ;; We found something but we are not finished. Show a - ;; completions buffer. Substitute what we found and return - ;; t. - (setq try-complete-erc-nick-window-configuration - (current-window-configuration)) - (with-output-to-temp-buffer "*Completions*" - (display-completion-list (all-completions he-search-string alist))) - (he-substitute-string expansion) - t)))) - -(defun erc-at-beginning-of-line-p (point &optional bol-func) - (save-excursion - (funcall (or bol-func - 'erc-bol)) - (equal point (point)))) - -(defun erc-complete-at-prompt () - "Return t if point is directly after `erc-prompt' when doing completion." - (erc-at-beginning-of-line-p (he-dabbrev-beg))) - -(provide 'erc-hecomplete) - -;;; erc-hecomplete.el ends here -;; -;; Local Variables: -;; indent-tabs-mode: t -;; tab-width: 8 -;; End: diff --git a/lisp/obsolete/mailpost.el b/lisp/obsolete/mailpost.el deleted file mode 100644 index 5b3a76e2f79..00000000000 --- a/lisp/obsolete/mailpost.el +++ /dev/null @@ -1,101 +0,0 @@ -;;; mailpost.el --- RMAIL coupler to /usr/uci/post mailer -*- lexical-binding: t; -*- - -;; This is in the public domain -;; since Delp distributed it in 1986 without a copyright notice. - -;; This file is part of GNU Emacs. - -;; Author: Gary Delp -;; Maintainer: emacs-devel@gnu.org -;; Created: 13 Jan 1986 -;; Keywords: mail -;; Obsolete-since: 24.3 - -;;; Commentary: - -;; Yet another mail interface. this for the rmail system to provide -;; the missing sendmail interface on systems without /usr/lib/sendmail, -;; but with /usr/uci/post. - -;;; Code: - -(require 'mailalias) -(require 'sendmail) - -;; (setq send-mail-function 'post-mail-send-it) - -(defun post-mail-send-it () - "The MH -post interface for `rmail-mail' to call. -To use it, include \"(setq send-mail-function \\='post-mail-send-it)\" in -site-init." - (let ((errbuf (if mail-interactive - (generate-new-buffer " post-mail errors") - 0)) - temfile - (tembuf (generate-new-buffer " post-mail temp")) - (case-fold-search nil) - delimline - (mailbuf (current-buffer))) - (unwind-protect - (with-current-buffer tembuf - (erase-buffer) - (insert-buffer-substring mailbuf) - (goto-char (point-max)) - ;; require one newline at the end. - (or (= (preceding-char) ?\n) - (insert ?\n)) - ;; Change header-delimiter to be what post-mail expects. - (mail-sendmail-undelimit-header) - (setq delimline (point-marker)) - (if mail-aliases - (expand-mail-aliases (point-min) delimline)) - (goto-char (point-min)) - ;; ignore any blank lines in the header - (while (and (re-search-forward "\n\n\n*" delimline t) - (< (point) delimline)) - (replace-match "\n")) - ;; Find and handle any Fcc fields. - (let ((case-fold-search t)) - (goto-char (point-min)) - (if (re-search-forward "^Fcc:" delimline t) - (mail-do-fcc delimline)) - ;; If there is a From and no Sender, put it a Sender. - (goto-char (point-min)) - (and (re-search-forward "^From:" delimline t) - (not (save-excursion - (goto-char (point-min)) - (re-search-forward "^Sender:" delimline t))) - (progn - (forward-line 1) - (insert "Sender: " (user-login-name) "\n"))) - ;; don't send out a blank subject line - (goto-char (point-min)) - (if (re-search-forward "^Subject:[ \t]*\n" delimline t) - (replace-match "")) - (if mail-interactive - (with-current-buffer errbuf - (erase-buffer)))) - (with-file-modes 384 (setq temfile (make-temp-file ",rpost"))) - (apply #'call-process - (append (list (if (boundp 'post-mail-program) - post-mail-program - "/usr/uci/lib/mh/post") - nil errbuf nil - "-nofilter" "-msgid") - (if mail-interactive '("-watch") '("-nowatch")) - (list temfile))) - (if mail-interactive - (with-current-buffer errbuf - (goto-char (point-min)) - (while (re-search-forward "\n\n* *" nil t) - (replace-match "; ")) - (if (not (zerop (buffer-size))) - (error "Sending...failed to %s" - (buffer-substring (point-min) (point-max))))))) - (kill-buffer tembuf) - (if (bufferp errbuf) - (switch-to-buffer errbuf))))) - -(provide 'mailpost) - -;;; mailpost.el ends here diff --git a/lisp/obsolete/mouse-sel.el b/lisp/obsolete/mouse-sel.el deleted file mode 100644 index 3eacac65fba..00000000000 --- a/lisp/obsolete/mouse-sel.el +++ /dev/null @@ -1,731 +0,0 @@ -;;; mouse-sel.el --- multi-click selection support -*- lexical-binding: t; -*- - -;; Copyright (C) 1993-1995, 2001-2022 Free Software Foundation, Inc. - -;; Author: Mike Williams -;; Keywords: mouse -;; Obsolete-since: 24.3 - -;; 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 . - -;;; Commentary: - -;; This module provides multi-click mouse support for GNU Emacs versions -;; 19.18 and later. I've tried to make it behave more like standard X -;; clients (eg. xterm) than the default Emacs 19 mouse selection handlers. -;; Basically: -;; -;; * Clicking mouse-1 starts (cancels) selection, dragging extends it. -;; -;; * Clicking or dragging mouse-3 extends the selection as well. -;; -;; * Double-clicking on word constituents selects words. -;; Double-clicking on symbol constituents selects symbols. -;; Double-clicking on quotes or parentheses selects sexps. -;; Double-clicking on whitespace selects whitespace. -;; Triple-clicking selects lines. -;; Quad-clicking selects paragraphs. -;; -;; * Selecting sets the region & X primary selection, but does NOT affect -;; the kill-ring. Because the mouse handlers set the primary selection -;; directly, mouse-sel sets the variables interprogram-cut-function -;; and interprogram-paste-function to nil. -;; -;; * Clicking mouse-2 inserts the contents of the primary selection at -;; the mouse position (or point, if mouse-yank-at-point is non-nil). -;; -;; * Pressing mouse-2 while selecting or extending copies selection -;; to the kill ring. Pressing mouse-1 or mouse-3 kills it. -;; -;; * Double-clicking mouse-3 also kills selection. -;; -;; * M-mouse-1, M-mouse-2 & M-mouse-3 work similarly to mouse-1, mouse-2 -;; & mouse-3, but operate on the X secondary selection rather than the -;; primary selection and region. -;; -;; This module requires my thingatpt.el module, which it uses to find the -;; bounds of words, lines, sexps, etc. -;; -;; Thanks to KevinB@bartley.demon.co.uk for his useful input. -;; -;;--- Customization ------------------------------------------------------- -;; -;; * You may want to use none or more of following: -;; -;; ;; Enable region highlight -;; (transient-mark-mode 1) -;; -;; ;; But only in the selected window -;; (setq highlight-nonselected-windows nil) -;; -;; ;; Enable pending-delete -;; (delete-selection-mode 1) -;; -;; * You can control the way mouse-sel binds its keys by setting the value -;; of mouse-sel-default-bindings before loading mouse-sel. -;; -;; (a) If mouse-sel-default-bindings = t (the default) -;; -;; Mouse sets and insert selection -;; mouse-1 mouse-select -;; mouse-2 mouse-insert-selection -;; mouse-3 mouse-extend -;; -;; Selection/kill-ring interaction is disabled -;; interprogram-cut-function = nil -;; interprogram-paste-function = nil -;; -;; (b) If mouse-sel-default-bindings = 'interprogram-cut-paste -;; -;; Mouse sets selection, and pastes from kill-ring -;; mouse-1 mouse-select -;; mouse-2 mouse-insert-selection -;; mouse-3 mouse-extend -;; In this mode, mouse-insert-selection just calls mouse-yank-at-click. -;; -;; Selection/kill-ring interaction is retained -;; interprogram-cut-function = gui-select-text -;; interprogram-paste-function = gui-selection-value -;; -;; What you lose is the ability to select some text in -;; delete-selection-mode and yank over the top of it. -;; -;; (c) If mouse-sel-default-bindings = nil, no bindings are made. -;; -;; * By default, mouse-insert-selection (mouse-2) inserts the selection at -;; the mouse position. You can tell it to insert at point instead with: -;; -;; (setq mouse-yank-at-point t) -;; -;; * I like to leave point at the end of the region nearest to where the -;; mouse was, even though this makes region highlighting mis-leading (the -;; cursor makes it look like one extra character is selected). You can -;; disable this behavior with: -;; -;; (setq mouse-sel-leave-point-near-mouse nil) -;; -;; * By default, mouse-select cycles the click count after 4 clicks. That -;; is, clicking mouse-1 five times has the same effect as clicking it -;; once, clicking six times has the same effect as clicking twice, etc. -;; Disable this behavior with: -;; -;; (setq mouse-sel-cycle-clicks nil) -;; -;; * The variables mouse-sel-{set,get}-selection-function control how the -;; selection is handled. Under X Windows, these variables default so -;; that the X primary selection is used. Under other windowing systems, -;; alternate functions are used, which simply store the selection value -;; in a variable. - -;;; Code: - -(require 'mouse) -(require 'thingatpt) - -;;=== User Variables ====================================================== - -(defgroup mouse-sel nil - "Mouse selection enhancement." - :group 'mouse) - -(defcustom mouse-sel-leave-point-near-mouse t - "Leave point near last mouse position. -If non-nil, \\[mouse-select] and \\[mouse-extend] will leave point at the end -of the region nearest to where the mouse last was. -If nil, point will always be placed at the beginning of the region." - :type 'boolean) - -(defcustom mouse-sel-cycle-clicks t - "If non-nil, \\[mouse-select] cycles the click-counts after 4 clicks." - :type 'boolean) - -(defcustom mouse-sel-default-bindings t - "Control mouse bindings." - :type '(choice (const :tag "none" nil) - (const :tag "cut and paste" interprogram-cut-paste) - (other :tag "default bindings" t))) - -;;=== Key bindings ======================================================== - -(defconst mouse-sel-bound-events - '(;; Primary selection bindings. - ;; - ;; Bind keys to `ignore' instead of unsetting them because modes may - ;; bind `down-mouse-1', for instance, without binding `mouse-1'. - ;; If we unset `mouse-1', this leads to a bitch_at_user when the - ;; mouse goes up because no matching binding is found for that. - ([mouse-1] . ignore) - ([drag-mouse-1] . ignore) - ([mouse-3] . ignore) - ([down-mouse-1] . mouse-select) - ([down-mouse-3] . mouse-extend) - ([mouse-2] . mouse-insert-selection) - ;; Secondary selection bindings. - ([M-mouse-1] . ignore) - ([M-drag-mouse-1] . ignore) - ([M-mouse-3] . ignore) - ([M-down-mouse-1] . mouse-select-secondary) - ([M-mouse-2] . mouse-insert-secondary) - ([M-down-mouse-3] . mouse-extend-secondary)) - "An alist of events that `mouse-sel-mode' binds.") - -;;=== User Command ======================================================== - -(defvar mouse-sel-original-bindings nil) - -(defalias 'mouse-sel--ignore #'ignore) - -;;;###autoload -(define-minor-mode mouse-sel-mode - "Toggle Mouse Sel mode. - -Mouse Sel mode is a global minor mode. When enabled, mouse -selection is enhanced in various ways: - -- Double-clicking on symbol constituents selects symbols. -Double-clicking on quotes or parentheses selects sexps. -Double-clicking on whitespace selects whitespace. -Triple-clicking selects lines. -Quad-clicking selects paragraphs. - -- Selecting sets the region & X primary selection, but does NOT affect -the `kill-ring', nor do the kill-ring functions change the X selection. -Because the mouse handlers set the primary selection directly, -mouse-sel sets the variables `interprogram-cut-function' and -`interprogram-paste-function' to nil. - -- Clicking mouse-2 inserts the contents of the primary selection at -the mouse position (or point, if `mouse-yank-at-point' is non-nil). - -- mouse-2 while selecting or extending copies selection to the -kill ring; mouse-1 or mouse-3 kills it." - :global t - (if mouse-sel-mode - (progn - ;; If mouse-2 has never been done by the user, initialize the - ;; `event-kind' property to ensure that `follow-link' clicks - ;; are interpreted correctly. - (put 'mouse-2 'event-kind 'mouse-click) - (add-hook 'x-lost-selection-functions #'mouse-sel-lost-selection-hook) - (when mouse-sel-default-bindings - ;; Save original bindings and replace them with new ones. - (setq mouse-sel-original-bindings - (mapcar (lambda (binding) - (let ((event (car binding))) - (prog1 (cons event (lookup-key global-map event)) - (global-set-key event (cdr binding))))) - mouse-sel-bound-events)) - ;; Update interprogram functions. - (unless (eq mouse-sel-default-bindings 'interprogram-cut-paste) - (add-function :override interprogram-cut-function - #'mouse-sel--ignore) - (add-function :override interprogram-paste-function - #'mouse-sel--ignore)))) - - ;; Restore original bindings - (remove-hook 'x-lost-selection-functions #'mouse-sel-lost-selection-hook) - (dolist (binding mouse-sel-original-bindings) - (global-set-key (car binding) (cdr binding))) - ;; Restore the old values of these variables, - ;; only if they were actually saved previously. - (remove-function interprogram-cut-function #'mouse-sel--ignore) - (remove-function interprogram-paste-function #'mouse-sel--ignore))) - -(make-obsolete 'mouse-sel-mode "use the normal mouse modes" "24.3") - -;;=== Internal Variables/Constants ======================================== - -(defvar mouse-sel-primary-thing nil - "Type of PRIMARY selection in current buffer.") -(make-variable-buffer-local 'mouse-sel-primary-thing) - -(defvar mouse-sel-secondary-thing nil - "Type of SECONDARY selection in current buffer.") -(make-variable-buffer-local 'mouse-sel-secondary-thing) - -;; Ensure that secondary overlay is defined -(unless (overlayp mouse-secondary-overlay) - (setq mouse-secondary-overlay (make-overlay 1 1)) - (overlay-put mouse-secondary-overlay 'face 'secondary-selection)) - -(defconst mouse-sel-primary-overlay - (let ((ol (make-overlay (point-min) (point-min)))) - (delete-overlay ol) - (overlay-put ol 'face 'region) - ol) - "An overlay which records the current primary selection. -This is used by Mouse Sel mode only.") - -(defconst mouse-sel-selection-alist - '((PRIMARY mouse-sel-primary-overlay mouse-sel-primary-thing) - (SECONDARY mouse-secondary-overlay mouse-sel-secondary-thing)) - "Alist associating selections with variables. -Each element is of the form: - - (SELECTION-NAME OVERLAY-SYMBOL SELECTION-THING-SYMBOL) - -where SELECTION-NAME = name of selection - OVERLAY-SYMBOL = name of variable containing overlay to use - SELECTION-THING-SYMBOL = name of variable where the current selection - type for this selection should be stored.") - -(defvar mouse-sel-set-selection-function - (if (eq mouse-sel-default-bindings 'interprogram-cut-paste) - 'gui-set-selection - (lambda (selection value) - (if (eq selection 'PRIMARY) - (gui-select-text value) - (gui-set-selection selection value)))) - "Function to call to set selection. -Called with two arguments: - - SELECTION, the name of the selection concerned, and - VALUE, the text to store. - -This sets the selection, unless `mouse-sel-default-bindings' -is `interprogram-cut-paste'.") - - -(defvar mouse-sel-get-selection-function - (lambda (selection) - (if (eq selection 'PRIMARY) - (or (gui-selection-value) - (bound-and-true-p x-last-selected-text-primary) - gui--last-selected-text-primary) - (gui-get-selection selection))) - "Function to call to get the selection. -Called with one argument: - - SELECTION: the name of the selection concerned.") - -;;=== Support/access functions ============================================ - -(defun mouse-sel-determine-selection-thing (nclicks) - "Determine what `thing' `mouse-sel' should operate on. -The first argument is NCLICKS, is the number of consecutive -mouse clicks at the same position. - -Double-clicking on word constituents selects words. -Double-clicking on symbol constituents selects symbols. -Double-clicking on quotes or parentheses selects sexps. -Double-clicking on whitespace selects whitespace. -Triple-clicking selects lines. -Quad-clicking selects paragraphs. - -Feel free to re-define this function to support your own desired -multi-click semantics." - (let* ((next-char (char-after (point))) - (char-syntax (if next-char (char-syntax next-char)))) - (if mouse-sel-cycle-clicks - (setq nclicks (1+ (% (1- nclicks) 4)))) - (cond - ((= nclicks 1) nil) - ((= nclicks 3) 'line) - ((>= nclicks 4) 'paragraph) - ((memq char-syntax '(?\( ?\) ?\" ?')) 'sexp) - ((memq next-char '(?\s ?\t ?\n)) 'whitespace) - ((eq char-syntax ?_) 'symbol) - ((eq char-syntax ?w) 'word)))) - -(defun mouse-sel-set-selection (selection value) - "Set the specified SELECTION to VALUE." - (if mouse-sel-set-selection-function - (funcall mouse-sel-set-selection-function selection value) - (put 'mouse-sel-internal-selection selection value))) - -(defun mouse-sel-get-selection (selection) - "Get the value of the specified SELECTION." - (if mouse-sel-get-selection-function - (funcall mouse-sel-get-selection-function selection) - (get 'mouse-sel-internal-selection selection))) - -(defun mouse-sel-selection-overlay (selection) - "Return overlay corresponding to SELECTION." - (let ((symbol (nth 1 (assoc selection mouse-sel-selection-alist)))) - (or symbol (error "No overlay corresponding to %s selection" selection)) - (symbol-value symbol))) - -(defun mouse-sel-selection-thing (selection) - "Return overlay corresponding to SELECTION." - (let ((symbol (nth 2 (assoc selection mouse-sel-selection-alist)))) - (or symbol (error "No symbol corresponding to %s selection" selection)) - symbol)) - -(defun mouse-sel-region-to-primary (orig-window) - "Convert region to PRIMARY overlay and deactivate region. -Argument ORIG-WINDOW specifies the window the cursor was in when the -originating command was issued, and is used to determine whether the -region was visible or not." - (if transient-mark-mode - (let ((overlay (mouse-sel-selection-overlay 'PRIMARY))) - (cond - ((and mark-active - (or highlight-nonselected-windows - (eq orig-window (selected-window)))) - ;; Region was visible, so convert region to overlay - (move-overlay overlay (region-beginning) (region-end) - (current-buffer))) - ((eq orig-window (selected-window)) - ;; Point was visible, so set overlay at point - (move-overlay overlay (point) (point) (current-buffer))) - (t - ;; Nothing was visible, so remove overlay - (delete-overlay overlay))) - (setq mark-active nil)))) - -(defun mouse-sel-primary-to-region (&optional direction) - "Convert PRIMARY overlay to region. -Optional argument DIRECTION specifies the mouse drag direction: a value of -1 indicates that the mouse was dragged left-to-right, otherwise it was -dragged right-to-left." - (let* ((overlay (mouse-sel-selection-overlay 'PRIMARY)) - (start (overlay-start overlay)) - (end (overlay-end overlay))) - (if (eq start end) - (progn - (if start (goto-char start)) - (deactivate-mark)) - (if (and mouse-sel-leave-point-near-mouse (eq direction 1)) - (progn - (goto-char end) - (push-mark start 'nomsg 'active)) - (goto-char start) - (push-mark end 'nomsg 'active))) - (if transient-mark-mode (delete-overlay overlay)))) - -(defmacro mouse-sel-eval-at-event-end (event &rest forms) - "Evaluate forms at mouse position. -Move to the end position of EVENT, execute FORMS, and restore original -point and window." - `(let ((posn (event-end ,event))) - (if posn (mouse-minibuffer-check ,event)) - (if (and posn (not (windowp (posn-window posn)))) - (error "Cursor not in text area of window")) - (let (orig-window orig-point-marker) - (setq orig-window (selected-window)) - (if posn (select-window (posn-window posn))) - (setq orig-point-marker (point-marker)) - (if (and posn (numberp (posn-point posn))) - (goto-char (posn-point posn))) - (unwind-protect - (progn - ,@forms) - (goto-char (marker-position orig-point-marker)) - (move-marker orig-point-marker nil) - (select-window orig-window))))) - -(put 'mouse-sel-eval-at-event-end 'lisp-indent-hook 1) - -;;=== Select ============================================================== - -(defun mouse-select (event) - "Set region/selection using the mouse. - -Click sets point & mark to click position. -Dragging extends region/selection. - -Multi-clicking selects word/lines/paragraphs, as determined by -`mouse-sel-determine-selection-thing'. - -Clicking mouse-2 while selecting copies selected text to the kill-ring. -Clicking mouse-1 or mouse-3 kills the selected text. - -This should be bound to a down-mouse event." - (interactive "@e") - (let (select) - (unwind-protect - (setq select (mouse-select-internal 'PRIMARY event)) - (if (and select (listp select)) - (push (cons 'mouse-2 (cdr event)) unread-command-events) - (mouse-sel-primary-to-region select))))) - -(defun mouse-select-secondary (event) - "Set secondary selection using the mouse. - -Click sets the start of the secondary selection to click position. -Dragging extends the secondary selection. - -Multi-clicking selects word/lines/paragraphs, as determined by -`mouse-sel-determine-selection-thing'. - -Clicking mouse-2 while selecting copies selected text to the kill-ring. -Clicking mouse-1 or mouse-3 kills the selected text. - -This should be bound to a down-mouse event." - (interactive "e") - (mouse-select-internal 'SECONDARY event)) - -(defun mouse-select-internal (selection event) - "Set SELECTION using the mouse, with EVENT as the initial down-event. -Normally, this returns the direction in which the selection was -made: a value of 1 indicates that the mouse was dragged -left-to-right, otherwise it was dragged right-to-left. - -However, if `mouse-1-click-follows-link' is non-nil and the -subsequent mouse events specify following a link, this returns -the final mouse-event. In that case, the selection is not set." - (mouse-sel-eval-at-event-end event - (let ((thing-symbol (mouse-sel-selection-thing selection)) - (overlay (mouse-sel-selection-overlay selection))) - (set thing-symbol - (mouse-sel-determine-selection-thing (event-click-count event))) - (let ((object-bounds (bounds-of-thing-at-point - (symbol-value thing-symbol)))) - (if object-bounds - (progn - (move-overlay overlay - (car object-bounds) (cdr object-bounds) - (current-buffer))) - (move-overlay overlay (point) (point) (current-buffer))))) - (catch 'follow-link - (mouse-extend-internal selection event t)))) - -;;=== Extend ============================================================== - -(defun mouse-extend (event) - "Extend region/selection using the mouse." - (interactive "e") - (let ((orig-window (selected-window)) - direction) - (select-window (posn-window (event-end event))) - (unwind-protect - (progn - (mouse-sel-region-to-primary orig-window) - (setq direction (mouse-extend-internal 'PRIMARY event))) - (mouse-sel-primary-to-region direction)))) - -(defun mouse-extend-secondary (event) - "Extend secondary selection using the mouse." - (interactive "e") - (save-window-excursion - (mouse-extend-internal 'SECONDARY event))) - -(defun mouse-extend-internal (selection &optional initial-event no-process) - "Extend specified SELECTION using the mouse. -Track mouse-motion events, adjusting the SELECTION appropriately. -Optional argument INITIAL-EVENT specifies an initial down-mouse event. -Optional argument NO-PROCESS means not to process the initial -event. - -See documentation for mouse-select-internal for more details." - (mouse-sel-eval-at-event-end initial-event - (let ((orig-cursor-type - (cdr (assoc 'cursor-type (frame-parameters (selected-frame)))))) - (unwind-protect - - (let* ((thing-symbol (mouse-sel-selection-thing selection)) - (overlay (mouse-sel-selection-overlay selection)) - (orig-window (selected-window)) - (top (nth 1 (window-edges orig-window))) - (bottom (nth 3 (window-edges orig-window))) - (mark-active nil) ; inhibit normal region highlight - (echo-keystrokes 0) ; don't echo mouse events - min max - direction - event) - - ;; Get current bounds of overlay - (if (eq (overlay-buffer overlay) (current-buffer)) - (setq min (overlay-start overlay) - max (overlay-end overlay)) - (setq min (point) - max min) - (set thing-symbol nil)) - - - ;; Bar cursor - (if (fboundp 'modify-frame-parameters) - (modify-frame-parameters (selected-frame) - '((cursor-type . bar)))) - - ;; Handle dragging - (track-mouse - - (while (if (and initial-event (not no-process)) - ;; Use initial event - (prog1 - (setq event initial-event) - (setq initial-event nil)) - (setq event (read-event)) - (and (consp event) - (memq (car event) '(mouse-movement switch-frame)))) - - (let ((selection-thing (symbol-value thing-symbol)) - (end (event-end event))) - - (cond - - ;; Ignore any movement outside the frame - ((eq (car-safe event) 'switch-frame) nil) - ((and (posn-window end) - (not (eq (let ((posn-w (posn-window end))) - (if (windowp posn-w) - (window-frame posn-w) - posn-w)) - (window-frame orig-window)))) nil) - - ;; Different window, same frame - ((not (eq (posn-window end) orig-window)) - (let ((end-row (cdr (cdr (mouse-position))))) - (cond - ((and end-row (not (bobp)) (< end-row top)) - (mouse-scroll-subr orig-window (- end-row top) - overlay max)) - ((and end-row (not (eobp)) (>= end-row bottom)) - (mouse-scroll-subr orig-window (1+ (- end-row bottom)) - overlay min)) - ))) - - ;; On the mode line - ((eq (posn-point end) 'mode-line) - (mouse-scroll-subr orig-window 1 overlay min)) - - ;; In original window - (t (goto-char (posn-point end))) - - ) - - ;; Determine direction of drag - (cond - ((and (not direction) (not (eq min max))) - (setq direction (if (< (point) (/ (+ min max) 2)) -1 1))) - ((and (not (eq direction -1)) (<= (point) min)) - (setq direction -1)) - ((and (not (eq direction 1)) (>= (point) max)) - (setq direction 1))) - - (if (not selection-thing) nil - - ;; If dragging forward, goal is next character - (if (and (eq direction 1) (not (eobp))) (forward-char 1)) - - ;; Move to start/end of selected thing - (let ((goal (point))) - (goto-char (if (eq 1 direction) min max)) - (condition-case nil - (progn - (while (> (* direction (- goal (point))) 0) - (forward-thing selection-thing direction)) - (let ((end (point))) - (forward-thing selection-thing (- direction)) - (goto-char - (if (> (* direction (- goal (point))) 0) - end (point))))) - (error)))) - - ;; Move overlay - (move-overlay overlay - (if (eq 1 direction) min (point)) - (if (eq -1 direction) max (point)) - (current-buffer)) - - ))) ; end track-mouse - - ;; Detect follow-link events - (when (mouse-sel-follow-link-p initial-event event) - (throw 'follow-link event)) - - ;; Finish up after dragging - (let ((overlay-start (overlay-start overlay)) - (overlay-end (overlay-end overlay))) - - ;; Set selection - (if (not (eq overlay-start overlay-end)) - (mouse-sel-set-selection - selection - (buffer-substring overlay-start overlay-end))) - - ;; Handle copy/kill - (let (this-command) - (cond - ((eq (event-basic-type last-input-event) 'mouse-2) - (copy-region-as-kill overlay-start overlay-end) - (read-event) (read-event)) - ((and (memq (event-basic-type last-input-event) - '(mouse-1 mouse-3)) - (memq 'down (event-modifiers last-input-event))) - (kill-region overlay-start overlay-end) - (move-overlay overlay overlay-start overlay-start) - (read-event) (read-event)) - ((and (eq (event-basic-type last-input-event) 'mouse-3) - (memq 'double (event-modifiers last-input-event))) - (kill-region overlay-start overlay-end) - (move-overlay overlay overlay-start overlay-start))))) - - direction) - - ;; Restore cursor - (if (fboundp 'modify-frame-parameters) - (modify-frame-parameters - (selected-frame) (list (cons 'cursor-type orig-cursor-type)))) - - )))) - -(defun mouse-sel-follow-link-p (initial final) - "Return t if we should follow a link, given INITIAL and FINAL mouse events. -See `mouse-1-click-follows-link' for details. Currently, Mouse -Sel mode does not support using a `double' value to follow links -using double-clicks." - (and initial final mouse-1-click-follows-link - (eq (car initial) 'down-mouse-1) - (mouse-on-link-p (event-start initial)) - (= (posn-point (event-start initial)) - (posn-point (event-end final))) - (= (event-click-count initial) 1) - (or (not (integerp mouse-1-click-follows-link)) - (let ((t0 (posn-timestamp (event-start initial))) - (t1 (posn-timestamp (event-end final)))) - (and (integerp t0) (integerp t1) - (if (> mouse-1-click-follows-link 0) - (<= (- t1 t0) mouse-1-click-follows-link) - (< (- t0 t1) mouse-1-click-follows-link))))))) - -;;=== Paste =============================================================== - -(defun mouse-insert-selection (event arg) - "Insert the contents of the PRIMARY selection at mouse click. -If `mouse-yank-at-point' is non-nil, insert at point instead." - (interactive "e\nP") - (if (eq mouse-sel-default-bindings 'interprogram-cut-paste) - (mouse-yank-at-click event arg) - (mouse-insert-selection-internal 'PRIMARY event))) - -(defun mouse-insert-secondary (event) - "Insert the contents of the SECONDARY selection at mouse click. -If `mouse-yank-at-point' is non-nil, insert at point instead." - (interactive "e") - (mouse-insert-selection-internal 'SECONDARY event)) - -(defun mouse-insert-selection-internal (selection event) - "Insert the contents of the named SELECTION at mouse click. -If `mouse-yank-at-point' is non-nil, insert at point instead." - (unless mouse-yank-at-point - (mouse-set-point event)) - (when mouse-sel-get-selection-function - (push-mark (point) 'nomsg) - (insert-for-yank - (or (funcall mouse-sel-get-selection-function selection) "")))) - -;;=== Handle loss of selections =========================================== - -(defun mouse-sel-lost-selection-hook (selection) - "Remove the overlay for a lost selection." - (let ((overlay (mouse-sel-selection-overlay selection))) - (delete-overlay overlay))) - -(provide 'mouse-sel) - -;;; mouse-sel.el ends here diff --git a/lisp/obsolete/old-emacs-lock.el b/lisp/obsolete/old-emacs-lock.el deleted file mode 100644 index 70123e75375..00000000000 --- a/lisp/obsolete/old-emacs-lock.el +++ /dev/null @@ -1,102 +0,0 @@ -;;; old-emacs-lock.el --- prevents you from exiting Emacs if a buffer is locked -*- lexical-binding: t; -*- - -;; Copyright (C) 1994, 1997, 2001-2022 Free Software Foundation, Inc. - -;; Author: Tom Wurgler -;; Created: 12/8/94 -;; Keywords: extensions, processes -;; Obsolete-since: 24.1 - -;; 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 . - -;;; Commentary: - -;; This code sets a buffer-local variable to t if toggle-emacs-lock is run, -;; then if the user attempts to exit Emacs, the locked buffer name will be -;; displayed and the exit aborted. This is just a way of protecting -;; yourself from yourself. For example, if you have a shell running a big -;; program and exiting Emacs would abort that program, you may want to lock -;; that buffer, then if you forget about it after a while, you won't -;; accidentally exit Emacs. To unlock the buffer, just goto the buffer and -;; run toggle-emacs-lock again. - -;;; Code: - -(defvar emacs-lock-from-exiting nil - "Whether Emacs is locked to prevent exiting. See `check-emacs-lock'.") -(make-variable-buffer-local 'emacs-lock-from-exiting) - -(defvar emacs-lock-buffer-locked nil - "Whether a shell or telnet buffer was locked when its process was killed.") -(make-variable-buffer-local 'emacs-lock-buffer-locked) -(put 'emacs-lock-buffer-locked 'permanent-local t) - -(defun check-emacs-lock () - "Check if variable `emacs-lock-from-exiting' is t for any buffer. -If any locked buffer is found, signal error and display the buffer's name." - (save-excursion - (dolist (buffer (buffer-list)) - (set-buffer buffer) - (when emacs-lock-from-exiting - (error "Emacs is locked from exit due to buffer: %s" (buffer-name)))))) - -(defun toggle-emacs-lock () - "Toggle `emacs-lock-from-exiting' for the current buffer. -See `check-emacs-lock'." - (interactive) - (setq emacs-lock-from-exiting (not emacs-lock-from-exiting)) - (if emacs-lock-from-exiting - (message "Buffer is now locked") - (message "Buffer is now unlocked"))) - -(defun emacs-lock-check-buffer-lock () - "Check if variable `emacs-lock-from-exiting' is t for a buffer. -If the buffer is locked, signal error and display its name." - (when emacs-lock-from-exiting - (error "Buffer `%s' is locked, can't delete it" (buffer-name)))) - -; These next defuns make it so if you exit a shell that is locked, the lock -; is shut off for that shell so you can exit Emacs. Same for telnet. -; Also, if a shell or a telnet buffer was locked and the process killed, -; turn the lock back on again if the process is restarted. - -(defun emacs-lock-shell-sentinel () - (set-process-sentinel - (get-buffer-process (buffer-name)) (function emacs-lock-clear-sentinel))) - -(defun emacs-lock-clear-sentinel (_proc _str) - (if emacs-lock-from-exiting - (progn - (setq emacs-lock-from-exiting nil) - (setq emacs-lock-buffer-locked t) - (message "Buffer is now unlocked")) - (setq emacs-lock-buffer-locked nil))) - -(defun emacs-lock-was-buffer-locked () - (if emacs-lock-buffer-locked - (setq emacs-lock-from-exiting t))) - -(unless noninteractive - (add-hook 'kill-emacs-hook #'check-emacs-lock)) -(add-hook 'kill-buffer-hook #'emacs-lock-check-buffer-lock) -(add-hook 'shell-mode-hook #'emacs-lock-was-buffer-locked) -(add-hook 'shell-mode-hook #'emacs-lock-shell-sentinel) -(add-hook 'telnet-mode-hook #'emacs-lock-was-buffer-locked) -(add-hook 'telnet-mode-hook #'emacs-lock-shell-sentinel) - -(provide 'emacs-lock) - -;;; old-emacs-lock.el ends here diff --git a/lisp/obsolete/patcomp.el b/lisp/obsolete/patcomp.el deleted file mode 100644 index 2c35cb07007..00000000000 --- a/lisp/obsolete/patcomp.el +++ /dev/null @@ -1,24 +0,0 @@ -;;; patcomp.el --- used by patch files to update Emacs releases -*- lexical-binding: t; -*- - -;; This file is part of GNU Emacs. - -;; Obsolete-since: 24.3 - -;;; Commentary: - -;;; Code: - -(defun batch-byte-recompile-emacs () - "Recompile the Emacs `lisp' directory. -This is used after installing the patches for a new version." - (let ((load-path (list (expand-file-name "lisp")))) - (byte-recompile-directory "lisp"))) - -(defun batch-byte-compile-emacs () - "Compile new files installed in the Emacs `lisp' directory. -This is used after installing the patches for a new version. -It uses the command line arguments to specify the files to compile." - (let ((load-path (list (expand-file-name "lisp")))) - (batch-byte-compile))) - -;;; patcomp.el ends here diff --git a/lisp/obsolete/pc-select.el b/lisp/obsolete/pc-select.el deleted file mode 100644 index 922358bcd66..00000000000 --- a/lisp/obsolete/pc-select.el +++ /dev/null @@ -1,410 +0,0 @@ -;;; pc-select.el --- emulate mark, cut, copy and paste from Motif -*- lexical-binding: t; -*- -;;; (or MAC GUI or MS-windoze (bah)) look-and-feel -;;; including key bindings. - -;; Copyright (C) 1995-1997, 2000-2022 Free Software Foundation, Inc. - -;; Author: Michael Staats -;; Keywords: convenience emulations -;; Created: 26 Sep 1995 -;; Obsolete-since: 24.1 - -;; 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 . - -;;; Commentary: - -;; This package emulates the mark, copy, cut and paste look-and-feel of motif -;; programs (which is the same as the MAC gui and (sorry for that) MS-Windows). -;; It modifies the keybindings of the cursor keys and the next, prior, -;; home and end keys. They will modify mark-active. -;; You can still get the old behavior of cursor moving with the -;; control sequences C-f, C-b, etc. -;; This package uses transient-mark-mode and -;; delete-selection-mode. -;; -;; In addition to that all key-bindings from the pc-mode are -;; done here too (as suggested by RMS). -;; -;; As I found out after I finished the first version, s-region.el tries -;; to do the same.... But my code is a little more complete and using -;; delete-selection-mode is very important for the look-and-feel. -;; Pete Forman provided some motif -;; compliant keybindings which I added. I had to modify them a little -;; to add the -mark and -nomark functionality of cursor moving. -;; -;; Credits: -;; Many thanks to all who made comments. -;; Thanks to RMS and Ralf Muschall for criticism. -;; Kevin Cutts added the beginning-of-buffer -;; and end-of-buffer functions which I modified a little. -;; David Biesack suggested some more cleanup. -;; Thanks to Pete Forman -;; for additional motif keybindings. -;; Thanks to jvromans@squirrel.nl (Johan Vromans) for a bug report -;; concerning setting of this-command. -;; Dan Nicolaescu suggested suppressing the -;; scroll-up/scroll-down error. -;; Eli Barzilay (eli@cs.bgu.ac.il) suggested the sexps functions and -;; keybindings. -;; -;; Ok, some details about the idea of PC Selection mode: -;; -;; o The standard keys for moving around (right, left, up, down, home, end, -;; prior, next, called "move-keys" from now on) will always de-activate -;; the mark. -;; o If you press "Shift" together with the "move-keys", the region -;; you pass along is activated -;; o You have the copy, cut and paste functions (as in many other programs) -;; which will operate on the active region -;; It was not possible to bind them to C-v, C-x and C-c for obvious -;; emacs reasons. -;; They will be bound according to the "old" behavior to S-delete (cut), -;; S-insert (paste) and C-insert (copy). These keys do the same in many -;; other programs. -;; - -;;; Code: - -;; Customization: -(defgroup pc-select nil - "Emulate pc bindings." - :prefix "pc-select" - :group 'emulations) - -(define-obsolete-variable-alias 'pc-select-override-scroll-error - 'scroll-error-top-bottom - "24.1") -(defcustom pc-select-override-scroll-error t - "Non-nil means don't generate error on scrolling past edge of buffer. -This variable applies in PC Selection mode only. -The scroll commands normally generate an error if you try to scroll -past the top or bottom of the buffer. This is annoying when selecting -text with these commands. If you set this variable to non-nil, these -errors are suppressed." - :type 'boolean) - -(defcustom pc-select-selection-keys-only nil - "Non-nil means only bind the basic selection keys when started. -Other keys that emulate pc-behavior will be untouched. -This gives mostly Emacs-like behavior with only the selection keys enabled." - :type 'boolean) - -(defcustom pc-select-meta-moves-sexps nil - "Non-nil means move sexp-wise with Meta key, otherwise move word-wise." - :type 'boolean) - -(defcustom pc-selection-mode-hook nil - "The hook to run when PC Selection mode is toggled." - :type 'hook) - -(defvar pc-select-saved-settings-alist nil - "The values of the variables before PC Selection mode was toggled on. -When PC Selection mode is toggled on, it sets quite a few variables -for its own purposes. This alist holds the original values of the -variables PC Selection mode had set, so that these variables can be -restored to their original values when PC Selection mode is toggled off.") - -(defvar pc-select-map nil - "The keymap used as the global map when PC Selection mode is on." ) - -(defvar pc-select-saved-global-map nil - "The global map that was in effect when PC Selection mode was toggled on.") - -(defvar pc-select-key-bindings-alist nil - "This alist holds all the key bindings PC Selection mode sets.") - -(defvar pc-select-default-key-bindings nil - "These key bindings always get set by PC Selection mode.") - -(defvar pc-select-extra-key-bindings - ;; The following keybindings are for standard ISO keyboards - ;; as they are used with IBM compatible PCs, IBM RS/6000, - ;; MACs, many X-Stations and probably more. - '(;; Commented out since it's been standard at least since Emacs-21. - ;;([S-insert] . yank) - ;;([C-insert] . copy-region-as-kill) - ;;([S-delete] . kill-region) - - ;; The following bindings are useful on Sun Type 3 keyboards - ;; They implement the Get-Delete-Put (copy-cut-paste) - ;; functions from sunview on the L6, L8 and L10 keys - ;; Sam Steingold says that f16 is copy and f18 is paste. - ([f16] . copy-region-as-kill) - ([f18] . yank) - ([f20] . kill-region) - - ;; The following bindings are from Pete Forman. - ([f6] . other-window) ; KNextPane F6 - ([C-delete] . kill-line) ; KEraseEndLine cDel - ("\M-\d" . undo) ; KUndo aBS - - ;; The following binding is taken from pc-mode.el - ;; as suggested by RMS. - ;; I only used the one that is not covered above. - ([C-M-delete] . kill-sexp) - ;; Next line proposed by Eli Barzilay - ([C-escape] . electric-buffer-list)) - "Key bindings to set only if `pc-select-selection-keys-only' is nil.") - -(defvar pc-select-meta-moves-sexps-key-bindings - '((([M-right] . forward-sexp) - ([M-left] . backward-sexp)) - (([M-right] . forward-word) - ([M-left] . backward-word))) - "The list of key bindings controlled by `pc-select-meta-moves-sexp'. -The bindings in the car of this list get installed if -`pc-select-meta-moves-sexp' is t, the bindings in the cadr of this -list get installed otherwise.") - -;; This is for tty. We don't turn on normal-erase-is-backspace, -;; but bind keys as pc-selection-mode did before -;; normal-erase-is-backspace was invented, to keep us back -;; compatible. -(defvar pc-select-tty-key-bindings - '(([delete] . delete-char) ; KDelete Del - ([C-backspace] . backward-kill-word)) - "The list of key bindings controlled by `pc-select-selection-keys-only'. -These key bindings get installed when running in a tty, but only if -`pc-select-selection-keys-only' is nil.") - -(defvar pc-select-old-M-delete-binding nil - "Holds the old mapping of [M-delete] in the `function-key-map'. -This variable holds the value associated with [M-delete] in the -`function-key-map' before PC Selection mode had changed that -association.") - -;;;; -;; misc -;;;; - -(provide 'pc-select) - -(defun pc-select-define-keys (alist keymap) - "Make KEYMAP have the key bindings specified in ALIST." - (let ((lst alist)) - (while lst - (define-key keymap (caar lst) (cdar lst)) - (setq lst (cdr lst))))) - -(defun pc-select-restore-keys (alist keymap saved-map) - "Use ALIST to restore key bindings from SAVED-MAP into KEYMAP. -Go through all the key bindings in ALIST, and, for each key -binding, if KEYMAP and ALIST still agree on the key binding, -restore the previous value of that key binding from SAVED-MAP." - (let ((lst alist)) - (while lst - (when (equal (lookup-key keymap (caar lst)) (cdar lst)) - (define-key keymap (caar lst) (lookup-key saved-map (caar lst)))) - (setq lst (cdr lst))))) - -(defmacro pc-select-add-to-alist (alist var val) - "Ensure that ALIST contains the cons cell (VAR . VAL). -If a cons cell whose car is VAR is already on the ALIST, update the -cdr of that cell with VAL. Otherwise, make a new cons cell -\(VAR . VAL), and prepend it onto ALIST." - (let ((elt (make-symbol "elt"))) - `(let ((,elt (assq ',var ,alist))) - (if ,elt - (setcdr ,elt ,val) - (setq ,alist (cons (cons ',var ,val) ,alist)))))) - -(defmacro pc-select-save-and-set-var (var newval) - "Set VAR to NEWVAL; save the old value. -The old value is saved on the `pc-select-saved-settings-alist'." - `(when (boundp ',var) - (pc-select-add-to-alist pc-select-saved-settings-alist ,var ,var) - (setq ,var ,newval))) - -(defmacro pc-select-save-and-set-mode (mode &optional arg mode-var) - "Call the function MODE; save the old value of the variable MODE. -MODE is presumed to be a function which turns on a minor mode. First, -save the value of the variable MODE on `pc-select-saved-settings-alist'. -Then, if ARG is specified, call MODE with ARG, otherwise call it with -nil as an argument. If MODE-VAR is specified, save the value of the -variable MODE-VAR (instead of the value of the variable MODE) on -`pc-select-saved-settings-alist'." - (unless mode-var (setq mode-var mode)) - `(when (fboundp ',mode) - (pc-select-add-to-alist pc-select-saved-settings-alist - ,mode-var ,mode-var) - (,mode ,arg))) - -(defmacro pc-select-restore-var (var) - "Restore the previous value of the variable VAR. -Look up VAR's previous value in `pc-select-saved-settings-alist', and, -if the value is found, set VAR to that value." - (let ((elt (make-symbol "elt"))) - `(let ((,elt (assq ',var pc-select-saved-settings-alist))) - (unless (null ,elt) - (setq ,var (cdr ,elt)))))) - -(defmacro pc-select-restore-mode (mode) - "Restore the previous state (either on or off) of the minor mode MODE. -Look up the value of the variable MODE on `pc-select-saved-settings-alist'. -If the value is non-nil, call the function MODE with an argument of -1, otherwise call it with an argument of -1." - (let ((elt (make-symbol "elt"))) - `(when (fboundp ',mode) - (let ((,elt (assq ',mode pc-select-saved-settings-alist))) - (unless (null ,elt) - (,mode (if (cdr ,elt) 1 -1))))))) - - -;;;###autoload -(define-minor-mode pc-selection-mode - "Change mark behavior to emulate Motif, Mac or MS-Windows cut and paste style. - -This mode enables Delete Selection mode and Transient Mark mode. - -The arrow keys (and others) are bound to new functions -which modify the status of the mark. - -The ordinary arrow keys disable the mark. -The shift-arrow keys move, leaving the mark behind. - -C-LEFT and C-RIGHT move back or forward one word, disabling the mark. -S-C-LEFT and S-C-RIGHT move back or forward one word, leaving the mark behind. - -M-LEFT and M-RIGHT move back or forward one word or sexp, disabling the mark. -S-M-LEFT and S-M-RIGHT move back or forward one word or sexp, leaving the mark -behind. To control whether these keys move word-wise or sexp-wise set the -variable `pc-select-meta-moves-sexps' after loading pc-select.el but before -turning PC Selection mode on. - -C-DOWN and C-UP move back or forward a paragraph, disabling the mark. -S-C-DOWN and S-C-UP move back or forward a paragraph, leaving the mark behind. - -HOME moves to beginning of line, disabling the mark. -S-HOME moves to beginning of line, leaving the mark behind. -With Ctrl or Meta, these keys move to beginning of buffer instead. - -END moves to end of line, disabling the mark. -S-END moves to end of line, leaving the mark behind. -With Ctrl or Meta, these keys move to end of buffer instead. - -PRIOR or PAGE-UP scrolls and disables the mark. -S-PRIOR or S-PAGE-UP scrolls and leaves the mark behind. - -S-DELETE kills the region (`kill-region'). -S-INSERT yanks text from the kill ring (`yank'). -C-INSERT copies the region into the kill ring (`copy-region-as-kill'). - -In addition, certain other PC bindings are imitated (to avoid this, set -the variable `pc-select-selection-keys-only' to t after loading pc-select.el -but before calling PC Selection mode): - - F6 other-window - DELETE delete-char - C-DELETE kill-line - M-DELETE kill-word - C-M-DELETE kill-sexp - C-BACKSPACE backward-kill-word - M-BACKSPACE undo" - ;; FIXME: bring pc-bindings-mode here ? - :global t - - (if pc-selection-mode - (if (null pc-select-key-bindings-alist) - (progn - (setq pc-select-saved-global-map (copy-keymap (current-global-map))) - (setq pc-select-key-bindings-alist - (append pc-select-default-key-bindings - (if pc-select-selection-keys-only - nil - pc-select-extra-key-bindings) - (if pc-select-meta-moves-sexps - (car pc-select-meta-moves-sexps-key-bindings) - (cadr pc-select-meta-moves-sexps-key-bindings)) - (if (or pc-select-selection-keys-only - (eq window-system 'x) - (memq system-type '(ms-dos windows-nt))) - nil - pc-select-tty-key-bindings))) - - (pc-select-define-keys pc-select-key-bindings-alist - (current-global-map)) - - (unless (or pc-select-selection-keys-only - (eq window-system 'x) - (memq system-type '(ms-dos windows-nt))) - ;; it is not clear that we need the following line - ;; I hope it doesn't do too much harm to leave it in, though... - (setq pc-select-old-M-delete-binding - (lookup-key function-key-map [M-delete])) - (define-key function-key-map [M-delete] [?\M-d])) - - (when (and (not pc-select-selection-keys-only) - (or (eq window-system 'x) - (memq system-type '(ms-dos windows-nt))) - (fboundp 'normal-erase-is-backspace-mode)) - (pc-select-save-and-set-mode normal-erase-is-backspace-mode 1 - normal-erase-is-backspace)) - ;; the original author also had this above: - ;; (setq-default normal-erase-is-backspace t) - ;; However, the documentation for the variable says that - ;; "setting it with setq has no effect", so I'm removing it. - - (pc-select-save-and-set-var highlight-nonselected-windows nil) - (pc-select-save-and-set-var transient-mark-mode t) - (pc-select-save-and-set-var shift-select-mode t) - (pc-select-save-and-set-var mark-even-if-inactive t) - (pc-select-save-and-set-mode delete-selection-mode 1)) - ;;else - ;; If the user turned on pc-selection-mode a second time - ;; do not clobber the values of the variables that were - ;; saved from before pc-selection mode was activated -- - ;; just make sure the values are the way we like them. - (pc-select-define-keys pc-select-key-bindings-alist - (current-global-map)) - (unless (or pc-select-selection-keys-only - (eq window-system 'x) - (memq system-type '(ms-dos windows-nt))) - ;; it is not clear that we need the following line - ;; I hope it doesn't do too much harm to leave it in, though... - (define-key function-key-map [M-delete] [?\M-d])) - (when (and (not pc-select-selection-keys-only) - (or (eq window-system 'x) - (memq system-type '(ms-dos windows-nt))) - (fboundp 'normal-erase-is-backspace-mode)) - (normal-erase-is-backspace-mode 1)) - (setq highlight-nonselected-windows nil) - (transient-mark-mode 1) - (setq mark-even-if-inactive t) - (delete-selection-mode 1)) - ;;else - (when pc-select-key-bindings-alist - (when (and (not pc-select-selection-keys-only) - (or (eq window-system 'x) - (memq system-type '(ms-dos windows-nt)))) - (pc-select-restore-mode normal-erase-is-backspace-mode)) - - (pc-select-restore-keys - pc-select-key-bindings-alist (current-global-map) - pc-select-saved-global-map) - - (pc-select-restore-var highlight-nonselected-windows) - (pc-select-restore-var transient-mark-mode) - (pc-select-restore-var shift-select-mode) - (pc-select-restore-var mark-even-if-inactive) - (pc-select-restore-mode delete-selection-mode) - (and pc-select-old-M-delete-binding - (define-key function-key-map [M-delete] - pc-select-old-M-delete-binding)) - (setq pc-select-key-bindings-alist nil - pc-select-saved-settings-alist nil)))) -(make-obsolete 'pc-selection-mode 'delete-selection-mode "24.1") - -;;; pc-select.el ends here diff --git a/lisp/obsolete/s-region.el b/lisp/obsolete/s-region.el deleted file mode 100644 index 9dfc9831f4e..00000000000 --- a/lisp/obsolete/s-region.el +++ /dev/null @@ -1,123 +0,0 @@ -;;; s-region.el --- set region using shift key -*- lexical-binding: t; -*- - -;; Copyright (C) 1994-1995, 2001-2022 Free Software Foundation, Inc. - -;; Author: Morten Welinder -;; Keywords: terminals -;; Favorite-brand-of-beer: None, I hate beer. -;; Obsolete-since: 24.1 - -;; 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 . - -;;; Commentary: - -;; Having loaded this code you can set the region by holding down the -;; shift key and move the cursor to the other end of the region. The -;; functionality provided by this code is similar to that provided by -;; the editors of Borland International's compilers for ms-dos. - -;; Currently, s-region-move may be bound only to events that are vectors -;; of length one and whose last element is a symbol. Also, the functions -;; that are given this kind of overlay should be (interactive "p") -;; functions. - -;; If the following keys are not already bound then... -;; C-insert is bound to copy-region-as-kill -;; S-delete is bound to kill-region -;; S-insert is bound to yank - -;;; Code: - -(defvar s-region-overlay (make-overlay 1 1)) -(overlay-put s-region-overlay 'face 'region) -(overlay-put s-region-overlay 'priority 1000000) ; for hilit19 - -(defun s-region-unshift (key) - "Remove shift modifier from last keypress KEY and return that as a key." - (if (vectorp key) - (let ((last (aref key (1- (length key))))) - (if (symbolp last) - (let* ((keyname (symbol-name last)) - (pos (string-match "S-" keyname))) - (if pos - ;; We skip all initial parts of the event assuming that - ;; those are setting up the prefix argument to the command. - (vector (intern (concat (substring keyname 0 pos) - (substring keyname (+ 2 pos))))) - (error "Non-shifted key: %S" key))) - (error "Key does not end in a symbol: %S" key))) - (error "Non-vector key: %S" key))) - -(defun s-region-move-p1 (&rest arg) - "This is an overlay function to point-moving keys that are interactive \"p\"." - (interactive "p") - (apply (function s-region-move) arg)) - -(defun s-region-move-p2 (&rest arg) - "This is an overlay function to point-moving keys that are interactive \"P\"." - (interactive "P") - (apply (function s-region-move) arg)) - -(defun s-region-move (&rest arg) - (if (if mark-active (not (equal last-command 's-region-move)) t) - (set-mark-command nil) - (message "")) ; delete the "Mark set" message - (setq this-command 's-region-move) - (apply (key-binding (s-region-unshift (this-command-keys))) arg) - (move-overlay s-region-overlay (mark) (point) (current-buffer)) - (sit-for 1) - (delete-overlay s-region-overlay)) - -(defun s-region-bind (keylist &optional map) - "Bind shifted keys in KEYLIST to `s-region-move-p1' or `s-region-move-p2'. -Each key in KEYLIST is shifted and bound to one of the `s-region-move' -functions provided it is already bound to some command or other. -Optional second argument MAP specifies keymap to add binding to, defaulting -to global keymap." - (let ((p2 (list 'scroll-up 'scroll-down - 'beginning-of-buffer 'end-of-buffer))) - (or map (setq map global-map)) - (while keylist - (let* ((key (car keylist)) - (binding (key-binding key))) - (if (commandp binding) - (define-key - map - (vector (intern (concat "S-" (symbol-name (aref key 0))))) - (cond ((memq binding p2) - 's-region-move-p2) - (t 's-region-move-p1))))) - (setq keylist (cdr keylist))))) - -;; Single keys (plus modifiers) only! -(s-region-bind - (list [right] [left] [up] [down] - [C-left] [C-right] [C-up] [C-down] - [M-left] [M-right] [M-up] [M-down] - [next] [previous] [home] [end] - [C-next] [C-previous] [C-home] [C-end] - [M-next] [M-previous] [M-home] [M-end])) - -(or (global-key-binding [C-insert]) - (global-set-key [C-insert] #'copy-region-as-kill)) -(or (global-key-binding [S-delete]) - (global-set-key [S-delete] #'kill-region)) -(or (global-key-binding [S-insert]) - (global-set-key [S-insert] #'yank)) - -(provide 's-region) - -;;; s-region.el ends here diff --git a/lisp/obsolete/sregex.el b/lisp/obsolete/sregex.el deleted file mode 100644 index f8722f6129e..00000000000 --- a/lisp/obsolete/sregex.el +++ /dev/null @@ -1,605 +0,0 @@ -;;; sregex.el --- symbolic regular expressions -*- lexical-binding: t; -*- - -;; Copyright (C) 1997-1998, 2000-2022 Free Software Foundation, Inc. - -;; Author: Bob Glickstein -;; Maintainer: emacs-devel@gnu.org -;; Keywords: extensions -;; Obsolete-since: 24.1 - -;; 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 . - -;;; Commentary: - -;; This package allows you to write regular expressions using a -;; totally new, Lisp-like syntax. - -;; A "symbolic regular expression" (sregex for short) is a Lisp form -;; that, when evaluated, produces the string form of the specified -;; regular expression. Here's a simple example: - -;; (sregexq (or "Bob" "Robert")) => "Bob\\|Robert" - -;; As you can see, an sregex is specified by placing one or more -;; special clauses in a call to `sregexq'. The clause in this case is -;; the `or' of two strings (not to be confused with the Lisp function -;; `or'). The list of allowable clauses appears below. - -;; With sregex, it is never necessary to "escape" magic characters -;; that are meant to be taken literally; that happens automatically. -;; For example: - -;; (sregexq "M*A*S*H") => "M\\*A\\*S\\*H" - -;; It is also unnecessary to "group" parts of the expression together -;; to overcome operator precedence; that also happens automatically. -;; For example: - -;; (sregexq (opt (or "Bob" "Robert"))) => "\\(?:Bob\\|Robert\\)?" - -;; It *is* possible to group parts of the expression in order to refer -;; to them with numbered backreferences: - -;; (sregexq (group (or "Go" "Run")) -;; ", Spot, " -;; (backref 1)) => "\\(Go\\|Run\\), Spot, \\1" - -;; `sregexq' is a macro. Each time it is used, it constructs a simple -;; Lisp expression that then invokes a moderately complex engine to -;; interpret the sregex and render the string form. Because of this, -;; I don't recommend sprinkling calls to `sregexq' throughout your -;; code, the way one normally does with string regexes (which are -;; cheap to evaluate). Instead, it's wiser to precompute the regexes -;; you need wherever possible instead of repeatedly constructing the -;; same ones over and over. Example: - -;; (let ((field-regex (sregexq (opt "resent-") -;; (or "to" "cc" "bcc")))) -;; ... -;; (while ... -;; ... -;; (re-search-forward field-regex ...) -;; ...)) - -;; The arguments to `sregexq' are automatically quoted, but the -;; flipside of this is that it is not straightforward to include -;; computed (i.e., non-constant) values in `sregexq' expressions. So -;; `sregex' is a function that is like `sregexq' but which does not -;; automatically quote its values. Literal sregex clauses must be -;; explicitly quoted like so: - -;; (sregex '(or "Bob" "Robert")) => "Bob\\|Robert" - -;; but computed clauses can be included easily, allowing for the reuse -;; of common clauses: - -;; (let ((dotstar '(0+ any)) -;; (whitespace '(1+ (syntax ?-))) -;; (digits '(1+ (char (?0 . ?9))))) -;; (sregex 'bol dotstar ":" whitespace digits)) => "^.*:\\s-+[0-9]+" - -;; To use this package in a Lisp program, simply (require 'sregex). - -;; Here are the clauses allowed in an `sregex' or `sregexq' -;; expression: - -;; - a string -;; This stands for the literal string. If it contains -;; metacharacters, they will be escaped in the resulting regex -;; (using `regexp-quote'). - -;; - the symbol `any' -;; This stands for ".", a regex matching any character except -;; newline. - -;; - the symbol `bol' -;; Stands for "^", matching the empty string at the beginning of a line - -;; - the symbol `eol' -;; Stands for "$", matching the empty string at the end of a line - -;; - (group CLAUSE ...) -;; Groups the given CLAUSEs using "\\(" and "\\)". - -;; - (sequence CLAUSE ...) - -;; Groups the given CLAUSEs; may or may not use "\\(?:" and "\\)". -;; Clauses grouped by `sequence' do not count for purposes of -;; numbering backreferences. Use `sequence' in situations like -;; this: - -;; (sregexq (or "dog" "cat" -;; (sequence (opt "sea ") "monkey"))) -;; => "dog\\|cat\\|\\(?:sea \\)?monkey" - -;; where a single `or' alternate needs to contain multiple -;; subclauses. - -;; - (backref N) -;; Matches the same string previously matched by the Nth "group" in -;; the same sregex. N is a positive integer. - -;; - (or CLAUSE ...) -;; Matches any one of the CLAUSEs by separating them with "\\|". - -;; - (0+ CLAUSE ...) -;; Concatenates the given CLAUSEs and matches zero or more -;; occurrences by appending "*". - -;; - (1+ CLAUSE ...) -;; Concatenates the given CLAUSEs and matches one or more -;; occurrences by appending "+". - -;; - (opt CLAUSE ...) -;; Concatenates the given CLAUSEs and matches zero or one occurrence -;; by appending "?". - -;; - (repeat MIN MAX CLAUSE ...) -;; Concatenates the given CLAUSEs and constructs a regex matching at -;; least MIN occurrences and at most MAX occurrences. MIN must be a -;; non-negative integer. MAX must be a non-negative integer greater -;; than or equal to MIN; or MAX can be nil to mean "infinity." - -;; - (char CHAR-CLAUSE ...) -;; Creates a "character class" matching one character from the given -;; set. See below for how to construct a CHAR-CLAUSE. - -;; - (not-char CHAR-CLAUSE ...) -;; Creates a "character class" matching any one character not in the -;; given set. See below for how to construct a CHAR-CLAUSE. - -;; - the symbol `bot' -;; Stands for "\\`", matching the empty string at the beginning of -;; text (beginning of a string or of a buffer). - -;; - the symbol `eot' -;; Stands for "\\'", matching the empty string at the end of text. - -;; - the symbol `point' -;; Stands for "\\=", matching the empty string at point. - -;; - the symbol `word-boundary' -;; Stands for "\\b", matching the empty string at the beginning or -;; end of a word. - -;; - the symbol `not-word-boundary' -;; Stands for "\\B", matching the empty string not at the beginning -;; or end of a word. - -;; - the symbol `bow' -;; Stands for "\\<", matching the empty string at the beginning of a -;; word. - -;; - the symbol `eow' -;; Stands for "\\>", matching the empty string at the end of a word. - -;; - the symbol `wordchar' -;; Stands for the regex "\\w", matching a word-constituent character -;; (as determined by the current syntax table) - -;; - the symbol `not-wordchar' -;; Stands for the regex "\\W", matching a non-word-constituent -;; character. - -;; - (syntax CODE) -;; Stands for the regex "\\sCODE", where CODE is a syntax table code -;; (a single character). Matches any character with the requested -;; syntax. - -;; - (not-syntax CODE) -;; Stands for the regex "\\SCODE", where CODE is a syntax table code -;; (a single character). Matches any character without the -;; requested syntax. - -;; - (regex REGEX) -;; This is a "trapdoor" for including ordinary regular expression -;; strings in the result. Some regular expressions are clearer when -;; written the old way: "[a-z]" vs. (sregexq (char (?a . ?z))), for -;; instance. - -;; Each CHAR-CLAUSE that is passed to (char ...) and (not-char ...) -;; has one of the following forms: - -;; - a character -;; Adds that character to the set. - -;; - a string -;; Adds all the characters in the string to the set. - -;; - A pair (MIN . MAX) -;; Where MIN and MAX are characters, adds the range of characters -;; from MIN through MAX to the set. - -;;; To do: - -;; An earlier version of this package could optionally translate the -;; symbolic regex into other languages' syntaxes, e.g. Perl. For -;; instance, with Perl syntax selected, (sregexq (or "ab" "cd")) would -;; yield "ab|cd" instead of "ab\\|cd". It might be useful to restore -;; such a facility. - -;; - handle multibyte chars in sregex--char-aux -;; - add support for character classes ([:blank:], ...) -;; - add support for non-greedy operators *? and +? -;; - bug: (sregexq (opt (opt ?a))) returns "a??" which is a non-greedy "a?" - -;;; Code: - -(eval-when-compile (require 'cl-lib)) - -;; Compatibility code for when we didn't have shy-groups -(defvar sregex--current-sregex nil) -(defun sregex-info () nil) -(defmacro sregex-save-match-data (&rest forms) (cons 'save-match-data forms)) -(defun sregex-replace-match (r &optional f l str subexp _x) - (replace-match r f l str subexp)) -(defun sregex-match-string (c &optional i _x) (match-string c i)) -(defun sregex-match-string-no-properties (count &optional in-string _sregex) - (match-string-no-properties count in-string)) -(defun sregex-match-beginning (count &optional _sregex) (match-beginning count)) -(defun sregex-match-end (count &optional _sregex) (match-end count)) -(defun sregex-match-data (&optional _sregex) (match-data)) -(defun sregex-backref-num (n &optional _sregex) n) - - -(defun sregex (&rest exps) - "Symbolic regular expression interpreter. -This is exactly like `sregexq' (q.v.) except that it evaluates all its -arguments, so literal sregex clauses must be quoted. For example: - - (sregex \\='(or \"Bob\" \"Robert\")) => \"Bob\\\\|Robert\" - -An argument-evaluating sregex interpreter lets you reuse sregex -subexpressions: - - (let ((dotstar \\='(0+ any)) - (whitespace \\='(1+ (syntax ?-))) - (digits \\='(1+ (char (?0 . ?9))))) - (sregex \\='bol dotstar \":\" whitespace digits)) => \"^.*:\\\\s-+[0-9]+\"" - (sregex--sequence exps nil)) - -(defmacro sregexq (&rest exps) - "Symbolic regular expression interpreter. -This macro allows you to specify a regular expression (regexp) in -symbolic form, and converts it into the string form required by Emacs's -regex functions such as `re-search-forward' and `looking-at'. Here is -a simple example: - - (sregexq (or \"Bob\" \"Robert\")) => \"Bob\\\\|Robert\" - -As you can see, an sregex is specified by placing one or more special -clauses in a call to `sregexq'. The clause in this case is the `or' -of two strings (not to be confused with the Lisp function `or'). The -list of allowable clauses appears below. - -With `sregex', it is never necessary to \"escape\" magic characters -that are meant to be taken literally; that happens automatically. -For example: - - (sregexq \"M*A*S*H\") => \"M\\\\*A\\\\*S\\\\*H\" - -It is also unnecessary to \"group\" parts of the expression together -to overcome operator precedence; that also happens automatically. -For example: - - (sregexq (opt (or \"Bob\" \"Robert\"))) => \"\\\\(Bob\\\\|Robert\\\\)?\" - -It *is* possible to group parts of the expression in order to refer -to them with numbered backreferences: - - (sregexq (group (or \"Go\" \"Run\")) - \", Spot, \" - (backref 1)) => \"\\\\(Go\\\\|Run\\\\), Spot, \\\\1\" - -If `sregexq' needs to introduce its own grouping parentheses, it will -automatically renumber your backreferences: - - (sregexq (opt \"resent-\") - (group (or \"to\" \"cc\" \"bcc\")) - \": \" - (backref 1)) => \"\\\\(resent-\\\\)?\\\\(to\\\\|cc\\\\|bcc\\\\): \\\\2\" - -`sregexq' is a macro. Each time it is used, it constructs a simple -Lisp expression that then invokes a moderately complex engine to -interpret the sregex and render the string form. Because of this, I -don't recommend sprinkling calls to `sregexq' throughout your code, -the way one normally does with string regexes (which are cheap to -evaluate). Instead, it's wiser to precompute the regexes you need -wherever possible instead of repeatedly constructing the same ones -over and over. Example: - - (let ((field-regex (sregexq (opt \"resent-\") - (or \"to\" \"cc\" \"bcc\")))) - ... - (while ... - ... - (re-search-forward field-regex ...) - ...)) - -The arguments to `sregexq' are automatically quoted, but the -flipside of this is that it is not straightforward to include -computed (i.e., non-constant) values in `sregexq' expressions. So -`sregex' is a function that is like `sregexq' but which does not -automatically quote its values. Literal sregex clauses must be -explicitly quoted like so: - - (sregex \\='(or \"Bob\" \"Robert\")) => \"Bob\\\\|Robert\" - -but computed clauses can be included easily, allowing for the reuse -of common clauses: - - (let ((dotstar \\='(0+ any)) - (whitespace \\='(1+ (syntax ?-))) - (digits \\='(1+ (char (?0 . ?9))))) - (sregex \\='bol dotstar \":\" whitespace digits)) => \"^.*:\\\\s-+[0-9]+\" - -Here are the clauses allowed in an `sregex' or `sregexq' expression: - -- a string - This stands for the literal string. If it contains - metacharacters, they will be escaped in the resulting regex - (using `regexp-quote'). - -- the symbol `any' - This stands for \".\", a regex matching any character except - newline. - -- the symbol `bol' - Stands for \"^\", matching the empty string at the beginning of a line - -- the symbol `eol' - Stands for \"$\", matching the empty string at the end of a line - -- (group CLAUSE ...) - Groups the given CLAUSEs using \"\\\\(\" and \"\\\\)\". - -- (sequence CLAUSE ...) - - Groups the given CLAUSEs; may or may not use \"\\\\(\" and \"\\\\)\". - Clauses grouped by `sequence' do not count for purposes of - numbering backreferences. Use `sequence' in situations like - this: - - (sregexq (or \"dog\" \"cat\" - (sequence (opt \"sea \") \"monkey\"))) - => \"dog\\\\|cat\\\\|\\\\(?:sea \\\\)?monkey\" - - where a single `or' alternate needs to contain multiple - subclauses. - -- (backref N) - Matches the same string previously matched by the Nth \"group\" in - the same sregex. N is a positive integer. - -- (or CLAUSE ...) - Matches any one of the CLAUSEs by separating them with \"\\\\|\". - -- (0+ CLAUSE ...) - Concatenates the given CLAUSEs and matches zero or more - occurrences by appending \"*\". - -- (1+ CLAUSE ...) - Concatenates the given CLAUSEs and matches one or more - occurrences by appending \"+\". - -- (opt CLAUSE ...) - Concatenates the given CLAUSEs and matches zero or one occurrence - by appending \"?\". - -- (repeat MIN MAX CLAUSE ...) - Concatenates the given CLAUSEs and constructs a regex matching at - least MIN occurrences and at most MAX occurrences. MIN must be a - non-negative integer. MAX must be a non-negative integer greater - than or equal to MIN; or MAX can be nil to mean \"infinity.\" - -- (char CHAR-CLAUSE ...) - Creates a \"character class\" matching one character from the given - set. See below for how to construct a CHAR-CLAUSE. - -- (not-char CHAR-CLAUSE ...) - Creates a \"character class\" matching any one character not in the - given set. See below for how to construct a CHAR-CLAUSE. - -- the symbol `bot' - Stands for \"\\\\\\=`\", matching the empty string at the beginning of - text (beginning of a string or of a buffer). - -- the symbol `eot' - Stands for \"\\\\'\", matching the empty string at the end of text. - -- the symbol `point' - Stands for \"\\\\=\\=\", matching the empty string at point. - -- the symbol `word-boundary' - Stands for \"\\\\b\", matching the empty string at the beginning or - end of a word. - -- the symbol `not-word-boundary' - Stands for \"\\\\B\", matching the empty string not at the beginning - or end of a word. - -- the symbol `bow' - Stands for \"\\\\=\\<\", matching the empty string at the beginning of a - word. - -- the symbol `eow' - Stands for \"\\\\=\\>\", matching the empty string at the end of a word. - -- the symbol `wordchar' - Stands for the regex \"\\\\w\", matching a word-constituent character - (as determined by the current syntax table) - -- the symbol `not-wordchar' - Stands for the regex \"\\\\W\", matching a non-word-constituent - character. - -- (syntax CODE) - Stands for the regex \"\\\\sCODE\", where CODE is a syntax table code - (a single character). Matches any character with the requested - syntax. - -- (not-syntax CODE) - Stands for the regex \"\\\\SCODE\", where CODE is a syntax table code - (a single character). Matches any character without the - requested syntax. - -- (regex REGEX) - This is a \"trapdoor\" for including ordinary regular expression - strings in the result. Some regular expressions are clearer when - written the old way: \"[a-z]\" vs. (sregexq (char (?a . ?z))), for - instance. - -Each CHAR-CLAUSE that is passed to (char ...) and (not-char ...) -has one of the following forms: - -- a character - Adds that character to the set. - -- a string - Adds all the characters in the string to the set. - -- A pair (MIN . MAX) - Where MIN and MAX are characters, adds the range of characters - from MIN through MAX to the set." - `(apply 'sregex ',exps)) - -(defun sregex--engine (exp combine) - (cond - ((stringp exp) - (if (and combine - (eq combine 'suffix) - (/= (length exp) 1)) - (concat "\\(?:" (regexp-quote exp) "\\)") - (regexp-quote exp))) - ((symbolp exp) - (cl-ecase exp - (any ".") - (bol "^") - (eol "$") - (wordchar "\\w") - (not-wordchar "\\W") - (bot "\\`") - (eot "\\'") - (point "\\=") - (word-boundary "\\b") - (not-word-boundary "\\B") - (bow "\\<") - (eow "\\>"))) - ((consp exp) - (funcall (intern (concat "sregex--" - (symbol-name (car exp)))) - (cdr exp) - combine)) - (t (error "Invalid expression: %s" exp)))) - -(defun sregex--sequence (exps combine) - (if (= (length exps) 1) (sregex--engine (car exps) combine) - (let ((re (mapconcat - (lambda (e) (sregex--engine e 'concat)) - exps ""))) - (if (eq combine 'suffix) - (concat "\\(?:" re "\\)") - re)))) - -(defun sregex--or (exps combine) - (if (= (length exps) 1) (sregex--engine (car exps) combine) - (let ((re (mapconcat - (lambda (e) (sregex--engine e 'or)) - exps "\\|"))) - (if (not (eq combine 'or)) - (concat "\\(?:" re "\\)") - re)))) - -(defun sregex--group (exps _combine) (concat "\\(" (sregex--sequence exps nil) "\\)")) - -(defun sregex--backref (exps _combine) (concat "\\" (int-to-string (car exps)))) -(defun sregex--opt (exps _combine) (concat (sregex--sequence exps 'suffix) "?")) -(defun sregex--0+ (exps _combine) (concat (sregex--sequence exps 'suffix) "*")) -(defun sregex--1+ (exps _combine) (concat (sregex--sequence exps 'suffix) "+")) - -(defun sregex--char (exps _combine) (sregex--char-aux nil exps)) -(defun sregex--not-char (exps _combine) (sregex--char-aux t exps)) - -(defun sregex--syntax (exps _combine) (format "\\s%c" (car exps))) -(defun sregex--not-syntax (exps _combine) (format "\\S%c" (car exps))) - -(defun sregex--regex (exps combine) - (if combine (concat "\\(?:" (car exps) "\\)") (car exps))) - -(defun sregex--repeat (exps _combine) - (let* ((min (or (pop exps) 0)) - (minstr (number-to-string min)) - (max (pop exps))) - (concat (sregex--sequence exps 'suffix) - (concat "\\{" minstr "," - (when max (number-to-string max)) "\\}")))) - -(defun sregex--char-range (start end) - (let ((startc (char-to-string start)) - (endc (char-to-string end))) - (cond - ((> end (+ start 2)) (concat startc "-" endc)) - ((> end (+ start 1)) (concat startc (char-to-string (1+ start)) endc)) - ((> end start) (concat startc endc)) - (t startc)))) - -(defun sregex--char-aux (complement args) - ;; regex-opt does the same, we should join effort. - (let ((chars (make-bool-vector 256 nil))) ; Yeah, right! - (dolist (arg args) - (cond ((integerp arg) (aset chars arg t)) - ((stringp arg) (mapc (lambda (c) (aset chars c t)) arg)) - ((consp arg) - (let ((start (car arg)) - (end (cdr arg))) - (when (> start end) - (let ((tmp start)) (setq start end) (setq end tmp))) - ;; now start <= end - (let ((i start)) - (while (<= i end) - (aset chars i t) - (setq i (1+ i)))))))) - ;; now chars is a map of the characters in the class - (let ((caret (aref chars ?^)) - (dash (aref chars ?-)) - (class (if (aref chars ?\]) "]" ""))) - (aset chars ?^ nil) - (aset chars ?- nil) - (aset chars ?\] nil) - - (let (start end) - (dotimes (i 256) - (if (aref chars i) - (progn - (unless start (setq start i)) - (setq end i) - (aset chars i nil)) - (when start - (setq class (concat class (sregex--char-range start end))) - (setq start nil)))) - (if start - (setq class (concat class (sregex--char-range start end))))) - - (if (> (length class) 0) - (setq class (concat class (if caret "^") (if dash "-"))) - (setq class (concat class (if dash "-") (if caret "^")))) - (if (and (not complement) (= (length class) 1)) - (regexp-quote class) - (concat "[" (if complement "^") class "]"))))) - -(provide 'sregex) - -;;; sregex.el ends here diff --git a/lisp/textmodes/rst.el b/lisp/textmodes/rst.el index 6a91cef1d94..964baed03c7 100644 --- a/lisp/textmodes/rst.el +++ b/lisp/textmodes/rst.el @@ -522,7 +522,7 @@ argument list for `rst-re'.") (defvar rst-re-alist) ; Forward declare to use it in `rst-re'. -;; FIXME: Use `sregex' or `rx' instead of re-inventing the wheel. +;; FIXME: Use `rx' instead of re-inventing the wheel. (rst-testcover-add-compose 'rst-re) (defun rst-re (&rest args) ;; testcover: ok.