;;; subr.el --- basic lisp subroutines for Emacs
;; Copyright (C) 1985, 1986, 1992, 1994, 1995, 1999, 2000, 2001, 2002, 2003,
-;; 2004, 2005, 2006, 2007, 2008 Free Software Foundation, Inc.
+;; 2004, 2005, 2006, 2007, 2008, 2009 Free Software Foundation, Inc.
;; Maintainer: FSF
;; Keywords: internal
;; This file is part of GNU Emacs.
-;; GNU Emacs is free software; you can redistribute it and/or modify
+;; 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, or (at your option)
-;; any later version.
+;; 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
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
-;; along with GNU Emacs; see the file COPYING. If not, write to the
-;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
-;; Boston, MA 02110-1301, USA.
+;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
;;; Commentary:
;;; Code:
+
(defvar custom-declare-variable-list nil
"Record `defcustom' calls made before `custom.el' is loaded to handle them.
Each element of this list holds the arguments to one call to `defcustom'.")
\(declare-function c-end-of-defun \"progmodes/cc-cmds.el\"
\(&optional arg))
-For more information, see Info node `elisp(Declaring Functions)'."
+For more information, see Info node `(elisp)Declaring Functions'."
;; Does nothing - byte-compile-declare-function does the work.
nil)
+
\f
;;;; Basic Lisp macros.
Treated as a declaration when used at the right place in a
`defmacro' form. \(See Info anchor `(elisp)Definition of declare'.)"
nil)
+
+(defmacro ignore-errors (&rest body)
+ "Execute BODY; if an error occurs, return nil.
+Otherwise, return result of last form in BODY."
+ `(condition-case nil (progn ,@body) (error nil)))
\f
;;;; Basic Lisp functions.
(defun keymap-canonicalize (map)
"Return an equivalent keymap, without inheritance."
(let ((bindings ())
- (ranges ()))
+ (ranges ())
+ (prompt (keymap-prompt map)))
(while (keymapp map)
(setq map (map-keymap-internal
(lambda (key item)
(push (cons key item) ranges)
(push (cons key item) bindings)))
map)))
- (setq map (funcall (if ranges 'make-keymap 'make-sparse-keymap)
- (keymap-prompt map)))
+ (setq map (funcall (if ranges 'make-keymap 'make-sparse-keymap) prompt))
(dolist (binding ranges)
;; Treat char-ranges specially.
(define-key map (vector (car binding)) (cdr binding)))
"Return non-nil if OBJECT is a mouse movement event."
(eq (car-safe object) 'mouse-movement))
+(defun mouse-event-p (object)
+ "Return non-nil if OBJECT is a mouse click event."
+ ;; is this really correct? maybe remove mouse-movement?
+ (memq (event-basic-type object) '(mouse-1 mouse-2 mouse-3 mouse-movement)))
+
(defsubst event-start (event)
"Return the starting position of EVENT.
If EVENT is a mouse or key press or a mouse click, this returns the location
and `event-end' functions."
(nth 2 position))
+(declare-function scroll-bar-scale "scroll-bar" (num-denom whole))
+
(defun posn-col-row (position)
"Return the nominal column and row in POSITION, measured in characters.
The column and row values are approximations calculated from the x
(make-obsolete 'focus-frame "it does nothing." "22.1")
(defalias 'unfocus-frame 'ignore "")
(make-obsolete 'unfocus-frame "it does nothing." "22.1")
-(make-obsolete 'make-variable-frame-local "use a frame-parameter instead." "22.2")
+(make-obsolete 'make-variable-frame-local
+ "explicitly check for a frame-parameter instead." "22.2")
\f
;;;; Obsolescence declarations for variables, and aliases.
(defalias 'search-backward-regexp (symbol-function 're-search-backward))
(defalias 'int-to-string 'number-to-string)
(defalias 'store-match-data 'set-match-data)
+(defalias 'chmod 'set-file-modes)
+(defalias 'mkdir 'make-directory)
;; These are the XEmacs names:
(defalias 'point-at-eol 'line-end-position)
(defalias 'point-at-bol 'line-beginning-position)
;; (setq symbol-file-load-history-loaded t)))
(defun symbol-file (symbol &optional type)
- "Return the input source in which SYMBOL was defined.
-The value is an absolute file name.
-It can also be nil, if the definition is not associated with any file.
-
-If TYPE is nil, then any kind of definition is acceptable.
-If TYPE is `defun' or `defvar', that specifies function
-definition only or variable definition only.
-`defface' specifies a face definition only."
+ "Return the name of the file that defined SYMBOL.
+The value is normally an absolute file name. It can also be nil,
+if the definition is not associated with any file. If SYMBOL
+specifies an autoloaded function, the value can be a relative
+file name without extension.
+
+If TYPE is nil, then any kind of definition is acceptable. If
+TYPE is `defun', `defvar', or `defface', that specifies function
+definition, variable definition, or face definition only."
(if (and (or (null type) (eq type 'defun))
(symbolp symbol) (fboundp symbol)
(eq 'autoload (car-safe (symbol-function symbol))))
If the optional third arg PATH is specified, that list of directories
is used instead of `load-path'.
-When called from a program, the file name is normaly returned as a
+When called from a program, the file name is normally returned as a
string. When run interactively, the argument INTERACTIVE-CALL is t,
and the file name is displayed in the echo area."
(interactive (list (completing-read "Locate library: "
;; bound to some prefix in function-key-map or key-translation-map.
(setq translated
(if (integerp char)
- (char-resolve-modifers char)
+ (char-resolve-modifiers char)
char))
(let ((translation (lookup-key local-function-key-map (vector char))))
(if (arrayp translation)
Optional DEFAULT is a default password to use instead of empty input.
This function echoes `.' for each character that the user types.
-The user ends with RET, LFD, or ESC. DEL or C-h rubs out. C-u kills line.
+
+The user ends with RET, LFD, or ESC. DEL or C-h rubs out.
+C-y yanks the current kill. C-u kills line.
C-g quits; if `inhibit-quit' was non-nil around this function,
then it returns nil if the user types C-g, but quit-flag remains set.
(c 0)
(echo-keystrokes 0)
(cursor-in-echo-area t)
- (message-log-max nil))
+ (message-log-max nil)
+ (stop-keys (list 'return ?\r ?\n ?\e))
+ (rubout-keys (list 'backspace ?\b ?\177)))
(add-text-properties 0 (length prompt)
minibuffer-prompt-properties prompt)
(while (progn (message "%s%s"
prompt
(make-string (length pass) ?.))
- (setq c (read-char-exclusive nil t))
- (and (/= c ?\r) (/= c ?\n) (/= c ?\e)))
+ ;; We used to use read-char-exclusive, but that
+ ;; gives funny behavior when the user presses,
+ ;; e.g., the arrow keys.
+ (setq c (read-event nil t))
+ (not (memq c stop-keys)))
(clear-this-command-keys)
- (if (= c ?\C-u)
- (progn
- (and (arrayp pass) (clear-string pass))
- (setq pass ""))
- (if (and (/= c ?\b) (/= c ?\177))
- (let* ((new-char (char-to-string c))
- (new-pass (concat pass new-char)))
- (and (arrayp pass) (clear-string pass))
- (clear-string new-char)
- (setq c ?\0)
- (setq pass new-pass))
- (if (> (length pass) 0)
- (let ((new-pass (substring pass 0 -1)))
- (and (arrayp pass) (clear-string pass))
- (setq pass new-pass))))))
+ (cond ((memq c rubout-keys) ; rubout
+ (when (> (length pass) 0)
+ (let ((new-pass (substring pass 0 -1)))
+ (and (arrayp pass) (clear-string pass))
+ (setq pass new-pass))))
+ ((not (numberp c)))
+ ((= c ?\C-u) ; kill line
+ (and (arrayp pass) (clear-string pass))
+ (setq pass ""))
+ ((= c ?\C-y) ; yank
+ (let* ((str (condition-case nil
+ (current-kill 0)
+ (error nil)))
+ new-pass)
+ (when str
+ (setq new-pass
+ (concat pass
+ (substring-no-properties str)))
+ (and (arrayp pass) (clear-string pass))
+ (setq c ?\0)
+ (setq pass new-pass))))
+ ((characterp c) ; insert char
+ (let* ((new-char (char-to-string c))
+ (new-pass (concat pass new-char)))
+ (and (arrayp pass) (clear-string pass))
+ (clear-string new-char)
+ (setq c ?\0)
+ (setq pass new-pass)))))
(message nil)
(or pass default "")))))
(dolist (elt handle)
(with-current-buffer (car elt)
(setq elt (cdr elt))
- (let ((old-car
- (if (consp elt) (car elt)))
- (old-cdr
- (if (consp elt) (cdr elt))))
- ;; Temporarily truncate the undo log at ELT.
- (when (consp elt)
- (setcar elt nil) (setcdr elt nil))
- (unless (eq last-command 'undo) (undo-start))
- ;; Make sure there's no confusion.
- (when (and (consp elt) (not (eq elt (last pending-undo-list))))
- (error "Undoing to some unrelated state"))
- ;; Undo it all.
- (save-excursion
- (while (listp pending-undo-list) (undo-more 1)))
- ;; Reset the modified cons cell ELT to its original content.
- (when (consp elt)
- (setcar elt old-car)
- (setcdr elt old-cdr))
- ;; Revert the undo info to what it was when we grabbed the state.
- (setq buffer-undo-list elt)))))
+ (save-restriction
+ ;; Widen buffer temporarily so if the buffer was narrowed within
+ ;; the body of `atomic-change-group' all changes can be undone.
+ (widen)
+ (let ((old-car
+ (if (consp elt) (car elt)))
+ (old-cdr
+ (if (consp elt) (cdr elt))))
+ ;; Temporarily truncate the undo log at ELT.
+ (when (consp elt)
+ (setcar elt nil) (setcdr elt nil))
+ (unless (eq last-command 'undo) (undo-start))
+ ;; Make sure there's no confusion.
+ (when (and (consp elt) (not (eq elt (last pending-undo-list))))
+ (error "Undoing to some unrelated state"))
+ ;; Undo it all.
+ (save-excursion
+ (while (listp pending-undo-list) (undo-more 1)))
+ ;; Reset the modified cons cell ELT to its original content.
+ (when (consp elt)
+ (setcar elt old-car)
+ (setcdr elt old-cdr))
+ ;; Revert the undo info to what it was when we grabbed the state.
+ (setq buffer-undo-list elt))))))
\f
;;;; Display-related functions.
Display MESSAGE (optional fourth arg) in the echo area.
If MESSAGE is nil, instructions to type EXIT-CHAR are displayed there."
(or exit-char (setq exit-char ?\s))
- (let ((inhibit-read-only t)
- ;; Don't modify the undo list at all.
- (buffer-undo-list t)
- (modified (buffer-modified-p))
- (name buffer-file-name)
- insert-end)
+ (let ((ol (make-overlay pos pos))
+ (message (copy-sequence string)))
(unwind-protect
- (progn
- (save-excursion
- (goto-char pos)
- ;; To avoid trouble with out-of-bounds position
- (setq pos (point))
- ;; defeat file locking... don't try this at home, kids!
- (setq buffer-file-name nil)
- (insert-before-markers string)
- (setq insert-end (point))
- ;; If the message end is off screen, recenter now.
- (if (< (window-end nil t) insert-end)
- (recenter (/ (window-height) 2)))
- ;; If that pushed message start off the screen,
- ;; scroll to start it at the top of the screen.
- (move-to-window-line 0)
- (if (> (point) pos)
- (progn
- (goto-char pos)
- (recenter 0))))
- (message (or message "Type %s to continue editing.")
- (single-key-description exit-char))
- (let (char)
- (if (integerp exit-char)
- (condition-case nil
- (progn
- (setq char (read-char))
- (or (eq char exit-char)
- (setq unread-command-events (list char))))
- (error
- ;; `exit-char' is a character, hence it differs
- ;; from char, which is an event.
- (setq unread-command-events (list char))))
- ;; `exit-char' can be an event, or an event description
- ;; list.
- (setq char (read-event))
- (or (eq char exit-char)
- (eq char (event-convert-list exit-char))
- (setq unread-command-events (list char))))))
- (if insert-end
- (save-excursion
- (delete-region pos insert-end)))
- (setq buffer-file-name name)
- (set-buffer-modified-p modified))))
+ (progn
+ (save-excursion
+ (overlay-put ol 'after-string message)
+ (goto-char pos)
+ ;; To avoid trouble with out-of-bounds position
+ (setq pos (point))
+ ;; If the message end is off screen, recenter now.
+ (if (<= (window-end nil t) pos)
+ (recenter (/ (window-height) 2))))
+ (message (or message "Type %s to continue editing.")
+ (single-key-description exit-char))
+ (let (char)
+ (if (integerp exit-char)
+ (condition-case nil
+ (progn
+ (setq char (read-char))
+ (or (eq char exit-char)
+ (setq unread-command-events (list char))))
+ (error
+ ;; `exit-char' is a character, hence it differs
+ ;; from char, which is an event.
+ (setq unread-command-events (list char))))
+ ;; `exit-char' can be an event, or an event description list.
+ (setq char (read-event))
+ (or (eq char exit-char)
+ (eq char (event-convert-list exit-char))
+ (setq unread-command-events (list char))))))
+ (delete-overlay ol))))
\f
;;;; Overlay operations
(defvar temp-buffer-show-hook nil
"Normal hook run by `with-output-to-temp-buffer' after displaying the buffer.
When the hook runs, the temporary buffer is current, and the window it
-was displayed in is selected. This hook is normally set up with a
-function to make the buffer read only, and find function names and
-variable names in it, provided the major mode is still Help mode.")
+was displayed in is selected.")
(defvar temp-buffer-setup-hook nil
"Normal hook run by `with-output-to-temp-buffer' at the start.
"~/.emacs.d/")
"Directory beneath which additional per-user Emacs-specific files are placed.
Various programs in Emacs store information in this directory.
-Note that this should end with a directory separator.")
+Note that this should end with a directory separator.
+See also `locate-user-emacs-file'.")
+
+(defun locate-user-emacs-file (new-name &optional old-name)
+ "Return an absolute per-user Emacs-specific file name.
+If OLD-NAME is non-nil and ~/OLD-NAME exists, return ~/OLD-NAME.
+Else return NEW-NAME in `user-emacs-directory', creating the
+directory if it does not exist."
+ (convert-standard-filename
+ (let* ((home (concat "~" (or init-file-user "")))
+ (at-home (and old-name (expand-file-name old-name home))))
+ (if (and at-home (file-readable-p at-home))
+ at-home
+ ;; Make sure `user-emacs-directory' exists,
+ ;; unless we're in batch mode or dumping Emacs
+ (or noninteractive
+ purify-flag
+ (file-accessible-directory-p (directory-file-name user-emacs-directory))
+ (make-directory user-emacs-directory))
+ (expand-file-name new-name user-emacs-directory)))))
\f
;;;; Misc. useful functions.
Wildcards and redirection are handled as usual in the shell.
\(fn NAME BUFFER COMMAND &rest COMMAND-ARGS)"
- (cond
- ((eq system-type 'vax-vms)
- (apply 'start-process name buffer args))
;; We used to use `exec' to replace the shell with the command,
;; but that failed to handle (...) and semicolon, etc.
- (t
- (start-process name buffer shell-file-name shell-command-switch
- (mapconcat 'identity args " ")))))
+ (start-process name buffer shell-file-name shell-command-switch
+ (mapconcat 'identity args " ")))
(defun start-file-process-shell-command (name buffer &rest args)
"Start a program in a subprocess. Return the process object for it.
Otherwise it waits for COMMAND to terminate and returns a numeric exit
status or a signal description string.
If you quit, the process is killed with SIGINT, or SIGKILL if you quit again."
- (cond
- ((eq system-type 'vax-vms)
- (apply 'call-process command infile buffer display args))
- ;; We used to use `exec' to replace the shell with the command,
- ;; but that failed to handle (...) and semicolon, etc.
- (t
- (call-process shell-file-name
- infile buffer display
- shell-command-switch
- (mapconcat 'identity (cons command args) " ")))))
+ ;; We used to use `exec' to replace the shell with the command,
+ ;; but that failed to handle (...) and semicolon, etc.
+ (call-process shell-file-name
+ infile buffer display
+ shell-command-switch
+ (mapconcat 'identity (cons command args) " ")))
(defun process-file-shell-command (command &optional infile buffer display
&rest args)
\f
;;;; Lisp macros to do various things temporarily.
-(defmacro with-current-buffer (buffer &rest body)
- "Execute the forms in BODY with BUFFER temporarily current.
-BUFFER can be a buffer or a buffer name.
-The value returned is the value of the last form in BODY.
-See also `with-temp-buffer'."
+(defmacro with-current-buffer (buffer-or-name &rest body)
+ "Execute the forms in BODY with BUFFER-OR-NAME temporarily current.
+BUFFER-OR-NAME must be a buffer or the name of an existing buffer.
+The value returned is the value of the last form in BODY. See
+also `with-temp-buffer'."
(declare (indent 1) (debug t))
`(save-current-buffer
- (set-buffer ,buffer)
+ (set-buffer ,buffer-or-name)
,@body))
(defmacro with-selected-window (window &rest body)
"Execute the forms in BODY with WINDOW as the selected window.
The value returned is the value of the last form in BODY.
-This macro saves and restores the current buffer, since otherwise
-its normal operation could potentially make a different
-buffer current. It does not alter the buffer list ordering.
-
-This macro saves and restores the selected window, as well as
-the selected window in each frame. If the previously selected
-window of some frame is no longer live at the end of BODY, that
-frame's selected window is left alone. If the selected window is
-no longer live, then whatever window is selected at the end of
-BODY remains selected.
-See also `with-temp-buffer'."
+This macro saves and restores the selected window, as well as the
+selected window of each frame. It does not change the order of
+recently selected windows. If the previously selected window of
+some frame is no longer live at the end of BODY, that frame's
+selected window is left alone. If the selected window is no
+longer live, then whatever window is selected at the end of BODY
+remains selected.
+
+This macro uses `save-current-buffer' to save and restore the
+current buffer, since otherwise its normal operation could
+potentially make a different buffer current. It does not alter
+the buffer list ordering."
(declare (indent 1) (debug t))
;; Most of this code is a copy of save-selected-window.
`(let ((save-selected-window-window (selected-window))
(dolist (elt save-selected-window-alist)
(and (frame-live-p (car elt))
(window-live-p (cadr elt))
- (set-frame-selected-window (car elt) (cadr elt))))
- (if (window-live-p save-selected-window-window)
- (select-window save-selected-window-window 'norecord))))))
+ (set-frame-selected-window (car elt) (cadr elt) 'norecord)))
+ (when (window-live-p save-selected-window-window)
+ (select-window save-selected-window-window 'norecord))))))
(defmacro with-selected-frame (frame &rest body)
"Execute the forms in BODY with FRAME as the selected frame.
The value returned is the value of the last form in BODY.
-See also `with-temp-buffer'."
+
+This macro neither changes the order of recently selected windows
+nor the buffer list."
(declare (indent 1) (debug t))
(let ((old-frame (make-symbol "old-frame"))
(old-buffer (make-symbol "old-buffer")))
`(let ((,old-frame (selected-frame))
(,old-buffer (current-buffer)))
(unwind-protect
- (progn (select-frame ,frame)
+ (progn (select-frame ,frame 'norecord)
,@body)
- (if (frame-live-p ,old-frame)
- (select-frame ,old-frame))
- (if (buffer-live-p ,old-buffer)
- (set-buffer ,old-buffer))))))
+ (when (frame-live-p ,old-frame)
+ (select-frame ,old-frame 'norecord))
+ (when (buffer-live-p ,old-buffer)
+ (set-buffer ,old-buffer))))))
(defmacro with-temp-file (file &rest body)
"Create a new buffer, evaluate BODY there, and write the buffer to FILE.
(with-current-buffer ,temp-buffer
,@body)
(with-current-buffer ,temp-buffer
- (widen)
- (write-region (point-min) (point-max) ,temp-file nil 0)))
+ (write-region nil nil ,temp-file nil 0)))
(and (buffer-name ,temp-buffer)
(kill-buffer ,temp-buffer))))))
(declare (indent 0) (debug t))
`(let ((standard-output
(get-buffer-create (generate-new-buffer-name " *string-output*"))))
- (let ((standard-output standard-output))
- ,@body)
- (with-current-buffer standard-output
- (prog1
- (buffer-string)
- (kill-buffer nil)))))
+ (unwind-protect
+ (progn
+ (let ((standard-output standard-output))
+ ,@body)
+ (with-current-buffer standard-output
+ (buffer-string)))
+ (kill-buffer standard-output))))
(defmacro with-local-quit (&rest body)
"Execute BODY, allowing quits to terminate BODY but not escape further.
"Run BODY and demote any errors to simple messages.
If `debug-on-error' is non-nil, run BODY without catching its errors.
This is to be used around code which is not expected to signal an error
-but which should be robust in the unexpected case that an error is signalled."
+but which should be robust in the unexpected case that an error is signaled."
(declare (debug t) (indent 0))
(let ((err (make-symbol "err")))
`(condition-case-no-debug ,err
starting position, to avoid checking matches that would start
before LIMIT.
-If GREEDY is non-nil, extend the match backwards as far as possible,
-stopping when a single additional previous character cannot be part
-of a match for REGEXP."
+If GREEDY is non-nil, extend the match backwards as far as
+possible, stopping when a single additional previous character
+cannot be part of a match for REGEXP. When the match is
+extended, its starting position is allowed to occur before
+LIMIT."
(let ((start (point))
(pos
(save-excursion
(split-string-and-unquote (combine-and-quote-strings strs)) == strs
The SEPARATOR regexp defaults to \"\\s-+\"."
(let ((sep (or separator "\\s-+"))
- (i (string-match "[\"]" string)))
+ (i (string-match "\"" string)))
(if (null i)
(split-string string sep t) ; no quoting: easy
(append (unless (eq i 0) (split-string (substring string 0 i) sep t))
\"1alpha\"."
(version-list-= (version-to-list v1) (version-to-list v2)))
-
-
;; arch-tag: f7e0e6e5-70aa-4897-ae72-7a3511ec40bc
;;; subr.el ends here