;;; subr.el --- basic lisp subroutines for Emacs
-;; Copyright (C) 1985, 86, 92, 94, 95, 99, 2000, 2001, 2002
+;; Copyright (C) 1985, 86, 92, 94, 95, 99, 2000, 2001, 2002, 2003
;; Free Software Foundation, Inc.
;; Maintainer: FSF
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)))))
+ ;; We can't use `dolist' or `cadr' yet for bootstrapping reasons.
+ (let (d)
+ ;; Ignore the first element of `decl' (it's always `declare').
+ (while (setq decl (cdr decl))
+ (setq d (car decl))
+ (cond ((and (consp d) (eq (car d) 'indent))
+ (put macro 'lisp-indent-function (car (cdr d))))
+ ((and (consp d) (eq (car d) 'debug))
+ (put macro 'edebug-form-spec (car (cdr d))))
+ (t
+ (message "Unknown declaration %s" d))))))
(setq macro-declaration-function 'macro-declaration-function)
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)))
(defmacro when (cond &rest body)
"If COND yields non-nil, do BODY, else return nil."
+ (declare (indent 1) (debug t))
(list 'if cond (cons 'progn body)))
(defmacro unless (cond &rest body)
"If COND yields nil, do BODY, else return nil."
+ (declare (indent 1) (debug t))
(cons 'if (cons cond (cons nil body))))
(defmacro dolist (spec &rest body)
- "(dolist (VAR LIST [RESULT]) BODY...): loop over a list.
+ "Loop over a list.
Evaluate BODY with VAR bound to each car from LIST, in turn.
-Then evaluate RESULT to get return value, default nil."
+Then evaluate RESULT to get return value, default nil.
+
+\(dolist (VAR LIST [RESULT]) BODY...)"
+ (declare (indent 1) (debug ((symbolp form &optional form) body)))
(let ((temp (make-symbol "--dolist-temp--")))
- (list 'let (list (list temp (nth 1 spec)) (car spec))
- (list 'while temp
- (list 'setq (car spec) (list 'car temp))
- (cons 'progn
- (append body
- (list (list 'setq temp (list 'cdr temp))))))
- (if (cdr (cdr spec))
- (cons 'progn
- (cons (list 'setq (car spec) nil) (cdr (cdr spec))))))))
+ `(let ((,temp ,(nth 1 spec))
+ ,(car spec))
+ (while ,temp
+ (setq ,(car spec) (car ,temp))
+ (setq ,temp (cdr ,temp))
+ ,@body)
+ ,@(if (cdr (cdr spec))
+ `((setq ,(car spec) nil) ,@(cdr (cdr spec)))))))
(defmacro dotimes (spec &rest body)
- "(dotimes (VAR COUNT [RESULT]) BODY...): loop a certain number of times.
+ "Loop a certain number of times.
Evaluate BODY with VAR bound to successive integers running from 0,
inclusive, to COUNT, exclusive. Then evaluate RESULT to get
-the return value (nil if RESULT is omitted)."
- (let ((temp (make-symbol "--dotimes-temp--")))
- (list 'let (list (list temp (nth 1 spec)) (list (car spec) 0))
- (list 'while (list '< (car spec) temp)
- (cons 'progn
- (append body (list (list 'setq (car spec)
- (list '1+ (car spec)))))))
- (if (cdr (cdr spec))
- (car (cdr (cdr spec)))
- nil))))
+the return value (nil if RESULT is omitted).
+
+\(dotimes (VAR COUNT [RESULT]) BODY...)"
+ (declare (indent 1) (debug dolist))
+ (let ((temp (make-symbol "--dotimes-temp--"))
+ (start 0)
+ (end (nth 1 spec)))
+ `(let ((,temp ,end)
+ (,(car spec) ,start))
+ (while (< ,(car spec) ,temp)
+ ,@body
+ (setq ,(car spec) (1+ ,(car spec))))
+ ,@(cdr (cdr spec)))))
(defsubst caar (x)
"Return the car of the car of X."
(if (> n 0) (setcdr (nthcdr (- (1- m) n) x) nil))
x))))
+(defun number-sequence (from &optional to inc)
+ "Return a sequence of numbers from FROM to TO (both inclusive) as a list.
+INC is the increment used between numbers in the sequence.
+So, the Nth element of the list is (+ FROM (* N INC)) where N counts from
+zero.
+If INC is nil, it defaults to 1 (one).
+If TO is nil, it defaults to FROM.
+If TO is less than FROM, the value is nil.
+Note that FROM, TO and INC can be integer or float."
+ (if (not to)
+ (list from)
+ (or inc (setq inc 1))
+ (let (seq)
+ (while (<= from to)
+ (setq seq (cons from seq)
+ from (+ from inc)))
+ (nreverse seq))))
+
(defun remove (elt seq)
"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'."
(delete elt (copy-sequence seq))))
(defun remq (elt list)
- "Return a copy of LIST with all occurences of ELT removed.
-The comparison is done with `eq'."
+ "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."
(if (memq elt list)
(delq elt (copy-sequence list))
list))
(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))
;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.
(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.
(if (> c 127)
(logxor c listify-key-sequence-1)
c)))
- (append key nil))))
+ key)))
(defsubst eventp (obj)
"True if the argument is an event object."
as returned by the `event-start' and `event-end' functions.
For a scroll-bar event, the result column is 0, and the row
corresponds to the vertical position of the click in the scroll bar."
- (let ((pair (nth 2 position))
- (window (posn-window position)))
+ (let* ((pair (nth 2 position))
+ (window (posn-window position)))
(if (eq (if (consp (nth 1 position))
(car (nth 1 position))
(nth 1 position))
(cons (scroll-bar-scale pair (window-width window)) 0)
(let* ((frame (if (framep window) window (window-frame window)))
(x (/ (car pair) (frame-char-width frame)))
- (y (/ (cdr pair) (frame-char-height frame))))
+ (y (/ (cdr pair) (+ (frame-char-height frame)
+ (or (frame-parameter frame 'line-spacing)
+ default-line-spacing
+ 0)))))
(cons x y))))))
(defsubst posn-timestamp (position)
(defalias 'sref 'aref)
(make-obsolete 'sref 'aref "20.4")
-(make-obsolete 'char-bytes "now always returns 1 (maintained for backward compatibility)." "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")
(eq 'autoload (car-safe (symbol-function function))))
(nth 1 (symbol-function function))
(let ((files load-history)
- file functions)
+ file)
(while files
- (if (memq function (cdr (car files)))
+ (if (member function (cdr (car files)))
(setq file (car (car files)) files nil))
(setq files (cdr files)))
file)))
(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.
+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))
:group 'editing-basics)
-(defun read-key (&optional prompt)
- "Read a key from the keyboard.
-Contrary to `read-event' this will not return a raw event but will
-obey `function-key-map' and `key-translation-map' instead."
- (let ((overriding-terminal-local-map (make-sparse-keymap)))
- (aref (read-key-sequence prompt nil t) 0)))
-
(defun read-quoted-char (&optional prompt)
"Like `read-char', but do not allow quitting.
Also, if the first character read is an octal digit,
The optional argument PROMPT specifies a string to use to prompt the user.
The variable `read-quoted-char-radix' controls which radix to use
for numeric input."
- (let ((message-log-max nil) done (first t) (code 0) char)
+ (let ((message-log-max nil) done (first t) (code 0) char translated)
(while (not done)
(let ((inhibit-quit first)
;; Don't let C-h get the help message--only help function keys.
or the octal character code.
RET terminates the character code and is discarded;
any other non-digit terminates the character code and is then used as input."))
- (setq char (read-key (and prompt (format "%s-" prompt))))
+ (setq char (read-event (and prompt (format "%s-" prompt)) t))
(if inhibit-quit (setq quit-flag nil)))
- (cond ((null char))
- ((not (integerp char))
- (setq unread-command-events (listify-key-sequence (this-single-command-raw-keys))
+ ;; 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.
+ (setq translated char)
+ (let ((translation (lookup-key function-key-map (vector char))))
+ (if (arrayp translation)
+ (setq translated (aref translation 0))))
+ (cond ((null translated))
+ ((not (integerp translated))
+ (setq unread-command-events (list char)
done t))
- ((/= (logand char ?\M-\^@) 0)
+ ((/= (logand translated ?\M-\^@) 0)
;; Turn a meta-character into a character with the 0200 bit set.
- (setq code (logior (logand char (lognot ?\M-\^@)) 128)
+ (setq code (logior (logand translated (lognot ?\M-\^@)) 128)
done t))
- ((and (<= ?0 char) (< char (+ ?0 (min 10 read-quoted-char-radix))))
- (setq code (+ (* code read-quoted-char-radix) (- char ?0)))
- (and prompt (setq prompt (message "%s %c" prompt char))))
- ((and (<= ?a (downcase char))
- (< (downcase char) (+ ?a -10 (min 26 read-quoted-char-radix))))
+ ((and (<= ?0 translated) (< translated (+ ?0 (min 10 read-quoted-char-radix))))
+ (setq code (+ (* code read-quoted-char-radix) (- translated ?0)))
+ (and prompt (setq prompt (message "%s %c" prompt translated))))
+ ((and (<= ?a (downcase translated))
+ (< (downcase translated) (+ ?a -10 (min 36 read-quoted-char-radix))))
(setq code (+ (* code read-quoted-char-radix)
- (+ 10 (- (downcase char) ?a))))
- (and prompt (setq prompt (message "%s %c" prompt char))))
- ((and (not first) (eq char ?\C-m))
+ (+ 10 (- (downcase translated) ?a))))
+ (and prompt (setq prompt (message "%s %c" prompt translated))))
+ ((and (not first) (eq translated ?\C-m))
(setq done t))
((not first)
- (setq unread-command-events (listify-key-sequence (this-single-command-raw-keys))
+ (setq unread-command-events (list char)
done t))
- (t (setq code char
+ (t (setq code translated
done t)))
(setq first nil))
code))
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)))
+ (if buffer
+ (list (cons buffer (with-current-buffer buffer buffer-undo-list)))
+ (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)
(setq elt (cdr elt))
- (let ((old-car
+ (let ((old-car
(if (consp elt) (car elt)))
(old-cdr
(if (consp elt) (cdr elt))))
(while (< (point) end)
(let ((cat (get-text-property (point) 'category))
run-end)
- (when cat
- (setq run-end
- (next-single-property-change (point) 'category nil end))
- (remove-list-of-text-properties (point) run-end '(category))
- (add-text-properties (point) run-end (symbol-plist cat))
- (goto-char (or run-end end)))
(setq run-end
(next-single-property-change (point) 'category nil end))
- (goto-char (or run-end 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))))
-
-(defun insert-for-yank (&rest strings)
- "Insert STRINGS at point, stripping some text properties.
-Strip text properties from the inserted text
-according to `yank-excluded-properties'.
-Otherwise just like (insert STRINGS...)."
- (let ((opoint (point)))
- (apply 'insert strings)
- (remove-yank-excluded-properties opoint (point))))
+ (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.
"Execute the forms in BODY with BUFFER as the current buffer.
The value returned is the value of the last form in BODY.
See also `with-temp-buffer'."
- (cons 'save-current-buffer
- (cons (list 'set-buffer buffer)
- body)))
+ (declare (indent 1) (debug t))
+ `(save-current-buffer
+ (set-buffer ,buffer)
+ ,@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.
+See also `with-temp-buffer'."
+ (declare (indent 1) (debug t))
+ `(save-selected-window
+ (select-window ,window 'norecord)
+ ,@body))
(defmacro with-temp-file (file &rest body)
"Create a new buffer, evaluate BODY there, and write the buffer to FILE.
(defmacro with-temp-buffer (&rest body)
"Create a temporary buffer, and evaluate BODY there like `progn'.
See also `with-temp-file' and `with-output-to-string'."
+ (declare (indent 0) (debug t))
(let ((temp-buffer (make-symbol "temp-buffer")))
`(let ((,temp-buffer
(get-buffer-create (generate-new-buffer-name " *temp*"))))
(defmacro with-output-to-string (&rest body)
"Execute BODY, return the text it sent to `standard-output', as a string."
+ (declare (indent 0) (debug t))
`(let ((standard-output
(get-buffer-create (generate-new-buffer-name " *string-output*"))))
(let ((standard-output standard-output))
(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)
Do not alter `after-change-functions' or `before-change-functions'
in BODY."
+ (declare (indent 0) (debug t))
`(unwind-protect
(let ((combine-after-change-calls t))
. ,body)
parent))
(defmacro with-syntax-table (table &rest body)
- "Evaluate BODY with syntax table of current buffer set to a copy of TABLE.
+ "Evaluate BODY with syntax table of current buffer set to TABLE.
The syntax table of the current buffer is saved, BODY is evaluated, and the
saved table is restored, even in case of an abnormal exit.
Value is what BODY returns."
(,old-buffer (current-buffer)))
(unwind-protect
(progn
- (set-syntax-table (copy-syntax-table ,table))
+ (set-syntax-table ,table)
,@body)
(save-current-buffer
(set-buffer ,old-buffer)
;; 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.
+ (declare (indent 0) (debug t))
(list 'let
'((save-match-data-internal (match-data)))
(list 'unwind-protect
(buffer-substring-no-properties (match-beginning num)
(match-end num)))))
-(defun split-string (string &optional separators)
- "Splits STRING into substrings where there are matches for SEPARATORS.
-Each match for SEPARATORS is a splitting point.
-The substrings between the splitting points are made into a list
+(defconst split-string-default-separators "[ \f\t\n\r\v]+"
+ "The default value of separators for `split-string'.
+
+A regexp matching strings of whitespace. May be locale-dependent
+\(as yet unimplemented). Should not match non-breaking spaces.
+
+Warning: binding this to a different value and using it as default is
+likely to have undesired semantics.")
+
+;; The specification says that if both SEPARATORS and OMIT-NULLS are
+;; defaulted, OMIT-NULLS should be treated as t. Simplifying the logical
+;; expression leads to the equivalent implementation that if SEPARATORS
+;; is defaulted, OMIT-NULLS is treated as t.
+(defun split-string (string &optional separators omit-nulls)
+ "Splits STRING into substrings bounded by matches for SEPARATORS.
+
+The beginning and end of STRING, and each match for SEPARATORS, are
+splitting points. The substrings matching SEPARATORS are removed, and
+the substrings between the splitting points are collected as a list,
which is returned.
-If SEPARATORS is absent, it defaults to \"[ \\f\\t\\n\\r\\v]+\".
-If there is match for SEPARATORS at the beginning of STRING, we do not
-include a null substring for that. Likewise, if there is a match
-at the end of STRING, we don't include a null substring for that.
+If SEPARATORS is non-nil, it should be a regular expression matching text
+which separates, but is not part of, the substrings. If nil it defaults to
+`split-string-default-separators', normally \"[ \\f\\t\\n\\r\\v]+\", and
+OMIT-NULLS is forced to t.
+
+If OMIT-NULLs is t, zero-length substrings are omitted from the list \(so
+that for the default value of SEPARATORS leading and trailing whitespace
+are effectively trimmed). If nil, all zero-length substrings are retained,
+which correctly parses CSV format, for example.
+
+Note that the effect of `(split-string STRING)' is the same as
+`(split-string STRING split-string-default-separators t)'). In the rare
+case that you wish to retain zero-length substrings when splitting on
+whitespace, use `(split-string STRING split-string-default-separators)'.
Modifies the match data; use `save-match-data' if necessary."
- (let ((rexp (or separators "[ \f\t\n\r\v]+"))
+ (let ((keep-nulls (not (if separators omit-nulls t)))
+ (rexp (or separators split-string-default-separators))
(start 0)
notfirst
(list nil))
(= start (match-beginning 0))
(< start (length string)))
(1+ start) start))
- (< (match-beginning 0) (length string)))
+ (< start (length string)))
(setq notfirst t)
- (or (eq (match-beginning 0) 0)
- (and (eq (match-beginning 0) (match-end 0))
- (eq (match-beginning 0) start))
+ (if (or keep-nulls (< start (match-beginning 0)))
(setq list
(cons (substring string start (match-beginning 0))
list)))
(setq start (match-end 0)))
- (or (eq start (length string))
+ (if (or keep-nulls (< start (length string)))
(setq list
(cons (substring string start)
list)))
newstr))
(defun replace-regexp-in-string (regexp rep string &optional
- fixedcase literal subexp start)
+ fixedcase literal subexp start)
"Replace all matches for REGEXP with REP in STRING.
Return a new string containing the replacements.
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\"
"
rep
(funcall rep (match-string 0 str)))
fixedcase literal str subexp)
- (cons (substring string start mb) ; unmatched prefix
+ (cons (substring string start mb) ; unmatched prefix
matches)))
(setq start me))
;; Reconstruct a string from the pieces.
"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 assq-delete-all (key alist)
"Delete from ALIST all elements whose car is KEY.
-Return the modified alist."
+Return the modified alist.
+Elements of ALIST that are not conses are ignored."
(let ((tail alist))
(while tail
- (if (eq (car (car tail)) key)
+ (if (and (consp (car tail)) (eq (car (car tail)) key))
(setq alist (delq (car tail) alist)))
(setq tail (cdr tail)))
alist))
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 (file)
- (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))
+ (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
+;; If a minor mode is not defined with define-minor-mode,
+;; add it here explicitly.
+;; isearch-mode is deliberately excluded, since you should
+;; not call it yourself.
+(defvar minor-mode-list '(auto-save-mode auto-fill-mode abbrev-mode
+ overwrite-mode view-mode)
+ "List of all minor mode functions.")
+
(defun add-minor-mode (toggle name &optional keymap after toggle-fun)
"Register a new minor mode.
If TOGGLE has a non-nil `:included' property, an entry for the mode is
included in the mode-line minor mode menu.
If TOGGLE has a `:menu-tag', that is used for the menu item's label."
+ (unless (memq toggle minor-mode-list)
+ (push toggle minor-mode-list))
+
(unless toggle-fun (setq toggle-fun 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)
(concat
(or (get toggle :menu-tag)
(if (stringp name) name (symbol-name toggle)))
- (let ((mode-name (if (stringp name) name
- (if (symbolp name) (symbol-value name)))))
- (if mode-name
- (concat " (" mode-name ")"))))
+ (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.
+ ;; Add the map to the minor-mode-map-alist.
(when keymap
(let ((existing (assq toggle minor-mode-map-alist)))
(if existing
;; 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 'face 'underline)
(overlay-put ol2 'evaporate t)
(overlay-put ol2 'text-clones dups)))
-\f
+
(defun play-sound (sound)
"SOUND is a list of the form `(sound KEYWORD VALUE...)'.
The following keywords are recognized:
(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