"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)
and `down'.
EVENT may be an event or an event type. If EVENT is a symbol
that has never been used in an event that has been read as input
-in the current Emacs session, then this function can return nil,
-even when EVENT actually has modifiers."
+in the current Emacs session, then this function may fail to include
+the `click' modifier."
(let ((type event))
(if (listp type)
(setq type (car type)))
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
(put 'eval-after-load 'lisp-indent-function 1)
(defun eval-after-load (file form)
- "Arrange that, if FILE is ever loaded, FORM will be run at that time.
+ "Arrange that if FILE is loaded, FORM will be run immediately afterwards.
If FILE is already loaded, evaluate FORM right now.
If a matching file is loaded again, FORM will be evaluated again.
(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
(or (not process)
(not (memq (process-status process) '(run stop open listen)))
(not (process-query-on-exit-flag process))
- (yes-or-no-p "Buffer has a running process; kill it? "))))
+ (yes-or-no-p
+ (format "Buffer %S has a running process; kill it? "
+ (buffer-name (current-buffer)))))))
(add-hook 'kill-buffer-query-functions 'process-kill-buffer-query-function)
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))
(listp last-nonmenu-event)
use-dialog-box)
(setq answer
- (x-popup-dialog t `(,prompt ("yes" . act) ("No" . skip))))
+ (x-popup-dialog t `(,prompt ("Yes" . act) ("No" . skip))))
(setq prompt (concat prompt
(if (eq ?\s (aref prompt (1- (length prompt))))
"" " ")
(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))
NUM specifies which parenthesized expression in the last regexp.
Value is nil if NUMth pair didn't match, or there were less than NUM pairs.
Zero means the entire text matched by the whole regexp or whole string.
-STRING should be given if the last search was by `string-match' on STRING."
+STRING should be given if the last search was by `string-match' on STRING.
+If STRING is nil, the current buffer should be the same buffer
+the search/match was performed in."
(if (match-beginning num)
(if string
(substring string (match-beginning num) (match-end num))
NUM specifies which parenthesized expression in the last regexp.
Value is nil if NUMth pair didn't match, or there were less than NUM pairs.
Zero means the entire text matched by the whole regexp or whole string.
-STRING should be given if the last search was by `string-match' on STRING."
+STRING should be given if the last search was by `string-match' on STRING.
+If STRING is nil, the current buffer should be the same buffer
+the search/match was performed in."
(if (match-beginning num)
(if string
(substring-no-properties string (match-beginning num)
to case differences."
(eq t (compare-strings str1 nil nil
str2 0 (length str1) ignore-case)))
+
+(defun bidi-string-mark-left-to-right (str)
+ "Return a string that can be safely inserted in left-to-right text.
+
+Normally, inserting a string with right-to-left (RTL) script into
+a buffer may cause some subsequent text to be displayed as part
+of the RTL segment (usually this affects punctuation characters).
+This function returns a string which displays as STR but forces
+subsequent text to be displayed as left-to-right.
+
+If STR contains any RTL character, this function returns a string
+consisting of STR followed by an invisible left-to-right mark
+\(LRM) character. Otherwise, it returns STR."
+ (unless (stringp str)
+ (signal 'wrong-type-argument (list 'stringp str)))
+ (if (string-match "\\cR" str)
+ (concat str (propertize (string ?\x200e) 'invisible t))
+ str))
\f
;;;; invisibility specs
`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