X-Git-Url: https://code.delx.au/gnu-emacs/blobdiff_plain/51fa39614fdaacef2e26e6aba3d08189d4ec4ba8..e1d290e2118242327ddc892b3f7e61cd165bf10b:/lisp/subr.el diff --git a/lisp/subr.el b/lisp/subr.el index 51297611ed..b2842b2724 100644 --- a/lisp/subr.el +++ b/lisp/subr.el @@ -3,6 +3,9 @@ ;; Copyright (C) 1985, 86, 92, 94, 95, 99, 2000, 2001, 2002 ;; 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 @@ -86,8 +89,9 @@ LISTNAME must be a symbol." 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." @@ -182,12 +186,33 @@ 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. + "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, @@ -219,7 +244,7 @@ Unibyte strings are converted to multibyte for comparison." (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)) @@ -231,8 +256,11 @@ Unibyte strings are converted to multibyte for comparison." (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) @@ -251,7 +279,7 @@ Unibyte strings are converted to multibyte for comparison." "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) @@ -263,7 +291,7 @@ but optional second arg NODIGITS non-nil treats them like other chars." ;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) @@ -281,7 +309,7 @@ in KEYMAP as NEWDEF those keys which are defined as OLDDEF in OLDMAP." ;; 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. @@ -475,7 +503,7 @@ and then modifies one entry in it." (aset keyboard-translate-table from to)) -;;;; 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. @@ -580,7 +608,8 @@ If EVENT is a drag, this returns the drag's starting position. 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. @@ -588,12 +617,13 @@ If EVENT is a click event, this function is the same as `event-start'. 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. @@ -669,7 +699,16 @@ as returned by the `event-start' and `event-end' functions." (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. @@ -677,17 +716,32 @@ 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.3") +(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) + + +;;;; 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") + ;;;; Alternate names for functions - these are not being phased out. @@ -703,6 +757,7 @@ Please convert your programs to use the variable `baud-rate' directly." (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) @@ -742,7 +797,7 @@ Do not use `make-local-variable' to make a hook variable buffer-local." (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. @@ -808,7 +863,11 @@ This makes the hook buffer-local if needed." ;; (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. @@ -834,25 +893,25 @@ other hooks, such as major mode hooks, can do the job." ;;; 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. @@ -860,14 +919,16 @@ The value is normally a string that was passed to `load': 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))) ;;;; Specifying things to do after certain files are loaded. @@ -893,7 +954,7 @@ evaluated whenever that feature is `provide'd." (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) @@ -903,6 +964,102 @@ evaluated whenever that feature is `provide'd." 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))) + +;;; 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))) ;;;; Input and display facilities. @@ -912,7 +1069,7 @@ FILE should be the name of a library, with no directory name." 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)) @@ -942,13 +1099,17 @@ any other non-digit terminates the character code and is then used as input.")) (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. @@ -965,7 +1126,7 @@ any other non-digit terminates the character code and is then used as input.")) ((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))) @@ -1019,11 +1180,13 @@ Optional DEFAULT is a default password to use instead of empty input." (message nil) (or pass default "")))) +;;; 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 regadless of whether undo is enabled in the buffer. +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 @@ -1097,7 +1260,7 @@ 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 + (let ((old-car (if (consp elt) (car elt))) (old-cdr (if (consp elt) (cdr elt)))) @@ -1117,6 +1280,9 @@ This finishes the change group by reverting all of its changes." ;; Revert the undo info to what it was when we grabbed the state. (setq buffer-undo-list elt))))) +;; 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." @@ -1262,6 +1428,67 @@ for the sake of consistency." (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)))) + +(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)))) + +(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)))) + + +;; 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. @@ -1389,6 +1616,7 @@ See also `with-temp-file' and `with-output-to-string'." (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) @@ -1466,6 +1694,8 @@ Value is what BODY returns." (set-buffer ,old-buffer) (set-syntax-table ,old-table)))))) +;;; Matching and substitution + (defvar save-match-data-internal) ;; We use save-match-data-internal as the local variable because @@ -1574,7 +1804,7 @@ point are such that match 0 is the function's argument. 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\" " @@ -1652,16 +1882,22 @@ from `standard-syntax-table' otherwise." (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'." @@ -1728,7 +1964,9 @@ configuration." (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) @@ -1766,29 +2004,42 @@ Return the modified alist." (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)))) (defun add-minor-mode (toggle name &optional keymap after toggle-fun) @@ -1819,11 +2070,6 @@ If TOGGLE has a `:menu-tag', that is used for the menu item's label." ;; 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) @@ -1845,14 +2091,13 @@ If TOGGLE has a `:menu-tag', that is used for the menu item's label." (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 @@ -1868,7 +2113,7 @@ If TOGGLE has a `:menu-tag', that is used for the menu item's label." (nconc found (list (cons toggle keymap)) rest)) (setq minor-mode-map-alist (cons (cons toggle keymap) minor-mode-map-alist)))))))) - + ;; Clones ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun text-clone-maintain (ol1 after beg end &optional len) @@ -1939,7 +2184,7 @@ clone should be incorporated in the clone." ;; 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)) @@ -1956,7 +2201,7 @@ clone should be incorporated in the clone." ;;(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)) @@ -1964,4 +2209,60 @@ clone should be incorporated in the clone." (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