-;;; subr.el --- basic lisp subroutines for Emacs -*- coding: utf-8; lexical-binding:t -*-
+;;; subr.el --- basic lisp subroutines for Emacs -*- lexical-binding:t -*-
-;; Copyright (C) 1985-1986, 1992, 1994-1995, 1999-2015 Free Software
+;; Copyright (C) 1985-1986, 1992, 1994-1995, 1999-2016 Free Software
;; Foundation, Inc.
;; Maintainer: emacs-devel@gnu.org
letter but *do not* end with a period. Please follow this convention
for the sake of consistency."
(declare (advertised-calling-convention (string &rest args) "23.1"))
- (signal 'error (list (apply 'format args))))
+ (signal 'error (list (apply #'format-message args))))
(defun user-error (format &rest args)
"Signal a pilot error, making error message by passing all args to `format'.
This is just like `error' except that `user-error's are expected to be the
result of an incorrect manipulation on the part of the user, rather than the
result of an actual problem."
- (signal 'user-error (list (apply #'format format args))))
+ (signal 'user-error (list (apply #'format-message format args))))
(defun define-error (name message &optional parent)
"Define NAME as a new error signal.
Store the result in LIST and return it. LIST must be a proper list.
Of several `equal' occurrences of an element in LIST, the first
one is kept."
- (if (> (length list) 100)
- (let ((hash (make-hash-table :test #'equal))
- res)
- (dolist (elt list)
- (unless (gethash elt hash)
- (puthash elt elt hash)
- (push elt res)))
- (setcdr list (cdr (nreverse res))))
- (let ((tail list))
- (while tail
- (setcdr tail (delete (car tail) (cdr tail)))
- (setq tail (cdr tail)))))
+ (let ((l (length list)))
+ (if (> l 100)
+ (let ((hash (make-hash-table :test #'equal :size l))
+ (tail list) retail)
+ (puthash (car list) t hash)
+ (while (setq retail (cdr tail))
+ (let ((elt (car retail)))
+ (if (gethash elt hash)
+ (setcdr tail (cdr retail))
+ (puthash elt t hash)
+ (setq tail retail)))))
+ (let ((tail list))
+ (while tail
+ (setcdr tail (delete (car tail) (cdr tail)))
+ (setq tail (cdr tail))))))
list)
;; See http://lists.gnu.org/archive/html/emacs-devel/2013-05/msg00204.html
First and last elements are considered consecutive if CIRCULAR is
non-nil."
(let ((tail list) last)
- (while (consp tail)
+ (while (cdr tail)
(if (equal (car tail) (cadr tail))
(setcdr tail (cddr tail))
- (setq last (car tail)
+ (setq last tail
tail (cdr tail))))
(if (and circular
- (cdr list)
- (equal last (car list)))
- (nbutlast list)
- list)))
+ last
+ (equal (car tail) (car list)))
+ (setcdr last nil)))
+ list)
(defun number-sequence (from &optional to inc)
"Return a sequence of numbers from FROM to TO (both inclusive) as a list.
"Return the window row number in POSITION and character number in that row.
Return nil if POSITION does not contain the actual position; in that case
-\`posn-col-row' can be used to get approximate values.
+`posn-col-row' can be used to get approximate values.
POSITION should be a list of the form returned by the `event-start'
and `event-end' functions.
This function does not account for the width on display, like the
number of visual columns taken by a TAB or image. If you need
the coordinates of POSITION in character units, you should use
-\`posn-col-row', not this function."
+`posn-col-row', not this function."
(nth 6 position))
(defsubst posn-timestamp (position)
(defalias 'send-region 'process-send-region)
(defalias 'string= 'string-equal)
(defalias 'string< 'string-lessp)
+(defalias 'string> 'string-greaterp)
(defalias 'move-marker 'set-marker)
(defalias 'rplaca 'setcar)
(defalias 'rplacd 'setcdr)
exp
(let* ((sym (cadr list-var))
(append (eval append))
- (msg (format "`add-to-list' can't use lexical var `%s'; use `push' or `cl-pushnew'"
- sym))
+ (msg (format-message
+ "`add-to-list' can't use lexical var `%s'; use `push' or `cl-pushnew'"
+ sym))
;; Big ugly hack so we only output a warning during
;; byte-compilation, and so we can use
;; byte-compile-not-lexical-var-p to silence the warning
(message "%s%s" prompt (char-to-string char))
char))
+(defun read-multiple-choice (prompt choices)
+ "Ask user a multiple choice question.
+PROMPT should be a string that will be displayed as the prompt.
+
+CHOICES is an alist where the first element in each entry is a
+character to be entered, the second element is a short name for
+the entry to be displayed while prompting (if there's room, it
+might be shortened), and the third, optional entry is a longer
+explanation that will be displayed in a help buffer if the user
+requests more help.
+
+The return value is the matching entry from the CHOICES list.
+
+Usage example:
+
+\(read-multiple-choice \"Continue connecting?\"
+ '((?a \"always\")
+ (?s \"session only\")
+ (?n \"no\")))"
+ (let* ((altered-names nil)
+ (full-prompt
+ (format
+ "%s (%s): "
+ prompt
+ (mapconcat
+ (lambda (elem)
+ (let* ((name (cadr elem))
+ (pos (seq-position name (car elem)))
+ (altered-name
+ (cond
+ ;; Not in the name string.
+ ((not pos)
+ (format "[%c] %s" (car elem) name))
+ ;; The prompt character is in the name, so highlight
+ ;; it on graphical terminals...
+ ((display-supports-face-attributes-p
+ '(:underline t) (window-frame))
+ (setq name (copy-sequence name))
+ (put-text-property pos (1+ pos)
+ 'face 'read-multiple-choice-face
+ name)
+ name)
+ ;; And put it in [bracket] on non-graphical terminals.
+ (t
+ (concat
+ (substring name 0 pos)
+ "["
+ (upcase (substring name pos (1+ pos)))
+ "]"
+ (substring name (1+ pos)))))))
+ (push (cons (car elem) altered-name)
+ altered-names)
+ altered-name))
+ (append choices '((?? "?")))
+ ", ")))
+ tchar buf wrong-char)
+ (save-window-excursion
+ (save-excursion
+ (while (not tchar)
+ (message "%s%s"
+ (if wrong-char
+ "Invalid choice. "
+ "")
+ full-prompt)
+ (setq tchar
+ (if (and (display-popup-menus-p)
+ last-input-event ; not during startup
+ (listp last-nonmenu-event)
+ use-dialog-box)
+ (x-popup-dialog
+ t
+ (cons prompt
+ (mapcar
+ (lambda (elem)
+ (cons (capitalize (cadr elem))
+ (car elem)))
+ choices)))
+ (condition-case nil
+ (let ((cursor-in-echo-area t))
+ (read-char))
+ (error nil))))
+ ;; The user has entered an invalid choice, so display the
+ ;; help messages.
+ (when (not (assq tchar choices))
+ (setq wrong-char (not (memq tchar '(?? ?\C-h)))
+ tchar nil)
+ (when wrong-char
+ (ding))
+ (with-help-window (setq buf (get-buffer-create
+ "*Multiple Choice Help*"))
+ (with-current-buffer buf
+ (erase-buffer)
+ (pop-to-buffer buf)
+ (insert prompt "\n\n")
+ (let* ((columns (/ (window-width) 25))
+ (fill-column 21)
+ (times 0)
+ (start (point)))
+ (dolist (elem choices)
+ (goto-char start)
+ (unless (zerop times)
+ (if (zerop (mod times columns))
+ ;; Go to the next "line".
+ (goto-char (setq start (point-max)))
+ ;; Add padding.
+ (while (not (eobp))
+ (end-of-line)
+ (insert (make-string (max (- (* (mod times columns)
+ (+ fill-column 4))
+ (current-column))
+ 0)
+ ?\s))
+ (forward-line 1))))
+ (setq times (1+ times))
+ (let ((text
+ (with-temp-buffer
+ (insert (format
+ "%c: %s\n"
+ (car elem)
+ (cdr (assq (car elem) altered-names))))
+ (fill-region (point-min) (point-max))
+ (when (nth 2 elem)
+ (let ((start (point)))
+ (insert (nth 2 elem))
+ (unless (bolp)
+ (insert "\n"))
+ (fill-region start (point-max))))
+ (buffer-string))))
+ (goto-char start)
+ (dolist (line (split-string text "\n"))
+ (end-of-line)
+ (if (bolp)
+ (insert line "\n")
+ (insert line))
+ (forward-line 1)))))))))))
+ (when (buffer-live-p buf)
+ (kill-buffer buf))
+ (assq tchar choices)))
+
(defun sit-for (seconds &optional nodisp obsolete)
"Redisplay, then wait for SECONDS seconds. Stop when input is available.
SECONDS may be a floating-point value.
t)
((input-pending-p t)
nil)
- ((<= seconds 0)
+ ((or (<= seconds 0)
+ ;; We are going to call read-event below, which will record
+ ;; the the next key as part of the macro, even if that key
+ ;; invokes kmacro-end-macro, so if we are recording a macro,
+ ;; the macro will recursively call itself. In addition, when
+ ;; that key is removed from unread-command-events, it will be
+ ;; recorded the second time, so the macro will have each key
+ ;; doubled. This used to happen if a macro was defined with
+ ;; Flyspell mode active (because Flyspell calls sit-for in its
+ ;; post-command-hook, see bug #21329.) To avoid all that, we
+ ;; simply disable the wait when we are recording a macro.
+ defining-kbd-macro)
(or nodisp (redisplay)))
(t
(or nodisp (redisplay))
(t (setq temp-prompt (concat "Please answer y or n. "
prompt))))))))
((and (display-popup-menus-p)
+ last-input-event ; not during startup
(listp last-nonmenu-event)
use-dialog-box)
(setq prompt (funcall padded prompt t)
(or (eq event exit-char)
(eq event (event-convert-list exit-char))
(setq unread-command-events
- (append (this-single-command-raw-keys))))))
+ (append (this-single-command-raw-keys)
+ unread-command-events)))))
(delete-overlay ol))))
\f
"Determine the boundaries of the default tag, based on text at point.
Return a cons cell with the beginning and end of the found tag.
If there is no plausible default, return nil."
- (let (from to bound)
- (when (or (progn
- ;; Look at text around `point'.
- (save-excursion
- (skip-syntax-backward "w_") (setq from (point)))
- (save-excursion
- (skip-syntax-forward "w_") (setq to (point)))
- (> to from))
- ;; Look between `line-beginning-position' and `point'.
- (save-excursion
- (and (setq bound (line-beginning-position))
- (skip-syntax-backward "^w_" bound)
- (> (setq to (point)) bound)
- (skip-syntax-backward "w_")
- (setq from (point))))
- ;; Look between `point' and `line-end-position'.
- (save-excursion
- (and (setq bound (line-end-position))
- (skip-syntax-forward "^w_" bound)
- (< (setq from (point)) bound)
- (skip-syntax-forward "w_")
- (setq to (point)))))
- (cons from to))))
+ (bounds-of-thing-at-point 'symbol))
(defun find-tag-default ()
"Determine default tag to search for, based on text at point.
(declare-function w32-shell-dos-semantics "w32-fns" nil)
(defun shell-quote-argument (argument)
- "Quote ARGUMENT for passing as argument to an inferior shell."
+ "Quote ARGUMENT for passing as argument to an inferior shell.
+
+This function is designed to work with the syntax of your system's
+standard shell, and might produce incorrect results with unusual shells.
+See Info node `(elisp)Security Considerations'."
(cond
((eq system-type 'ms-dos)
;; Quote using double quotes, but escape any existing quotes in
(if (string-match "\\cR" str)
(concat str (propertize (string ?\x200e) 'invisible t))
str))
+
+(defun string-greaterp (string1 string2)
+ "Return non-nil if STRING1 is greater than STRING2 in lexicographic order.
+Case is significant.
+Symbols are also allowed; their print names are used instead."
+ (string-lessp string2 string1))
+
\f
;;;; Specifying things to do later.
file, FORM is evaluated immediately after the provide statement.
Usually FILE is just a library name like \"font-lock\" or a feature name
-like 'font-lock.
+like `font-lock'.
This function makes or adds to an entry on `after-load-alist'."
(declare (compiler-macro
(defun remove-from-invisibility-spec (element)
"Remove ELEMENT from `buffer-invisibility-spec'."
- (if (consp buffer-invisibility-spec)
- (setq buffer-invisibility-spec
- (delete element buffer-invisibility-spec))))
+ (setq buffer-invisibility-spec
+ (if (consp buffer-invisibility-spec)
+ (delete element buffer-invisibility-spec)
+ (list t))))
\f
;;;; Syntax tables.
(defconst version-regexp-alist
- '(("^[-_+ ]?snapshot$" . -4)
+ '(("^[-._+ ]?snapshot$" . -4)
;; treat "1.2.3-20050920" and "1.2-3" as snapshot releases
- ("^[-_+]$" . -4)
+ ("^[-._+]$" . -4)
;; treat "1.2.3-CVS" as snapshot release
- ("^[-_+ ]?\\(cvs\\|git\\|bzr\\|svn\\|hg\\|darcs\\)$" . -4)
- ("^[-_+ ]?alpha$" . -3)
- ("^[-_+ ]?beta$" . -2)
- ("^[-_+ ]?\\(pre\\|rc\\)$" . -1))
+ ("^[-._+ ]?\\(cvs\\|git\\|bzr\\|svn\\|hg\\|darcs\\)$" . -4)
+ ("^[-._+ ]?alpha$" . -3)
+ ("^[-._+ ]?beta$" . -2)
+ ("^[-._+ ]?\\(pre\\|rc\\)$" . -1))
"Specify association between non-numeric version and its priority.
This association is used to handle version string like \"1.0pre2\",
String Version Integer List Version
\"0.9snapshot\" (0 9 -4)
\"1.0-git\" (1 0 -4)
+ \"1.0.cvs\" (1 0 -4)
\"1.0pre2\" (1 0 -1 2)
\"1.0PRE2\" (1 0 -1 2)
\"22.8beta3\" (22 8 -2 3)
Examples of valid version syntax:
- 1.0pre2 1.0.7.5 22.8beta3 0.9alpha1 6.9.30Beta
+ 1.0pre2 1.0.7.5 22.8beta3 0.9alpha1 6.9.30Beta 2.4.snapshot .5
Examples of invalid version syntax:
- 1.0prepre2 1.0..7.5 22.8X3 alpha3.2 .5
+ 1.0prepre2 1.0..7.5 22.8X3 alpha3.2
Examples of version conversion:
Version String Version as a List of Integers
- \"1.0.7.5\" (1 0 7 5)
- \"1.0pre2\" (1 0 -1 2)
- \"1.0PRE2\" (1 0 -1 2)
- \"22.8beta3\" (22 8 -2 3)
- \"22.8Beta3\" (22 8 -2 3)
- \"0.9alpha1\" (0 9 -3 1)
+ \".5\" (0 5)
+ \"0.9 alpha\" (0 9 -3)
\"0.9AlphA1\" (0 9 -3 1)
- \"0.9alpha\" (0 9 -3)
\"0.9snapshot\" (0 9 -4)
\"1.0-git\" (1 0 -4)
+ \"1.0.7.5\" (1 0 7 5)
+ \"1.0.cvs\" (1 0 -4)
+ \"1.0PRE2\" (1 0 -1 2)
+ \"1.0pre2\" (1 0 -1 2)
+ \"22.8 Beta3\" (22 8 -2 3)
+ \"22.8beta3\" (22 8 -2 3)
See documentation for `version-separator' and `version-regexp-alist'."
- (or (and (stringp ver) (> (length ver) 0))
- (error "Invalid version string: '%s'" ver))
+ (unless (stringp ver)
+ (error "Version must be a string"))
;; Change .x.y to 0.x.y
(if (and (>= (length ver) (length version-separator))
(string-equal (substring ver 0 (length version-separator))
version-separator))
(setq ver (concat "0" ver)))
+ (unless (string-match-p "^[0-9]" ver)
+ (error "Invalid version syntax: `%s' (must start with a number)" ver))
+
(save-match-data
(let ((i 0)
(case-fold-search t) ; ignore case in matching
lst s al)
+ ;; Parse the version-string up to a separator until there are none left
(while (and (setq s (string-match "[0-9]+" ver i))
(= s i))
- ;; handle numeric part
+ ;; Add the numeric part to the beginning of the version list;
+ ;; lst gets reversed at the end
(setq lst (cons (string-to-number (substring ver i (match-end 0)))
lst)
i (match-end 0))
(setq al (cdr al)))
(cond (al
(push (cdar al) lst))
- ;; Convert 22.3a to 22.3.1, 22.3b to 22.3.2, etc.
- ((string-match "^[-_+ ]?\\([a-zA-Z]\\)$" s)
+ ;; Convert 22.3a to 22.3.1, 22.3b to 22.3.2, etc., but only if
+ ;; the letter is the end of the version-string, to avoid
+ ;; 22.8X3 being valid
+ ((and (string-match "^[-._+ ]?\\([a-zA-Z]\\)$" s)
+ (= i (length ver)))
(push (- (aref (downcase (match-string 1 s)) 0) ?a -1)
lst))
- (t (error "Invalid version syntax: '%s'" ver))))))
- (if (null lst)
- (error "Invalid version syntax: '%s'" ver)
- (nreverse lst)))))
-
+ (t (error "Invalid version syntax: `%s'" ver))))))
+ (nreverse lst))))
(defun version-list-< (l1 l2)
"Return t if L1, a list specification of a version, is lower than L2.