X-Git-Url: https://code.delx.au/gnu-emacs/blobdiff_plain/813f532d2f0d18dcda7d93be2c6cd841815ff8b8..ff98122692e5f21e3dd91d2513c7b1897b6e7ac9:/lisp/mail/mail-hist.el diff --git a/lisp/mail/mail-hist.el b/lisp/mail/mail-hist.el index ffa3003a45..da27b726ef 100644 --- a/lisp/mail/mail-hist.el +++ b/lisp/mail/mail-hist.el @@ -1,10 +1,10 @@ -;;; mail-hist.el --- Headers and message body history for outgoing mail. +;;; mail-hist.el --- headers and message body history for outgoing mail + ;; Copyright (C) 1994 Free Software Foundation, Inc. -;; Author: Karl Fogel +;; Author: Karl Fogel ;; Created: March, 1994 -;; Version: 1.2.2 -;; Keywords: mail +;; Keywords: mail, history ;; This file is part of GNU Emacs. @@ -18,11 +18,12 @@ ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. -;;; Commentary: - ;; You should have received a copy of the GNU General Public License -;; along with GNU Emacs; see the file COPYING. If not, write to -;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. +;; along with GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Commentary: ;; Thanks to Jim Blandy for mentioning ring.el. It saved a lot of ;; time. @@ -54,6 +55,12 @@ ;;; Code: (require 'ring) +(require 'sendmail) + +(defgroup mail-hist nil + "Headers and message body history for outgoing mail." + :prefix "mail-hist-" + :group 'mail) ;;;###autoload (defun mail-hist-define-keys () @@ -62,26 +69,26 @@ (local-set-key "\M-n" 'mail-hist-next-input)) ;;;###autoload -(add-hook 'mail-mode-hook 'mail-hist-define-keys) - -;;;###autoload -(add-hook 'vm-mail-mode-hook 'mail-hist-define-keys) - -;;;###autoload -(add-hook 'mail-send-hook 'mail-hist-put-headers-into-history) +(defun mail-hist-enable () + (add-hook 'mail-mode-hook 'mail-hist-define-keys) + (add-hook 'mail-send-hook 'mail-hist-put-headers-into-history)) (defvar mail-hist-header-ring-alist nil "Alist of form (header-name . history-ring). Used for knowing which history list to look in when the user asks for previous/next input.") -(defvar mail-hist-history-size (or kill-ring-max 1729) +(defcustom mail-hist-history-size (or kill-ring-max 1729) "*The maximum number of elements in a mail field's history. -Oldest elements are dumped first.") +Oldest elements are dumped first." + :type 'integer + :group 'mail-hist) ;;;###autoload -(defvar mail-hist-keep-history t - "*Non-nil means keep a history for headers and text of outgoing mail.") +(defcustom mail-hist-keep-history t + "*Non-nil means keep a history for headers and text of outgoing mail." + :type 'boolean + :group 'mail-hist) ;; For handling repeated history requests (defvar mail-hist-access-count 0) @@ -98,13 +105,11 @@ Oldest elements are dumped first.") "Get name of mail header point is currently in, without the colon. Returns nil if not in a header, implying that point is in the body of the message." - (if (save-excursion - (re-search-backward (concat "^" mail-header-separator) nil t)) + (if (>= (point) (mail-text-start)) nil ; then we are in the body of the message (save-excursion - (let* ((body-start ; limit possibility of false headers - (save-excursion - (re-search-forward (concat "^" mail-header-separator) nil t))) + (let* ((body-start + (mail-text-start)) (name-start (re-search-backward mail-hist-header-regexp nil t)) (name-end @@ -112,20 +117,19 @@ the message." (and name-start name-end - (buffer-substring name-start name-end)))))) + (downcase (buffer-substring-no-properties name-start name-end))))))) (defsubst mail-hist-forward-header (count) "Move forward COUNT headers (backward if COUNT is negative). If last/first header is encountered first, stop there and returns -nil. +nil. Places point on the first non-whitespace on the line following the colon after the header name, or on the second space following that if the header is empty." - (let ((boundary (save-excursion - (re-search-forward (concat "^" mail-header-separator) nil t)))) + (let ((boundary (mail-header-end))) (and - boundary + (> boundary 0) (let ((unstopped t)) (setq boundary (save-excursion (goto-char boundary) @@ -168,20 +172,35 @@ colon, or just after the colon if it is not followed by whitespace." (mail-hist-beginning-of-header) (let ((start (point))) (or (mail-hist-forward-header 1) - (re-search-forward (concat "^" mail-header-separator))) + (goto-char (mail-header-end))) (beginning-of-line) (buffer-substring start (1- (point)))))) (defsubst mail-hist-get-header-ring (header) "Get HEADER's history ring, or nil if none. HEADER is a string without the colon." + (setq header (downcase header)) (cdr (assoc header mail-hist-header-ring-alist))) +(defcustom mail-hist-text-size-limit nil + "*Don't store any header or body with more than this many characters. +If the value is nil, that means no limit on text size." + :type '(choice (const nil) integer) + :group 'mail-hist) + +(defun mail-hist-text-too-long-p (text) + "Return non-nil if TEXT's length exceeds `mail-hist-text-size-limit'." + (if mail-hist-text-size-limit + (> (length text) mail-hist-text-size-limit))) + (defsubst mail-hist-add-header-contents-to-ring (header &optional contents) "Add the contents of HEADER to the header history ring. Optional argument CONTENTS is a string which will be the contents -(instead of whatever's found in the header)." - (let ((ring (cdr (assoc header mail-hist-header-ring-alist)))) +\(instead of whatever's found in the header)." + (setq header (downcase header)) + (let ((ctnts (or contents (mail-hist-current-header-contents))) + (ring (cdr (assoc header mail-hist-header-ring-alist)))) + (if (mail-hist-text-too-long-p ctnts) (setq ctnts "")) (or ring ;; If the ring doesn't exist, we'll have to make it and add it ;; to the mail-header-ring-alist: @@ -189,60 +208,73 @@ Optional argument CONTENTS is a string which will be the contents (setq ring (make-ring mail-hist-history-size)) (setq mail-hist-header-ring-alist (cons (cons header ring) mail-hist-header-ring-alist)))) - (ring-insert - ring - (or contents (mail-hist-current-header-contents))))) + (ring-insert ring ctnts))) ;;;###autoload (defun mail-hist-put-headers-into-history () - "Put headers and contents of this message into mail header history. + "Put headers and contents of this message into mail header history. Each header has its own independent history, as does the body of the message. -This function normally would be called when the message is sent." +This function normally would be called when the message is sent." (and mail-hist-keep-history - (progn + (save-excursion (goto-char (point-min)) (while (mail-hist-forward-header 1) (mail-hist-add-header-contents-to-ring (mail-hist-current-header-name))) (let ((body-contents - (save-excursion - (goto-char (point-min)) - (re-search-forward (concat "^" mail-header-separator) nil) - (forward-line 1) - (buffer-substring (point) (point-max))))) + (buffer-substring (mail-text-start) (point-max)))) (mail-hist-add-header-contents-to-ring "body" body-contents))))) - -(defun mail-hist-previous-input (header) - "Insert the previous contents of this mail header or message body. -Moves back through the history of sent mail messages. Each header has -its own independent history, as does the body of the message. -The history only contains the contents of outgoing messages, not -received mail." - (interactive (list (or (mail-hist-current-header-name) "body"))) + + +(defun mail-hist-retrieve-and-insert (header access-func) + "Helper for `mail-hist-previous-input' and `mail-hist-next-input'." + (setq header (downcase header)) (let* ((ring (cdr (assoc header mail-hist-header-ring-alist))) (len (ring-length ring)) (repeat (eq last-command 'mail-hist-input-access))) (if repeat (setq mail-hist-access-count - (ring-plus1 mail-hist-access-count len)) + (funcall access-func mail-hist-access-count len)) (setq mail-hist-access-count 0)) (if (null ring) (progn (ding) (message "No history for \"%s\"." header)) (if (ring-empty-p ring) - (error "\"%s\" ring is empty." header) + (error "\"%s\" ring is empty" header) (and repeat (delete-region (car mail-hist-last-bounds) (cdr mail-hist-last-bounds))) (let ((start (point))) (insert (ring-ref ring mail-hist-access-count)) (setq mail-hist-last-bounds (cons start (point))) - (setq this-command 'mail-hist-input-access)))))) + (setq this-command 'mail-hist-input-access) + ;; Special case: when flipping through message bodies, it's + ;; usually most useful for point to stay at the top. This + ;; is because the unique part of a message in a thread is + ;; more likely to be at the top than the bottom, as the + ;; bottom is often just the same quoted history for every + ;; message in the thread, differing only in indentation + ;; level. + (if (string-equal header "body") + (goto-char start))) + )))) + + +(defun mail-hist-previous-input (header) + "Insert the previous contents of this mail header or message body. +Moves back through the history of sent mail messages. Each header has +its own independent history, as does the body of the message. + +The history only contains the contents of outgoing messages, not +received mail." + (interactive (list (or (mail-hist-current-header-name) "body"))) + (mail-hist-retrieve-and-insert header 'ring-plus1)) + (defun mail-hist-next-input (header) "Insert next contents of this mail header or message body. @@ -251,32 +283,14 @@ its own independent history, as does the body of the message. Although you can do so, it does not make much sense to call this without having called `mail-hist-previous-header' first -(\\[mail-hist-previous-header]). +\(\\[mail-hist-previous-header]). The history only contains the contents of outgoing messages, not received mail." (interactive (list (or (mail-hist-current-header-name) "body"))) - (let* ((ring (cdr (assoc header mail-hist-header-ring-alist))) - (len (ring-length ring)) - (repeat (eq last-command 'mail-hist-input-access))) - (if repeat - (setq mail-hist-access-count - (ring-minus1 mail-hist-access-count len)) - (setq mail-hist-access-count 0)) - (if (null ring) - (progn - (ding) - (message "No history for \"%s\"." header)) - (if (ring-empty-p ring) - (error "\"%s\" ring is empty." header) - (and repeat - (delete-region (car mail-hist-last-bounds) - (cdr mail-hist-last-bounds))) - (let ((start (point))) - (insert (ring-ref ring mail-hist-access-count)) - (setq mail-hist-last-bounds (cons start (point))) - (setq this-command 'mail-hist-input-access)))))) + (mail-hist-retrieve-and-insert header 'ring-minus1)) + (provide 'mail-hist) -;; mail-hist.el ends here +;;; mail-hist.el ends here