;;; subr.el --- basic lisp subroutines for Emacs
-;; Copyright (C) 1985, 86, 92, 94, 95, 99, 2000, 2001
+;; Copyright (C) 1985, 86, 92, 94, 95, 99, 2000, 2001, 2002, 2003
;; 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
(defun custom-declare-variable-early (&rest arguments)
(setq custom-declare-variable-list
(cons arguments custom-declare-variable-list)))
+
+\f
+(defun macro-declaration-function (macro decl)
+ "Process a declaration found in a macro definition.
+This is set as the value of the variable `macro-declaration-function'.
+MACRO is the name of the macro being defined.
+DECL is a list `(declare ...)' containing the declarations.
+The return value of this function is not used."
+ (dolist (d (cdr decl))
+ (cond ((and (consp d) (eq (car d) 'indent))
+ (put macro 'lisp-indent-function (cadr d)))
+ ((and (consp d) (eq (car d) 'debug))
+ (put macro 'edebug-form-spec (cadr d)))
+ (t
+ (message "Unknown declaration %s" d)))))
+
+(setq macro-declaration-function 'macro-declaration-function)
+
\f
;;;; Lisp language features.
But documentation strings are usually not useful in nameless functions.
INTERACTIVE should be a call to the function `interactive', which see.
It may also be omitted.
-BODY should be a list of lisp expressions."
+BODY should be a list of Lisp expressions."
;; Note that this definition should not use backquotes; subr.el should not
;; depend on backquote.el.
(list 'function (cons 'lambda cdr)))
LISTNAME must be a symbol whose value is a list.
If the value is nil, `pop' returns nil but does not actually
change the list."
- (list 'prog1 (list 'car listname)
- (list 'setq listname (list 'cdr listname))))
+ (list 'car
+ (list 'prog1 listname
+ (list 'setq listname (list 'cdr listname)))))
(defmacro when (cond &rest body)
"If COND yields non-nil, do BODY, else return nil."
x))))
(defun remove (elt seq)
- "Return a copy of SEQ with all occurences of ELT removed.
+ "Return a copy of SEQ with all occurrences of ELT removed.
SEQ must be a list, vector, or string. The comparison is done with `equal'."
(if (nlistp seq)
;; If SEQ isn't a list, there's no need to copy SEQ because
(delete elt (copy-sequence seq))))
(defun remq (elt list)
- "Return a copy of LIST with all occurences of ELT removed.
+ "Return a copy of LIST with all occurrences of ELT removed.
The comparison is done with `eq'."
(if (memq elt list)
(delq elt (copy-sequence list))
list))
+(defun copy-tree (tree &optional vecp)
+ "Make a copy of TREE.
+If TREE is a cons cell, this recursively copies both its car and its cdr.
+Contrast to `copy-sequence', which copies only along the cdrs. With second
+argument VECP, this copies vectors as well as conses."
+ (if (consp tree)
+ (let (result)
+ (while (consp tree)
+ (let ((newcar (car tree)))
+ (if (or (consp (car tree)) (and vecp (vectorp (car tree))))
+ (setq newcar (copy-tree (car tree) vecp)))
+ (push newcar result))
+ (setq tree (cdr tree)))
+ (nconc (nreverse result) tree))
+ (if (and vecp (vectorp tree))
+ (let ((i (length (setq tree (copy-sequence tree)))))
+ (while (>= (setq i (1- i)) 0)
+ (aset tree i (copy-tree (aref tree i) vecp)))
+ tree)
+ tree)))
+
(defun assoc-default (key alist &optional test default)
"Find object KEY in a pseudo-alist ALIST.
ALIST is a list of conses or objects. Each element (or the element's car,
(defun assoc-ignore-representation (key alist)
"Like `assoc', but ignores differences in text representation.
-KEY must be a string.
+KEY must be a string.
Unibyte strings are converted to multibyte for comparison."
(let (element)
(while (and alist (not element))
(defun member-ignore-case (elt list)
"Like `member', but ignores differences in case and text representation.
ELT must be a string. Upper-case and lower-case letters are treated as equal.
-Unibyte strings are converted to multibyte for comparison."
- (while (and list (not (eq t (compare-strings elt 0 nil (car list) 0 nil t))))
+Unibyte strings are converted to multibyte for comparison.
+Non-strings in LIST are ignored."
+ (while (and list
+ (not (and (stringp (car list))
+ (eq t (compare-strings elt 0 nil (car list) 0 nil t)))))
(setq list (cdr list)))
list)
"Make MAP override all normally self-inserting keys to be undefined.
Normally, as an exception, digits and minus-sign are set to make prefix args,
but optional second arg NODIGITS non-nil treats them like other chars."
- (substitute-key-definition 'self-insert-command 'undefined map global-map)
+ (define-key map [remap self-insert-command] 'undefined)
(or nodigits
(let (loop)
(define-key map "-" 'negative-argument)
;Moved to keymap.c
;(defun copy-keymap (keymap)
-; "Return a copy of KEYMAP"
+; "Return a copy of KEYMAP"
; (while (not (keymapp keymap))
; (setq keymap (signal 'wrong-type-argument (list 'keymapp keymap))))
; (if (vectorp keymap)
;; Don't document PREFIX in the doc string because we don't want to
;; advertise it. It's meant for recursive calls only. Here's its
;; meaning
-
+
;; If optional argument PREFIX is specified, it should be a key
;; prefix, a string. Redefined bindings will then be bound to the
;; original key, with PREFIX added at the front.
(setq inserted t)))
(setq tail (cdr tail)))))
+
(defmacro kbd (keys)
"Convert KEYS to the internal Emacs key representation.
KEYS should be a string constant in the format used for
(aset keyboard-translate-table from to))
\f
-;;;; The global keymap tree.
+;;;; The global keymap tree.
;;; global-map, esc-map, and ctl-x-map have their values set up in
;;; keymap.c; we just give them docstrings here.
The normal global definition of the character C-x indirects to this keymap.")
(defvar ctl-x-4-map (make-sparse-keymap)
- "Keymap for subcommands of C-x 4")
+ "Keymap for subcommands of C-x 4.")
(defalias 'ctl-x-4-prefix ctl-x-4-map)
(define-key ctl-x-map "4" 'ctl-x-4-prefix)
The return value is of the form
(WINDOW BUFFER-POSITION (X . Y) TIMESTAMP)
The `posn-' functions access elements of such lists."
- (nth 1 event))
+ (if (consp event) (nth 1 event)
+ (list (selected-window) (point) '(0 . 0) 0)))
(defsubst event-end (event)
"Return the ending location of EVENT. EVENT should be a click or drag event.
The return value is of the form
(WINDOW BUFFER-POSITION (X . Y) TIMESTAMP)
The `posn-' functions access elements of such lists."
- (nth (if (consp (nth 2 event)) 2 1) event))
+ (if (consp event) (nth (if (consp (nth 2 event)) 2 1) event)
+ (list (selected-window) (point) '(0 . 0) 0)))
(defsubst event-click-count (event)
"Return the multi-click count of EVENT, a click or drag event.
The return value is a positive integer."
- (if (integerp (nth 2 event)) (nth 2 event) 1))
+ (if (and (consp event) (integerp (nth 2 event))) (nth 2 event) 1))
(defsubst posn-window (position)
"Return the window in POSITION.
(defalias 'sref 'aref)
(make-obsolete 'sref 'aref "20.4")
-(make-obsolete 'char-bytes "Now this function always returns 1" "20.4")
+(make-obsolete 'char-bytes "now always returns 1." "20.4")
+(make-obsolete 'chars-in-region "use (abs (- BEG END))." "20.3")
+(make-obsolete 'dot 'point "before 19.15")
+(make-obsolete 'dot-max 'point-max "before 19.15")
+(make-obsolete 'dot-min 'point-min "before 19.15")
+(make-obsolete 'dot-marker 'point-marker "before 19.15")
+(make-obsolete 'buffer-flush-undo 'buffer-disable-undo "before 19.15")
+(make-obsolete 'baud-rate "use the baud-rate variable instead." "before 19.15")
+(make-obsolete 'compiled-function-p 'byte-code-function-p "before 19.15")
+(make-obsolete 'define-function 'defalias "20.1")
+
+(defun insert-string (&rest args)
+ "Mocklisp-compatibility insert function.
+Like the function `insert' except that any argument that is a number
+is converted into a string by expressing it in decimal."
+ (dolist (el args)
+ (insert (if (integerp el) (number-to-string el) el))))
+(make-obsolete 'insert-string 'insert "21.4")
+(defun makehash (&optional test) (make-hash-table :test (or test 'eql)))
+(make-obsolete 'makehash 'make-hash-table "21.4")
;; Some programs still use this as a function.
(defun baud-rate ()
- "Obsolete function returning the value of the `baud-rate' variable.
-Please convert your programs to use the variable `baud-rate' directly."
+ "Return the value of the `baud-rate' variable."
baud-rate)
(defalias 'focus-frame 'ignore)
(defalias 'unfocus-frame 'ignore)
+
+\f
+;;;; Obsolescence declarations for variables.
+
+(make-obsolete-variable 'directory-sep-char "do not use it." "21.1")
+(make-obsolete-variable 'mode-line-inverse-video "use the appropriate faces instead." "21.1")
+(make-obsolete-variable 'unread-command-char
+ "use `unread-command-events' instead. That variable is a list of events to reread, so it now uses nil to mean `no event', instead of -1."
+ "before 19.15")
+(make-obsolete-variable 'executing-macro 'executing-kbd-macro "before 19.34")
+(make-obsolete-variable 'post-command-idle-hook
+ "use timers instead, with `run-with-idle-timer'." "before 19.34")
+(make-obsolete-variable 'post-command-idle-delay
+ "use timers instead, with `run-with-idle-timer'." "before 19.34")
+
\f
;;;; Alternate names for functions - these are not being phased out.
(defalias 'search-backward-regexp (symbol-function 're-search-backward))
(defalias 'int-to-string 'number-to-string)
(defalias 'store-match-data 'set-match-data)
+(defalias 'make-variable-frame-localizable 'make-variable-frame-local)
;; These are the XEmacs names:
(defalias 'point-at-eol 'line-end-position)
(defalias 'point-at-bol 'line-beginning-position)
(make-local-variable hook)
(set hook (list t)))
hook)
-(make-obsolete 'make-local-hook "Not necessary any more." "21.1")
+(make-obsolete 'make-local-hook "not necessary any more." "21.1")
(defun add-hook (hook function &optional append local)
"Add to the value of HOOK the function FUNCTION.
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.
+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.
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
;; (not (member (cons 'not function) hook-value)))
;; (push (cons 'not function) hook-value))
;; Set the actual variable
- (if local (set hook hook-value) (set-default hook hook-value))))
+ (if (not local)
+ (set-default hook hook-value)
+ (if (equal hook-value '(t))
+ (kill-local-variable hook)
+ (set hook hook-value)))))
(defun add-to-list (list-var element &optional append)
"Add to the value of LIST-VAR the element ELEMENT if it isn't there yet.
unless the optional argument APPEND is non-nil, in which case
ELEMENT is added at the end.
+The return value is the new value of LIST-VAR.
+
If you want to use `add-to-list' on a variable that is not defined
until a certain package is loaded, you should put the call to `add-to-list'
into a hook function that will be run only after loading the package.
\f
;;; Load history
-(defvar symbol-file-load-history-loaded nil
- "Non-nil means we have loaded the file `fns-VERSION.el' in `exec-directory'.
-That file records the part of `load-history' for preloaded files,
-which is cleared out before dumping to make Emacs smaller.")
-
-(defun load-symbol-file-load-history ()
- "Load the file `fns-VERSION.el' in `exec-directory' if not already done.
-That file records the part of `load-history' for preloaded files,
-which is cleared out before dumping to make Emacs smaller."
- (unless symbol-file-load-history-loaded
- (load (expand-file-name
- ;; fns-XX.YY.ZZ.el does not work on DOS filesystem.
- (if (eq system-type 'ms-dos)
- "fns.el"
- (format "fns-%s.el" emacs-version))
- exec-directory)
- ;; The file name fns-%s.el already has a .el extension.
- nil nil t)
- (setq symbol-file-load-history-loaded t)))
+;;; (defvar symbol-file-load-history-loaded nil
+;;; "Non-nil means we have loaded the file `fns-VERSION.el' in `exec-directory'.
+;;; That file records the part of `load-history' for preloaded files,
+;;; which is cleared out before dumping to make Emacs smaller.")
+
+;;; (defun load-symbol-file-load-history ()
+;;; "Load the file `fns-VERSION.el' in `exec-directory' if not already done.
+;;; That file records the part of `load-history' for preloaded files,
+;;; which is cleared out before dumping to make Emacs smaller."
+;;; (unless symbol-file-load-history-loaded
+;;; (load (expand-file-name
+;;; ;; fns-XX.YY.ZZ.el does not work on DOS filesystem.
+;;; (if (eq system-type 'ms-dos)
+;;; "fns.el"
+;;; (format "fns-%s.el" emacs-version))
+;;; exec-directory)
+;;; ;; The file name fns-%s.el already has a .el extension.
+;;; nil nil t)
+;;; (setq symbol-file-load-history-loaded t)))
(defun symbol-file (function)
"Return the input source from which FUNCTION was loaded.
either an absolute file name, or a library name
\(with no directory name and no `.el' or `.elc' at the end).
It can also be nil, if the definition is not associated with any file."
- (load-symbol-file-load-history)
- (let ((files load-history)
- file functions)
- (while files
- (if (memq function (cdr (car files)))
- (setq file (car (car files)) files nil))
- (setq files (cdr files)))
- file))
+ (if (and (symbolp function) (fboundp function)
+ (eq 'autoload (car-safe (symbol-function function))))
+ (nth 1 (symbol-function function))
+ (let ((files load-history)
+ file)
+ (while files
+ (if (member function (cdr (car files)))
+ (setq file (car (car files)) files nil))
+ (setq files (cdr files)))
+ file)))
\f
;;;; Specifying things to do after certain files are loaded.
(featurep file)
;; Make sure `load-history' contains the files dumped with
;; Emacs for the case that FILE is one of them.
- (load-symbol-file-load-history)
+ ;; (load-symbol-file-load-history)
(assoc file load-history))
(eval form))))
form)
This makes or adds to an entry on `after-load-alist'.
FILE should be the name of a library, with no directory name."
(eval-after-load file (read)))
+\f
+;;; make-network-process wrappers
+
+(if (featurep 'make-network-process)
+ (progn
+
+(defun open-network-stream (name buffer host service)
+ "Open a TCP connection for a service to a host.
+Returns a subprocess-object to represent the connection.
+Input and output work as for subprocesses; `delete-process' closes it.
+Args are NAME BUFFER HOST SERVICE.
+NAME is name for process. It is modified if necessary to make it unique.
+BUFFER is the buffer (or buffer-name) to associate with the process.
+ Process output goes at end of that buffer, unless you specify
+ an output stream or filter function to handle the output.
+ BUFFER may be also nil, meaning that this process is not associated
+ with any buffer
+Third arg is name of the host to connect to, or its IP address.
+Fourth arg SERVICE is name of the service desired, or an integer
+specifying a port number to connect to."
+ (make-network-process :name name :buffer buffer
+ :host host :service service))
+
+(defun open-network-stream-nowait (name buffer host service &optional sentinel filter)
+ "Initiate connection to a TCP connection for a service to a host.
+It returns nil if non-blocking connects are not supported; otherwise,
+it returns a subprocess-object to represent the connection.
+
+This function is similar to `open-network-stream', except that this
+function returns before the connection is established. When the
+connection is completed, the sentinel function will be called with
+second arg matching `open' (if successful) or `failed' (on error).
+
+Args are NAME BUFFER HOST SERVICE SENTINEL FILTER.
+NAME, BUFFER, HOST, and SERVICE are as for `open-network-stream'.
+Optional args, SENTINEL and FILTER specifies the sentinel and filter
+functions to be used for this network stream."
+ (if (featurep 'make-network-process '(:nowait t))
+ (make-network-process :name name :buffer buffer :nowait t
+ :host host :service service
+ :filter filter :sentinel sentinel)))
+
+(defun open-network-stream-server (name buffer service &optional sentinel filter)
+ "Create a network server process for a TCP service.
+It returns nil if server processes are not supported; otherwise,
+it returns a subprocess-object to represent the server.
+
+When a client connects to the specified service, a new subprocess
+is created to handle the new connection, and the sentinel function
+is called for the new process.
+
+Args are NAME BUFFER SERVICE SENTINEL FILTER.
+NAME is name for the server process. Client processes are named by
+appending the ip-address and port number of the client to NAME.
+BUFFER is the buffer (or buffer-name) to associate with the server
+process. Client processes will not get a buffer if a process filter
+is specified or BUFFER is nil; otherwise, a new buffer is created for
+the client process. The name is similar to the process name.
+Third arg SERVICE is name of the service desired, or an integer
+specifying a port number to connect to. It may also be t to selected
+an unused port number for the server.
+Optional args, SENTINEL and FILTER specifies the sentinel and filter
+functions to be used for the client processes; the server process
+does not use these function."
+ (if (featurep 'make-network-process '(:server t))
+ (make-network-process :name name :buffer buffer
+ :service service :server t :noquery t
+ :sentinel sentinel :filter filter)))
+
+)) ;; (featurep 'make-network-process)
+
+
+;; compatibility
+
+(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.
+New code should not use this function; use `process-query-on-exit-flag'
+or `set-process-query-on-exit-flag' instead."
+ (let ((old (process-query-on-exit-flag process)))
+ (set-process-query-on-exit-flag process nil)
+ old))
+
+;; process plist management
+
+(defun process-get (process propname)
+ "Return the value of PROCESS' PROPNAME property.
+This is the last value stored with `(process-put PROCESS PROPNAME VALUE)'."
+ (plist-get (process-plist process) propname))
+
+(defun process-put (process propname value)
+ "Change PROCESS' PROPNAME property to VALUE.
+It can be retrieved with `(process-get PROCESS PROPNAME)'."
+ (set-process-plist process
+ (plist-put (process-plist process) propname value)))
\f
;;;; Input and display facilities.
Legitimate radix values are 8, 10 and 16.")
(custom-declare-variable-early
- 'read-quoted-char-radix 8
+ 'read-quoted-char-radix 8
"*Radix for \\[quoted-insert] and other uses of `read-quoted-char'.
Legitimate radix values are 8, 10 and 16."
:type '(choice (const 8) (const 10) (const 16))
(setq char (read-event (and prompt (format "%s-" prompt)) t))
(if inhibit-quit (setq quit-flag nil)))
;; Translate TAB key into control-I ASCII character, and so on.
+ ;; Note: `read-char' does it using the `ascii-character' property.
+ ;; We could try and use read-key-sequence instead, but then C-q ESC
+ ;; or C-q C-x might not return immediately since ESC or C-x might be
+ ;; bound to some prefix in function-key-map or key-translation-map.
(and char
(let ((translated (lookup-key function-key-map (vector char))))
(if (arrayp translated)
(setq char (aref translated 0)))))
(cond ((null char))
((not (integerp char))
- (setq unread-command-events (list char)
+ (setq unread-command-events (listify-key-sequence (this-single-command-raw-keys))
done t))
((/= (logand char ?\M-\^@) 0)
;; Turn a meta-character into a character with the 0200 bit set.
((and (not first) (eq char ?\C-m))
(setq done t))
((not first)
- (setq unread-command-events (list char)
+ (setq unread-command-events (listify-key-sequence (this-single-command-raw-keys))
done t))
(t (setq code char
done t)))
(message nil)
(or pass default ""))))
\f
+;;; Atomic change groups.
+
+(defmacro atomic-change-group (&rest body)
+ "Perform BODY as an atomic change group.
+This means that if BODY exits abnormally,
+all of its changes to the current buffer are undone.
+This works regardless of whether undo is enabled in the buffer.
+
+This mechanism is transparent to ordinary use of undo;
+if undo is enabled in the buffer and BODY succeeds, the
+user can undo the change normally."
+ (let ((handle (make-symbol "--change-group-handle--"))
+ (success (make-symbol "--change-group-success--")))
+ `(let ((,handle (prepare-change-group))
+ (,success nil))
+ (unwind-protect
+ (progn
+ ;; This is inside the unwind-protect because
+ ;; it enables undo if that was disabled; we need
+ ;; to make sure that it gets disabled again.
+ (activate-change-group ,handle)
+ ,@body
+ (setq ,success t))
+ ;; Either of these functions will disable undo
+ ;; if it was disabled before.
+ (if ,success
+ (accept-change-group ,handle)
+ (cancel-change-group ,handle))))))
+
+(defun prepare-change-group (&optional buffer)
+ "Return a handle for the current buffer's state, for a change group.
+If you specify BUFFER, make a handle for BUFFER's state instead.
+
+Pass the handle to `activate-change-group' afterward to initiate
+the actual changes of the change group.
+
+To finish the change group, call either `accept-change-group' or
+`cancel-change-group' passing the same handle as argument. Call
+`accept-change-group' to accept the changes in the group as final;
+call `cancel-change-group' to undo them all. You should use
+`unwind-protect' to make sure the group is always finished. The call
+to `activate-change-group' should be inside the `unwind-protect'.
+Once you finish the group, don't use the handle again--don't try to
+finish the same group twice. For a simple example of correct use, see
+the source code of `atomic-change-group'.
+
+The handle records only the specified buffer. To make a multibuffer
+change group, call this function once for each buffer you want to
+cover, then use `nconc' to combine the returned values, like this:
+
+ (nconc (prepare-change-group buffer-1)
+ (prepare-change-group buffer-2))
+
+You can then activate that multibuffer change group with a single
+call to `activate-change-group' and finish it with a single call
+to `accept-change-group' or `cancel-change-group'."
+
+ (list (cons (current-buffer) buffer-undo-list)))
+
+(defun activate-change-group (handle)
+ "Activate a change group made with `prepare-change-group' (which see)."
+ (dolist (elt handle)
+ (with-current-buffer (car elt)
+ (if (eq buffer-undo-list t)
+ (setq buffer-undo-list nil)))))
+
+(defun accept-change-group (handle)
+ "Finish a change group made with `prepare-change-group' (which see).
+This finishes the change group by accepting its changes as final."
+ (dolist (elt handle)
+ (with-current-buffer (car elt)
+ (if (eq elt t)
+ (setq buffer-undo-list t)))))
+
+(defun cancel-change-group (handle)
+ "Finish a change group made with `prepare-change-group' (which see).
+This finishes the change group by reverting all of its changes."
+ (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.
+ (while 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
+;; For compatibility.
+(defalias 'redraw-modeline 'force-mode-line-update)
+
(defun force-mode-line-update (&optional all)
- "Force the mode-line of the current buffer to be redisplayed.
-With optional non-nil ALL, force redisplay of all mode-lines."
+ "Force the mode line of the current buffer to be redisplayed.
+With optional non-nil ALL, force redisplay of all mode lines."
(if all (save-excursion (set-buffer (other-buffer))))
(set-buffer-modified-p (buffer-modified-p)))
(if (> (overlay-end o) end)
(move-overlay o end (overlay-end o))
(delete-overlay o)))))))
-
+\f
;;;; Miscellanea.
;; A number of major modes set this locally.
(defvar suspend-resume-hook nil
"Normal hook run by `suspend-emacs', after Emacs is continued.")
+(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.")
+
+(defvar temp-buffer-setup-hook nil
+ "Normal hook run by `with-output-to-temp-buffer' at the start.
+When the hook runs, the temporary buffer is current.
+This hook is normally set up with a function to put the buffer in Help
+mode.")
+
;; Avoid compiler warnings about this variable,
;; which has a special meaning on certain system types.
(defvar buffer-file-type nil
(defalias 'user-original-login-name 'user-login-name)
+(defvar yank-excluded-properties)
+
+(defun remove-yank-excluded-properties (start end)
+ "Remove `yank-excluded-properties' between START and END positions.
+Replaces `category' properties with their defined properties."
+ (let ((inhibit-read-only t))
+ ;; Replace any `category' property with the properties it stands for.
+ (unless (memq yank-excluded-properties '(t nil))
+ (save-excursion
+ (goto-char start)
+ (while (< (point) end)
+ (let ((cat (get-text-property (point) 'category))
+ run-end)
+ (setq run-end
+ (next-single-property-change (point) 'category nil end))
+ (when cat
+ (let (run-end2 original)
+ (remove-list-of-text-properties (point) run-end '(category))
+ (while (< (point) run-end)
+ (setq run-end2 (next-property-change (point) nil run-end))
+ (setq original (text-properties-at (point)))
+ (set-text-properties (point) run-end2 (symbol-plist cat))
+ (add-text-properties (point) run-end2 original)
+ (goto-char run-end2))))
+ (goto-char run-end)))))
+ (if (eq yank-excluded-properties t)
+ (set-text-properties start end nil)
+ (remove-list-of-text-properties start end yank-excluded-properties))))
+
+(defvar yank-undo-function)
+
+(defun insert-for-yank (string)
+ "Insert STRING at point, stripping some text properties.
+Strip text properties from the inserted text according to
+`yank-excluded-properties'. Otherwise just like (insert STRING).
+
+If STRING has a non-nil `yank-handler' property on the first character,
+the normal insert behaviour is modified in various ways. The value of
+the yank-handler property must be a list with one to five elements
+with the following format: (FUNCTION PARAM NOEXCLUDE UNDO).
+When FUNCTION is present and non-nil, it is called instead of `insert'
+ to insert the string. FUNCTION takes one argument--the object to insert.
+If PARAM is present and non-nil, it replaces STRING as the object
+ passed to FUNCTION (or `insert'); for example, if FUNCTION is
+ `yank-rectangle', PARAM may be a list of strings to insert as a
+ rectangle.
+If NOEXCLUDE is present and non-nil, the normal removal of the
+ yank-excluded-properties is not performed; instead FUNCTION is
+ responsible for removing those properties. This may be necessary
+ if FUNCTION adjusts point before or after inserting the object.
+If UNDO is present and non-nil, it is a function that will be called
+ by `yank-pop' to undo the insertion of the current object. It is
+ called with two arguments, the start and end of the current region.
+ FUNCTION may set `yank-undo-function' to override the UNDO value."
+ (let* ((handler (and (stringp string)
+ (get-text-property 0 'yank-handler string)))
+ (param (or (nth 1 handler) string))
+ (opoint (point)))
+ (setq yank-undo-function t)
+ (if (nth 0 handler) ;; FUNCTION
+ (funcall (car handler) param)
+ (insert param))
+ (unless (nth 2 handler) ;; NOEXCLUDE
+ (remove-yank-excluded-properties opoint (point)))
+ (if (eq yank-undo-function t) ;; not set by FUNCTION
+ (setq yank-undo-function (nth 3 handler))) ;; UNDO
+ (if (nth 4 handler) ;; COMMAND
+ (setq this-command (nth 4 handler)))))
+
+(defun insert-buffer-substring-no-properties (buf &optional start end)
+ "Insert before point a substring of buffer BUFFER, without text properties.
+BUFFER may be a buffer or a buffer name.
+Arguments START and END are character numbers specifying the substring.
+They default to the beginning and the end of BUFFER."
+ (let ((opoint (point)))
+ (insert-buffer-substring buf start end)
+ (let ((inhibit-read-only t))
+ (set-text-properties opoint (point) nil))))
+
+(defun insert-buffer-substring-as-yank (buf &optional start end)
+ "Insert before point a part of buffer BUFFER, stripping some text properties.
+BUFFER may be a buffer or a buffer name. Arguments START and END are
+character numbers specifying the substring. They default to the
+beginning and the end of BUFFER. Strip text properties from the
+inserted text according to `yank-excluded-properties'."
+ (let ((opoint (point)))
+ (insert-buffer-substring buf start end)
+ (remove-yank-excluded-properties opoint (point))))
+
+\f
+;; Synchronous shell commands.
+
(defun start-process-shell-command (name buffer &rest args)
"Start a program in a subprocess. Return the process object for it.
Args are NAME BUFFER COMMAND &rest COMMAND-ARGS.
(setq ,current-message (current-message))
(message "%s" ,temp-message))
,@body)
- (and ,temp-message ,current-message
- (message "%s" ,current-message))))))
+ (and ,temp-message
+ (if ,current-message
+ (message "%s" ,current-message)
+ (message nil)))))))
(defmacro with-temp-buffer (&rest body)
"Create a temporary buffer, and evaluate BODY there like `progn'.
(defmacro with-local-quit (&rest body)
"Execute BODY with `inhibit-quit' temporarily bound to nil."
+ (declare (debug t) (indent 0))
`(condition-case nil
(let ((inhibit-quit nil))
,@body)
(let ((delay-mode-hooks t))
,@body)))
+;; PUBLIC: find if the current mode derives from another.
+
+(defun derived-mode-p (&rest modes)
+ "Non-nil if the current major mode is derived from one of MODES.
+Uses the `derived-mode-parent' property of the symbol to trace backwards."
+ (let ((parent major-mode))
+ (while (and (not (memq parent modes))
+ (setq parent (get parent 'derived-mode-parent))))
+ parent))
+
(defmacro with-syntax-table (table &rest body)
"Evaluate BODY with syntax table of current buffer set to a copy of TABLE.
The syntax table of the current buffer is saved, BODY is evaluated, and the
(set-buffer ,old-buffer)
(set-syntax-table ,old-table))))))
\f
+;;; Matching and substitution
+
(defvar save-match-data-internal)
;; We use save-match-data-internal as the local variable because
;; We used to use an uninterned symbol; the compiler handles that properly
;; now, but it generates slower code.
(defmacro save-match-data (&rest body)
- "Execute the BODY forms, restoring the global value of the match data."
+ "Execute the BODY forms, restoring the global value of the match data.
+The value returned is the value of the last form in BODY."
;; It is better not to use backquote here,
;; because that makes a bootstrapping problem
;; if you need to recompile all the Lisp files using interpreted code.
To replace only the first match (if any), make REGEXP match up to \\'
and replace a sub-expression, e.g.
- (replace-regexp-in-string \"\\(foo\\).*\\'\" \"bar\" \" foo foo\" nil nil 1)
+ (replace-regexp-in-string \"\\\\(foo\\\\).*\\\\'\" \"bar\" \" foo foo\" nil nil 1)
=> \" bar foo\"
"
(set-char-table-parent table (or oldtable (standard-syntax-table)))
table))
+(defun syntax-after (pos)
+ "Return the syntax of the char after POS."
+ (unless (or (< pos (point-min)) (>= pos (point-max)))
+ (let ((st (if parse-sexp-lookup-properties
+ (get-char-property pos 'syntax-table))))
+ (if (consp st) st
+ (aref (or st (syntax-table)) (char-after pos))))))
+
(defun add-to-invisibility-spec (arg)
"Add elements to `buffer-invisibility-spec'.
See documentation for `buffer-invisibility-spec' for the kind of elements
that can be added."
- (cond
- ((or (null buffer-invisibility-spec) (eq buffer-invisibility-spec t))
- (setq buffer-invisibility-spec (list arg)))
- (t
- (setq buffer-invisibility-spec
- (cons arg buffer-invisibility-spec)))))
+ (if (eq buffer-invisibility-spec t)
+ (setq buffer-invisibility-spec (list t)))
+ (setq buffer-invisibility-spec
+ (cons arg buffer-invisibility-spec)))
(defun remove-from-invisibility-spec (arg)
"Remove elements from `buffer-invisibility-spec'."
(defun functionp (object)
"Non-nil iff OBJECT is a type of object that can be called as a function."
(or (and (symbolp object) (fboundp object)
- (setq object (indirect-function object))
+ (condition-case nil
+ (setq object (indirect-function object))
+ (error nil))
(eq (car-safe object) 'autoload)
(not (car-safe (cdr-safe (cdr-safe (cdr-safe (cdr-safe object)))))))
(subrp object) (byte-code-function-p object)
(setq tail (cdr tail)))
alist))
-(defun make-temp-file (prefix &optional dir-flag)
+(defun make-temp-file (prefix &optional dir-flag suffix)
"Create a temporary file.
The returned file name (created by appending some random characters at the end
-of PREFIX, and expanding against `temporary-file-directory' if necessary,
+of PREFIX, and expanding against `temporary-file-directory' if necessary),
is guaranteed to point to a newly created empty file.
You can then use `write-region' to write new data into the file.
-If DIR-FLAG is non-nil, create a new empty directory instead of a file."
- (let (file)
- (while (condition-case ()
- (progn
- (setq file
- (make-temp-name
- (expand-file-name prefix temporary-file-directory)))
- (if dir-flag
- (make-directory file)
- (write-region "" nil file nil 'silent nil 'excl))
- nil)
- (file-already-exists t))
- ;; the file was somehow created by someone else between
- ;; `make-temp-name' and `write-region', let's try again.
- nil)
- file))
+If DIR-FLAG is non-nil, create a new empty directory instead of a file.
+
+If SUFFIX is non-nil, add that at the end of the file name."
+ (let ((umask (default-file-modes))
+ file)
+ (unwind-protect
+ (progn
+ ;; Create temp files with strict access rights. It's easy to
+ ;; loosen them later, whereas it's impossible to close the
+ ;; time-window of loose permissions otherwise.
+ (set-default-file-modes ?\700)
+ (while (condition-case ()
+ (progn
+ (setq file
+ (make-temp-name
+ (expand-file-name prefix temporary-file-directory)))
+ (if suffix
+ (setq file (concat file suffix)))
+ (if dir-flag
+ (make-directory file)
+ (write-region "" nil file nil 'silent nil 'excl))
+ nil)
+ (file-already-exists t))
+ ;; the file was somehow created by someone else between
+ ;; `make-temp-name' and `write-region', let's try again.
+ nil)
+ file)
+ ;; Reset the umask.
+ (set-default-file-modes umask))))
\f
(defun add-minor-mode (toggle name &optional keymap after toggle-fun)
included in the mode-line minor mode menu.
If TOGGLE has a `:menu-tag', that is used for the menu item's label."
(unless toggle-fun (setq toggle-fun toggle))
- ;; Add the toggle to the minor-modes menu if requested.
- (when (get toggle :included)
- (define-key mode-line-mode-menu
- (vector toggle)
- (list 'menu-item
- (or (get toggle :menu-tag)
- (if (stringp name) name (symbol-name toggle)))
- toggle-fun
- :button (cons :toggle toggle))))
;; Add the name to the minor-mode-alist.
(when name
(let ((existing (assq toggle minor-mode-alist)))
- (when (and (stringp name) (not (get-text-property 0 'local-map name)))
- (setq name
- (propertize name
- 'local-map mode-line-minor-mode-keymap
- 'help-echo "mouse-3: minor mode menu")))
(if existing
(setcdr existing (list name))
(let ((tail minor-mode-alist) found)
(nconc found (list (list toggle name)) rest))
(setq minor-mode-alist (cons (list toggle name)
minor-mode-alist)))))))
- ;; Add the map to the minor-mode-map-alist.
+ ;; Add the toggle to the minor-modes menu if requested.
+ (when (get toggle :included)
+ (define-key mode-line-mode-menu
+ (vector toggle)
+ (list 'menu-item
+ (concat
+ (or (get toggle :menu-tag)
+ (if (stringp name) name (symbol-name toggle)))
+ (let ((mode-name (if (symbolp name) (symbol-value name))))
+ (if (and (stringp mode-name) (string-match "[^ ]+" mode-name))
+ (concat " (" (match-string 0 mode-name) ")"))))
+ toggle-fun
+ :button (cons :toggle toggle))))
+
+ ;; Add the map to the minor-mode-map-alist.
(when keymap
(let ((existing (assq toggle minor-mode-map-alist)))
(if existing
(nconc found (list (cons toggle keymap)) rest))
(setq minor-mode-map-alist (cons (cons toggle keymap)
minor-mode-map-alist))))))))
-
-;; XEmacs compatibility/convenience.
-(if (fboundp 'play-sound)
- (defun play-sound-file (file &optional volume device)
- "Play sound stored in FILE.
-VOLUME and DEVICE correspond to the keywords of the sound
-specification for `play-sound'."
- (interactive "fPlay sound file: ")
- (let ((sound (list :file file)))
- (if volume
- (plist-put sound :volume volume))
- (if device
- (plist-put sound :device device))
- (push 'sound sound)
- (play-sound sound))))
-
+\f
;; Clones ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun text-clone-maintain (ol1 after beg end &optional len)
;; where the clone is reduced to the empty string (we want the overlay to
;; stay when the clone's content is the empty string and we want to use
;; `evaporate' to make sure those overlays get deleted when needed).
- ;;
+ ;;
(let* ((pt-end (+ (point) (- end start)))
(start-margin (if (or (not spreadp) (bobp) (<= start (point-min)))
0 1))
;;(overlay-put ol1 'face 'underline)
(overlay-put ol1 'evaporate t)
(overlay-put ol1 'text-clones dups)
- ;;
+ ;;
(overlay-put ol2 'modification-hooks '(text-clone-maintain))
(when spreadp (overlay-put ol2 'text-clone-spreadp t))
(when syntax (overlay-put ol2 'text-clone-syntax syntax))
(overlay-put ol2 'evaporate t)
(overlay-put ol2 'text-clones dups)))
+(defun play-sound (sound)
+ "SOUND is a list of the form `(sound KEYWORD VALUE...)'.
+The following keywords are recognized:
+
+ :file FILE - read sound data from FILE. If FILE isn't an
+absolute file name, it is searched in `data-directory'.
+
+ :data DATA - read sound data from string DATA.
+
+Exactly one of :file or :data must be present.
+
+ :volume VOL - set volume to VOL. VOL must an integer in the
+range 0..100 or a float in the range 0..1.0. If not specified,
+don't change the volume setting of the sound device.
+
+ :device DEVICE - play sound on DEVICE. If not specified,
+a system-dependent default device name is used."
+ (unless (fboundp 'play-sound-internal)
+ (error "This Emacs binary lacks sound support"))
+ (play-sound-internal sound))
+
+(defun define-mail-user-agent (symbol composefunc sendfunc
+ &optional abortfunc hookvar)
+ "Define a symbol to identify a mail-sending package for `mail-user-agent'.
+
+SYMBOL can be any Lisp symbol. Its function definition and/or
+value as a variable do not matter for this usage; we use only certain
+properties on its property list, to encode the rest of the arguments.
+
+COMPOSEFUNC is program callable function that composes an outgoing
+mail message buffer. This function should set up the basics of the
+buffer without requiring user interaction. It should populate the
+standard mail headers, leaving the `to:' and `subject:' headers blank
+by default.
+
+COMPOSEFUNC should accept several optional arguments--the same
+arguments that `compose-mail' takes. See that function's documentation.
+
+SENDFUNC is the command a user would run to send the message.
+
+Optional ABORTFUNC is the command a user would run to abort the
+message. For mail packages that don't have a separate abort function,
+this can be `kill-buffer' (the equivalent of omitting this argument).
+
+Optional HOOKVAR is a hook variable that gets run before the message
+is actually sent. Callers that use the `mail-user-agent' may
+install a hook function temporarily on this hook variable.
+If HOOKVAR is nil, `mail-send-hook' is used.
+
+The properties used on SYMBOL are `composefunc', `sendfunc',
+`abortfunc', and `hookvar'."
+ (put symbol 'composefunc composefunc)
+ (put symbol 'sendfunc sendfunc)
+ (put symbol 'abortfunc (or abortfunc 'kill-buffer))
+ (put symbol 'hookvar (or hookvar 'mail-send-hook)))
+
;;; subr.el ends here
HCoop / bpt / emacs.git / blobdiff