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.
---
** '?\' 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.
+
\f
* Lisp Changes in Emacs 29.1
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.")
+++ /dev/null
-;;; 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 <https://www.gnu.org/licenses/>.
-
-;;; 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
+++ /dev/null
-;;; assoc.el --- insert/delete functions on association lists -*- lexical-binding: t -*-
-
-;; Copyright (C) 1996, 2001-2022 Free Software Foundation, Inc.
-
-;; Author: Barry A. Warsaw <bwarsaw@cen.com>
-;; 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 <https://www.gnu.org/licenses/>.
-
-;;; 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
+++ /dev/null
-;;; complete.el --- partial completion mechanism plus other goodies -*- lexical-binding: t; -*-
-
-;; Copyright (C) 1990-1993, 1999-2022 Free Software Foundation, Inc.
-
-;; Author: Dave Gillespie <daveg@synaptics.com>
-;; 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 <https://www.gnu.org/licenses/>.
-
-;;; 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 <sys/time.h> 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.")
-
-\f
-(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] <sys/time.h> 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))))
-
-\f
-(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)))
-\f
-
-(provide 'complete)
-
-;;; complete.el ends here
+++ /dev/null
-;;; cust-print.el --- handles print-level and print-circle -*- lexical-binding: t; -*-
-
-;; Copyright (C) 1992, 2001-2022 Free Software Foundation, Inc.
-
-;; Author: Daniel LaLiberte <liberte@holonexus.org>
-;; 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 <https://www.gnu.org/licenses/>.
-
-;;; 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.
-
-\f
-;;; 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.
-\f
-;; 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)
-
-\f
-;; 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)
- ))
- ;; )
- ))
-
-\f
-;; 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)
-
-\f
-;; 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))))
-
-
-\f
-;; 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)
-
-
-\f
-;; 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:
- ;; ( <object> <nil-t-or-id-number> )
- ;; 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))))))))))
-
-\f
-;; 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
+++ /dev/null
-;;; 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 <alex@gnu.org>
-;; 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 <https://www.gnu.org/licenses/>.
-
-;;; 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:
+++ /dev/null
-;;; 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 <delp@huey.Udel.Edu>
-;; 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
+++ /dev/null
-;;; mouse-sel.el --- multi-click selection support -*- lexical-binding: t; -*-
-
-;; Copyright (C) 1993-1995, 2001-2022 Free Software Foundation, Inc.
-
-;; Author: Mike Williams <mdub@bigfoot.com>
-;; 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 <https://www.gnu.org/licenses/>.
-
-;;; 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
+++ /dev/null
-;;; 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 <twurgler@goodyear.com>
-;; 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 <https://www.gnu.org/licenses/>.
-
-;;; 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
+++ /dev/null
-;;; 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
+++ /dev/null
-;;; 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 <michael@thp.Uni-Duisburg.DE>
-;; 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 <https://www.gnu.org/licenses/>.
-
-;;; 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 <pete.forman@airgun.wg.waii.com> 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 <prm@rz.uni-jena.de> for criticism.
-;; Kevin Cutts <cutts@ukraine.corp.mot.com> added the beginning-of-buffer
-;; and end-of-buffer functions which I modified a little.
-;; David Biesack <sasdjb@unx.sas.com> suggested some more cleanup.
-;; Thanks to Pete Forman <pete.forman@airgun.wg.waii.com>
-;; for additional motif keybindings.
-;; Thanks to jvromans@squirrel.nl (Johan Vromans) for a bug report
-;; concerning setting of this-command.
-;; Dan Nicolaescu <done@ece.arizona.ro> 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 <sds@gnu.org> 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
+++ /dev/null
-;;; s-region.el --- set region using shift key -*- lexical-binding: t; -*-
-
-;; Copyright (C) 1994-1995, 2001-2022 Free Software Foundation, Inc.
-
-;; Author: Morten Welinder <terra@diku.dk>
-;; 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 <https://www.gnu.org/licenses/>.
-
-;;; 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
+++ /dev/null
-;;; sregex.el --- symbolic regular expressions -*- lexical-binding: t; -*-
-
-;; Copyright (C) 1997-1998, 2000-2022 Free Software Foundation, Inc.
-
-;; Author: Bob Glickstein <bobg+sregex@zanshin.com>
-;; 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 <https://www.gnu.org/licenses/>.
-
-;;; 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
(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.
projects / emacs.git / commitdiff