X-Git-Url: https://code.delx.au/gnu-emacs/blobdiff_plain/b9ab4064a8287bbb908f4864b8448ce4acd35be4..e1d290e2118242327ddc892b3f7e61cd165bf10b:/lisp/subr.el

diff --git a/lisp/subr.el b/lisp/subr.el
index 15d483c10b..b2842b2724 100644
--- a/lisp/subr.el
+++ b/lisp/subr.el
@@ -186,7 +186,7 @@ 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))
@@ -244,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))
@@ -279,7 +279,7 @@ Non-strings in LIST are ignored."
   "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)
@@ -291,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)
@@ -309,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.
@@ -503,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.
@@ -699,7 +699,7 @@ as returned by the `event-start' and `event-end' functions."
 
 (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")
@@ -757,6 +757,7 @@ is converted into a string by expressing it in decimal."
 (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)
@@ -892,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.
@@ -918,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.
@@ -951,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)
@@ -1038,13 +1041,26 @@ does not use these function."
 (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)))
+
 
 ;;;; Input and display facilities.
 
@@ -1053,19 +1069,12 @@ or `set-process-query-on-exit-flag' instead."
 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,
@@ -1087,11 +1096,20 @@ for numeric input."
 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)))
+      ;; 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 (this-single-command-raw-keys)
+	     (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.
@@ -1108,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 (this-single-command-raw-keys)
+	     (setq unread-command-events (listify-key-sequence (this-single-command-raw-keys))
 		   done t))
 	    (t (setq code char
 		     done t)))
@@ -1242,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))))
@@ -1423,19 +1441,21 @@ Replaces `category' properties with their defined properties."
 	(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))))
+      (remove-list-of-text-properties start end yank-excluded-properties))))
 
 (defun insert-for-yank (&rest strings)
   "Insert STRINGS at point, stripping some text properties.
@@ -1596,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)
@@ -1783,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\"
 "
 
@@ -1861,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'."
@@ -1987,23 +2014,32 @@ 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.
 
 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))))
 
 
 (defun add-minor-mode (toggle name &optional keymap after toggle-fun)
@@ -2034,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)
@@ -2060,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
@@ -2154,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))
@@ -2171,14 +2201,14 @@ 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))
     ;;(overlay-put ol2 'face 'underline)
     (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:
@@ -2200,4 +2230,39 @@ a system-dependent default device name is used."
     (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