0 (instrument no arguments); t (instrument all arguments);
a symbol (naming a function with an Edebug specification); or a list.
The elements of the list describe the argument types; see
-\(info \"(elisp)Specification List\") for details."
+Info node `(elisp)Specification List' for details."
`(put (quote ,symbol) 'edebug-form-spec (quote ,spec)))
(defmacro lambda (&rest cdr)
(setq ,(car spec) (1+ ,(car spec))))
,@(cdr (cdr spec))))))
-(defmacro declare (&rest specs)
+(defmacro declare (&rest _specs)
"Do not evaluate any arguments and return nil.
Treated as a declaration when used at the right place in a
`defmacro' form. \(See Info anchor `(elisp)Definition of declare'.)"
\f
;;;; Basic Lisp functions.
-(defun ignore (&rest ignore)
+(defun ignore (&rest _ignore)
"Do nothing and return nil.
This function accepts any number of arguments, but ignores them."
(interactive)
"Return LIST with all occurrences of ELT removed.
The comparison is done with `eq'. Contrary to `delq', this does not use
side-effects, and the argument LIST is not modified."
+ (while (and (eq elt (car list)) (setq list (cdr list))))
(if (memq elt list)
(delq elt (copy-sequence list))
list))
(define-key map (char-to-string loop) 'digit-argument)
(setq loop (1+ loop))))))
+(defun make-composed-keymap (maps &optional parent)
+ "Construct a new keymap composed of MAPS and inheriting from PARENT.
+When looking up a key in the returned map, the key is looked in each
+keymap of MAPS in turn until a binding is found.
+If no binding is found in MAPS, the lookup continues in PARENT, if non-nil.
+As always with keymap inheritance, a nil binding in MAPS overrides
+any corresponding binding in PARENT, but it does not override corresponding
+bindings in other keymaps of MAPS.
+MAPS can be a list of keymaps or a single keymap.
+PARENT if non-nil should be a keymap."
+ `(keymap
+ ,@(if (keymapp maps) (list maps) maps)
+ ,@parent))
+
(defun define-key-after (keymap key definition &optional after)
"Add binding in KEYMAP for KEY => DEFINITION, right after AFTER's binding.
This is like `define-key' except that the binding for KEY is placed
(dolist (p list)
(funcall function (car p) (cdr p)))))
+(defun keymap--menu-item-binding (val)
+ "Return the binding part of a menu-item."
+ (cond
+ ((not (consp val)) val) ;Not a menu-item.
+ ((eq 'menu-item (car val))
+ (let* ((binding (nth 2 val))
+ (plist (nthcdr 3 val))
+ (filter (plist-get plist :filter)))
+ (if filter (funcall filter binding)
+ binding)))
+ ((and (consp (cdr val)) (stringp (cadr val)))
+ (cddr val))
+ ((stringp (car val))
+ (cdr val))
+ (t val))) ;Not a menu-item either.
+
+(defun keymap--menu-item-with-binding (item binding)
+ "Build a menu-item like ITEM but with its binding changed to BINDING."
+ (cond
+ ((eq 'menu-item (car item))
+ (setq item (copy-sequence item))
+ (let ((tail (nthcdr 2 item)))
+ (setcar tail binding)
+ ;; Remove any potential filter.
+ (if (plist-get (cdr tail) :filter)
+ (setcdr tail (plist-put (cdr tail) :filter nil))))
+ item)
+ ((and (consp (cdr item)) (stringp (cadr item)))
+ (cons (car item) (cons (cadr item) binding)))
+ (t (cons (car item) binding))))
+
+(defun keymap--merge-bindings (val1 val2)
+ "Merge bindings VAL1 and VAL2."
+ (let ((map1 (keymap--menu-item-binding val1))
+ (map2 (keymap--menu-item-binding val2)))
+ (if (not (and (keymapp map1) (keymapp map2)))
+ ;; There's nothing to merge: val1 takes precedence.
+ val1
+ (let ((map (list 'keymap map1 map2))
+ (item (if (keymapp val1) (if (keymapp val2) nil val2) val1)))
+ (keymap--menu-item-with-binding item map)))))
+
(defun keymap-canonicalize (map)
- "Return an equivalent keymap, without inheritance."
+ "Return a simpler equivalent keymap.
+This resolves inheritance and redefinitions. The returned keymap
+should behave identically to a copy of KEYMAP w.r.t `lookup-key'
+and use in active keymaps and menus.
+Subkeymaps may be modified but are not canonicalized."
+ ;; FIXME: Problem with the difference between a nil binding
+ ;; that hides a binding in an inherited map and a nil binding that's ignored
+ ;; to let some further binding visible. Currently a nil binding hides all.
+ ;; FIXME: we may want to carefully (re)order elements in case they're
+ ;; menu-entries.
(let ((bindings ())
(ranges ())
(prompt (keymap-prompt map)))
(while (keymapp map)
- (setq map (map-keymap-internal
+ (setq map (map-keymap ;; -internal
(lambda (key item)
(if (consp key)
;; Treat char-ranges specially.
(push (cons key item) ranges)
(push (cons key item) bindings)))
map)))
+ ;; Create the new map.
(setq map (funcall (if ranges 'make-keymap 'make-sparse-keymap) prompt))
(dolist (binding ranges)
- ;; Treat char-ranges specially.
+ ;; Treat char-ranges specially. FIXME: need to merge as well.
(define-key map (vector (car binding)) (cdr binding)))
+ ;; Process the bindings starting from the end.
(dolist (binding (prog1 bindings (setq bindings ())))
(let* ((key (car binding))
(item (cdr binding))
(oldbind (assq key bindings)))
- ;; Newer bindings override older.
- (if oldbind (setq bindings (delq oldbind bindings)))
- (when item ;nil bindings just hide older ones.
- (push binding bindings))))
+ (push (if (not oldbind)
+ ;; The normal case: no duplicate bindings.
+ binding
+ ;; This is the second binding for this key.
+ (setq bindings (delq oldbind bindings))
+ (cons key (keymap--merge-bindings (cdr binding)
+ (cdr oldbind))))
+ bindings)))
(nconc map bindings)))
(put 'keyboard-translate-table 'char-table-extra-slots 0)
FUNCTION is added at the end.
The optional fourth argument, LOCAL, if non-nil, says to modify
-the hook's buffer-local value rather than its default value.
-This makes the hook buffer-local if needed, and it makes t a member
-of the buffer-local value. That acts as a flag to run the hook
-functions in the default value as well as in the local value.
+the hook's buffer-local value rather than its global value.
+This makes the hook buffer-local, and it makes t a member of the
+buffer-local value. That acts as a flag to run the hook
+functions of the global value as well as in the local value.
HOOK should be a symbol, and FUNCTION may be any valid function. If
HOOK is void, it is first set to nil. If HOOK's value is a single
FILE should be the name of a library, with no directory name."
(eval-after-load file (read)))
(make-obsolete 'eval-next-after-load `eval-after-load "23.2")
+
+(defun display-delayed-warnings ()
+ "Display delayed warnings from `delayed-warnings-list'.
+This is the default value of `delayed-warnings-hook'."
+ (dolist (warning (nreverse delayed-warnings-list))
+ (apply 'display-warning warning))
+ (setq delayed-warnings-list nil))
+
+(defvar delayed-warnings-hook '(display-delayed-warnings)
+ "Normal hook run to process delayed warnings.
+Functions in this hook should access the `delayed-warnings-list'
+variable (which see) and remove from it the warnings they process.")
+
\f
;;;; Process stuff.
(forward-line 1))
(nreverse lines)))))
+(defun process-live-p (process)
+ "Returns non-nil if PROCESS is alive.
+A process is considered alive if its status is `run', `open',
+`listen', `connect' or `stop'."
+ (memq (process-status process)
+ '(run open listen connect stop)))
+
;; compatibility
(make-obsolete
'process-kill-without-query
"use `process-query-on-exit-flag' or `set-process-query-on-exit-flag'."
"22.1")
-(defun process-kill-without-query (process &optional flag)
+(defun process-kill-without-query (process &optional _flag)
"Say no query needed if PROCESS is running when Emacs is exited.
Optional second argument if non-nil says to require a query.
Value is t if a query was formerly required."
keyboard-quit events while waiting for a valid input."
(unless (consp chars)
(error "Called `read-char-choice' without valid char choices"))
- (let (char done)
+ (let (char done show-help (helpbuf " *Char Help*"))
(let ((cursor-in-echo-area t)
(executing-kbd-macro executing-kbd-macro))
- (while (not done)
- (unless (get-text-property 0 'face prompt)
- (setq prompt (propertize prompt 'face 'minibuffer-prompt)))
- (setq char (let ((inhibit-quit inhibit-keyboard-quit))
- (read-key prompt)))
- (cond
- ((not (numberp char)))
- ((memq char chars)
- (setq done t))
- ((and executing-kbd-macro (= char -1))
- ;; read-event returns -1 if we are in a kbd macro and
- ;; there are no more events in the macro. Attempt to
- ;; get an event interactively.
- (setq executing-kbd-macro nil)))))
+ (save-window-excursion ; in case we call help-form-show
+ (while (not done)
+ (unless (get-text-property 0 'face prompt)
+ (setq prompt (propertize prompt 'face 'minibuffer-prompt)))
+ (setq char (let ((inhibit-quit inhibit-keyboard-quit))
+ (read-key prompt)))
+ (and show-help (buffer-live-p helpbuf)
+ (kill-buffer helpbuf))
+ (cond
+ ((not (numberp char)))
+ ;; If caller has set help-form, that's enough.
+ ;; They don't explicitly have to add help-char to chars.
+ ((and help-form
+ (eq char help-char)
+ (setq show-help t)
+ (help-form-show)))
+ ((memq char chars)
+ (setq done t))
+ ((and executing-kbd-macro (= char -1))
+ ;; read-event returns -1 if we are in a kbd macro and
+ ;; there are no more events in the macro. Attempt to
+ ;; get an event interactively.
+ (setq executing-kbd-macro nil))
+ ((and (not inhibit-keyboard-quit) (eq char ?\C-g))
+ (keyboard-quit))))))
;; Display the question with the answer. But without cursor-in-echo-area.
(message "%s%s" prompt (char-to-string char))
char))
(defun shell-quote-argument (argument)
"Quote ARGUMENT for passing as argument to an inferior shell."
- (if (or (eq system-type 'ms-dos)
- (and (eq system-type 'windows-nt) (w32-shell-dos-semantics)))
- ;; Quote using double quotes, but escape any existing quotes in
- ;; the argument with backslashes.
- (let ((result "")
- (start 0)
- end)
- (if (or (null (string-match "[^\"]" argument))
- (< (match-end 0) (length argument)))
- (while (string-match "[\"]" argument start)
- (setq end (match-beginning 0)
- result (concat result (substring argument start end)
- "\\" (substring argument end (1+ end)))
- start (1+ end))))
- (concat "\"" result (substring argument start) "\""))
+ (cond
+ ((eq system-type 'ms-dos)
+ ;; Quote using double quotes, but escape any existing quotes in
+ ;; the argument with backslashes.
+ (let ((result "")
+ (start 0)
+ end)
+ (if (or (null (string-match "[^\"]" argument))
+ (< (match-end 0) (length argument)))
+ (while (string-match "[\"]" argument start)
+ (setq end (match-beginning 0)
+ result (concat result (substring argument start end)
+ "\\" (substring argument end (1+ end)))
+ start (1+ end))))
+ (concat "\"" result (substring argument start) "\"")))
+
+ ((and (eq system-type 'windows-nt) (w32-shell-dos-semantics))
+
+ ;; First, quote argument so that CommandLineToArgvW will
+ ;; understand it. See
+ ;; http://msdn.microsoft.com/en-us/library/17w5ykft%28v=vs.85%29.aspx
+ ;; After we perform that level of quoting, escape shell
+ ;; metacharacters so that cmd won't mangle our argument. If the
+ ;; argument contains no double quote characters, we can just
+ ;; surround it with double quotes. Otherwise, we need to prefix
+ ;; each shell metacharacter with a caret.
+
+ (setq argument
+ ;; escape backslashes at end of string
+ (replace-regexp-in-string
+ "\\(\\\\*\\)$"
+ "\\1\\1"
+ ;; escape backslashes and quotes in string body
+ (replace-regexp-in-string
+ "\\(\\\\*\\)\""
+ "\\1\\1\\\\\""
+ argument)))
+
+ (if (string-match "[%!\"]" argument)
+ (concat
+ "^\""
+ (replace-regexp-in-string
+ "\\([%!()\"<>&|^]\\)"
+ "^\\1"
+ argument)
+ "^\"")
+ (concat "\"" argument "\"")))
+
+ (t
(if (equal argument "")
"''"
;; Quote everything except POSIX filename characters.
;; This should be safe enough even for really weird shells.
- (replace-regexp-in-string "\n" "'\n'"
- (replace-regexp-in-string "[^-0-9a-zA-Z_./\n]" "\\\\\\&" argument)))))
+ (replace-regexp-in-string
+ "\n" "'\n'"
+ (replace-regexp-in-string "[^-0-9a-zA-Z_./\n]" "\\\\\\&" argument))))
+ ))
(defun string-or-null-p (object)
"Return t if OBJECT is a string or nil.
(get-char-property (1- (field-end pos)) 'field)
raw-field)))
+(defun sha1 (object &optional start end binary)
+ "Return the SHA1 (Secure Hash Algorithm) of an OBJECT.
+OBJECT is either a string or a buffer. Optional arguments START and
+END are character positions specifying which portion of OBJECT for
+computing the hash. If BINARY is non-nil, return a string in binary
+form."
+ (secure-hash 'sha1 object start end binary))
+
\f
;;;; Support for yanking and text properties.
buffer temporarily current, and the window that was used to display it
temporarily selected. But it doesn't run `temp-buffer-show-hook'
if it uses `temp-buffer-show-function'."
+ (declare (debug t))
(let ((old-dir (make-symbol "old-dir"))
(buf (make-symbol "buf")))
`(let* ((,old-dir default-directory)
"Execute BODY, pretending it does not modify the buffer.
If BODY performs real modifications to the buffer's text, other
than cosmetic ones, undo data may become corrupted.
-Typically used around modifications of text-properties which do not really
-affect the buffer's content."
+
+This macro will run BODY normally, but doesn't count its buffer
+modifications as being buffer modifications. This affects things
+like buffer-modified-p, checking whether the file is locked by
+someone else, running buffer modification hooks, and other things
+of that nature.
+
+Typically used around modifications of text-properties which do
+not really affect the buffer's content."
(declare (debug t) (indent 0))
(let ((modified (make-symbol "modified")))
`(let* ((,modified (buffer-modified-p))
to case differences."
(eq t (compare-strings str1 nil nil
str2 0 (length str1) ignore-case)))
+
+(defun string-mark-left-to-right (str)
+ "Return a string that can be safely inserted in left-to-right text.
+If STR contains right-to-left (RTL) script, return a string
+consisting of STR followed by a terminating invisible
+left-to-right mark (LRM) character.
+
+The LRM character marks the end of an RTL segment, and resets the
+display direction of any subsequent text to left-to-right.
+\(Otherwise, some of that text might be displayed as part of the
+RTL segment, based on the bidirectional display algorithm.)
+
+If STR contains no RTL characters, return STR."
+ (unless (stringp str)
+ (signal 'wrong-type-argument (list 'stringp str)))
+ (let ((len (length str))
+ (n 0)
+ rtl-found)
+ (while (and (not rtl-found) (< n len))
+ (setq rtl-found (memq (get-char-code-property
+ (aref str n) 'bidi-class) '(R AL RLO))
+ n (1+ n)))
+ (if rtl-found
+ (concat str (propertize (string ?\x200e) 'invisible t))
+ str)))
\f
;;;; invisibility specs
\f
;;;; Text clones
-(defun text-clone-maintain (ol1 after beg end &optional len)
+(defun text-clone-maintain (ol1 after beg end &optional _len)
"Propagate the changes made under the overlay OL1 to the other clones.
This is used on the `modification-hooks' property of text clones."
(when (and after (not undo-in-progress) (overlay-start ol1))
`float-time' is not present, time is not tracked at all. If the
OS is not capable of measuring fractions of seconds, this
parameter is effectively rounded up."
+ (when (string-match "[[:alnum:]]\\'" message)
+ (setq message (concat message "...")))
(unless min-time
(setq min-time 0.2))
(let ((reporter
Note that version string \"1\" is equal to \"1.0\", \"1.0.0\", \"1.0.0.0\",
etc. That is, the trailing \".0\"s are insignificant. Also, version
string \"1\" is higher (newer) than \"1pre\", which is higher than \"1beta\",
-which is higher than \"1alpha\"."
+which is higher than \"1alpha\". Also, \"-CVS\" and \"-NNN\" are treated
+as alpha versions."
(version-list-< (version-to-list v1) (version-to-list v2)))
Note that version string \"1\" is equal to \"1.0\", \"1.0.0\", \"1.0.0.0\",
etc. That is, the trailing \".0\"s are insignificant. Also, version
string \"1\" is higher (newer) than \"1pre\", which is higher than \"1beta\",
-which is higher than \"1alpha\"."
+which is higher than \"1alpha\". Also, \"-CVS\" and \"-NNN\" are treated
+as alpha versions."
(version-list-<= (version-to-list v1) (version-to-list v2)))
(defun version= (v1 v2)
Note that version string \"1\" is equal to \"1.0\", \"1.0.0\", \"1.0.0.0\",
etc. That is, the trailing \".0\"s are insignificant. Also, version
string \"1\" is higher (newer) than \"1pre\", which is higher than \"1beta\",
-which is higher than \"1alpha\"."
+which is higher than \"1alpha\". Also, \"-CVS\" and \"-NNN\" are treated
+as alpha versions."
(version-list-= (version-to-list v1) (version-to-list v2)))
\f