X-Git-Url: http://cgit.sxemacs.org/?p=gnus;a=blobdiff_plain;f=lisp%2Fmessage.el;h=6c4d9309cad0421151c06a6fffe7749d410c7552;hp=8adec815b32c77194e66416a39235cbbc887b1c4;hb=a2c927950fdddc21d7d245d01ed30463268f9234;hpb=ca86e68e1f1d1991f8dbd459b314ef6221fe7037 diff --git a/lisp/message.el b/lisp/message.el index 8adec815b..6c4d9309c 100644 --- a/lisp/message.el +++ b/lisp/message.el @@ -31,7 +31,8 @@ (eval-when-compile (require 'cl)) -(require 'mail-header) +(require 'mailheader) +(require 'rmail) (require 'nnheader) (require 'timezone) (require 'easymenu) @@ -42,6 +43,12 @@ (defvar message-directory "~/Mail/" "*Directory from which all other mail file variables are derived.") +(defvar message-max-buffers 10 + "*How many buffers to keep before starting to kill them off.") + +(defvar message-send-rename-function nil + "Function called to rename the buffer after sending it.") + ;;;###autoload (defvar message-fcc-handler-function 'rmail-output "*A function called to save outgoing articles. @@ -118,8 +125,7 @@ included. Organization, Lines and X-Mailer are optional.") "*Regexp of headers to be removed unconditionally before mailing.") ;;;###autoload -(defvar message-ignored-supersedes-headers - "^Path:\\|^Date\\|^NNTP-Posting-Host:\\|^Xref:\\|^Lines:\\|^Received:\\|^X-From-Line:\\|Return-Path:" +(defvar message-ignored-supersedes-headers "^Path:\\|^Date\\|^NNTP-Posting-Host:\\|^Xref:\\|^Lines:\\|^Received:\\|^X-From-Line:\\|Return-Path:\\|^Supersedes:" "*Header lines matching this regexp will be deleted before posting. It's best to delete old Path and Date headers before posting to avoid any confusion.") @@ -134,15 +140,17 @@ any confusion.") nil means let mailer mail back a message to report errors.") ;;;###autoload -(defvar message-generate-new-buffers nil - "*Non-nil means that a new message buffer will be created whenever `mail-setup' is called.") +(defvar message-generate-new-buffers t + "*Non-nil means that a new message buffer will be created whenever `mail-setup' is called. +If this is a function, call that function with three parameters: The type, +the to address and the group name. (Any of these may be nil.) The function +should return the new buffer name.") ;;;###autoload (defvar message-kill-buffer-on-exit nil "*Non-nil means that the message buffer will be killed after sending a message.") (defvar gnus-local-organization) -;;;###autoload (defvar message-user-organization (or (and (boundp 'gnus-local-organization) gnus-local-organization) @@ -155,9 +163,8 @@ If t, use `message-user-organization-file'.") (defvar message-user-organization-file "/usr/lib/news/organization" "*Local news organization file.") -;;;###autoload -(defvar message-autosave-directory - (concat (file-name-as-directory message-directory) "drafts/") +(defvar message-autosave-directory "~/" + ; (concat (file-name-as-directory message-directory) "drafts/") "*Directory where message autosaves buffers. If nil, message won't autosave.") @@ -200,7 +207,7 @@ Legal values include `message-send-mail-with-mh' and (defvar message-send-news-function 'message-send-news "Function to call to send the current buffer as news. The headers should be delimited by a line whose contents match the -variable `message-header-separator'.") +variable `mail-header-separator'.") ;;;###autoload (defvar message-reply-to-function nil @@ -244,14 +251,21 @@ always use the value.") (defvar message-generate-headers-first nil "*If non-nil, generate all possible headers before composing.") -;;;###autoload -(defvar message-header-separator "--text follows this line--" - "*Line used to separate headers from text in messages being composed.") - (defvar message-setup-hook nil "Normal hook, run each time a new outgoing message is initialized. The function `message-setup' runs this hook.") +(defvar message-signature-setup-hook nil + "Normal hook, run each time a new outgoing message is initialized. +It is run after the headers have been inserted and before +the signature is inserted.") + +(defvar message-mode-hook nil + "Hook run in message mode buffers.") + +(defvar message-header-hook nil + "Hook run in a message mode buffer narrowed to the headers.") + (defvar message-header-setup-hook nil "Hook called narrowed to the headers when setting up a message buffer.") @@ -362,6 +376,10 @@ actually occur.") table) "Syntax table used while in Message mode.") +(defvar message-mode-abbrev-table text-mode-abbrev-table + "Abbrev table used in Message mode buffers. +Defaults to `text-mode-abbrev-table'.") + (defvar message-font-lock-keywords (let* ((cite-prefix "A-Za-z") (cite-suffix (concat cite-prefix "0-9_.@-"))) (list '("^To:" . font-lock-function-name-face) @@ -395,6 +413,8 @@ The cdr of ech entry is a function for applying the face to a region.") ;;; Internal variables. +(defvar message-buffer-list nil) + ;;; Regexp matching the delimiter of messages in UNIX mail format ;;; (UNIX From lines), minus the initial ^. (defvar message-unix-mail-delimiter @@ -446,8 +466,8 @@ The cdr of ech entry is a function for applying the face to a region.") (defvar message-header-format-alist `((Newsgroups) - (To . message-fill-header) - (Cc . message-fill-header) + (To . message-fill-address) + (Cc . message-fill-address) (Subject) (In-Reply-To) (Fcc) @@ -464,7 +484,7 @@ The cdr of ech entry is a function for applying the face to a region.") "Alist used for formatting headers.") (eval-and-compile - (autoload 'message-setup-toolbar "message-xmas") + (autoload 'message-setup-toolbar "messagexmas") (autoload 'mh-send-letter "mh-comp")) @@ -497,17 +517,27 @@ The cdr of ech entry is a function for applying the face to a region.") (defun message-tokenize-header (header &optional separator) "Split HEADER into a list of header elements. \",\" is used as the separator." - (let* ((beg 0) - (separator (or separator ",")) - (regexp - (format "[ \t]*\\([^%s]+\\)?\\([%s]+\\|\\'\\)" separator separator)) - elems) - (while (and (string-match regexp header beg) - (< beg (length header))) - (when (match-beginning 1) - (push (match-string 1 header) elems)) - (setq beg (match-end 0))) - (nreverse elems))) + (let ((regexp (format "[%s]+" (or separator ","))) + (beg 1) + (first t) + quoted elems) + (save-excursion + (message-set-work-buffer) + (insert header) + (goto-char (point-min)) + (while (not (eobp)) + (if first + (setq first nil) + (forward-char 1)) + (cond ((and (> (point) beg) + (or (eobp) + (and (looking-at regexp) + (not quoted)))) + (push (buffer-substring beg (point)) elems) + (setq beg (match-end 0))) + ((= (following-char) ?\") + (setq quoted (not quoted))))) + (nreverse elems)))) (defun message-fetch-field (header) "The same as `mail-fetch-field', only remove all newlines." @@ -708,6 +738,8 @@ Return the number of headers removed." "----" ["To" message-goto-to t] ["Subject" message-goto-subject t] + ["Cc" message-goto-cc t] + ["Reply-to" message-goto-reply-to t] ["Summary" message-goto-summary t] ["Keywords" message-goto-keywords t] ["Newsgroups" message-goto-newsgroups t] @@ -721,7 +753,7 @@ Return the number of headers removed." ["Sort Headers" message-sort-headers t] ["Yank Original" message-yank-original t] ["Fill Yanked Message" message-fill-yanked-message t] - ;; ["Insert Signature" news-reply-signature t] + ["Insert Signature" message-insert-signature t] ["Caesar (rot13) Message" message-caesar-buffer-body t] ["Rename buffer" message-rename-buffer t] ["Spellcheck" ispell-message t] @@ -729,6 +761,9 @@ Return the number of headers removed." ["Send Message" message-send-and-exit t] ["Abort Message" message-dont-send t])) +(defvar facemenu-add-face-function) +(defvar facemenu-remove-face-function) + ;;;###autoload (defun message-mode () "Major mode for editing mail and news to be sent. @@ -759,7 +794,7 @@ C-c C-r message-ceasar-buffer-body (rot13 the message body)." (make-local-variable 'message-postpone-actions) (set-syntax-table message-mode-syntax-table) (use-local-map message-mode-map) - (setq local-abbrev-table text-mode-abbrev-table) + (setq local-abbrev-table message-mode-abbrev-table) (setq major-mode 'message-mode) (setq mode-name "Message") (setq buffer-offer-save t) @@ -779,9 +814,11 @@ C-c C-r message-ceasar-buffer-body (rot13 the message body)." (make-local-variable 'paragraph-start) (setq paragraph-start (concat (regexp-quote mail-header-separator) "$\\|[ \t]*[-_][-_][-_]+$\\|" + "-- $\\|" paragraph-start)) (setq paragraph-separate (concat (regexp-quote mail-header-separator) "$\\|[ \t]*[-_][-_][-_]+$\\|" + "-- $\\|" paragraph-separate)) (make-local-variable 'message-reply-headers) (setq message-reply-headers nil) @@ -792,8 +829,8 @@ C-c C-r message-ceasar-buffer-body (rot13 the message body)." (setq message-sent-message-via nil) (make-local-variable 'message-checksum) (setq message-checksum nil) - (when (fboundp 'mail-hist-define-keys) - (mail-hist-define-keys)) + ;;(when (fboundp 'mail-hist-define-keys) + ;; (mail-hist-define-keys)) (when (string-match "XEmacs\\|Lucid" emacs-version) (message-setup-toolbar)) (easy-menu-add message-mode-menu message-mode-map) @@ -869,6 +906,7 @@ C-c C-r message-ceasar-buffer-body (rot13 the message body)." (defun message-goto-body () "Move point to the beginning of the message body." (interactive) + (if (looking-at "[ \t]*\n") (expand-abbrev)) (goto-char (point-min)) (search-forward (concat "\n" mail-header-separator "\n") nil t)) @@ -884,7 +922,9 @@ C-c C-r message-ceasar-buffer-body (rot13 the message body)." (defun message-insert-to () "Insert a To header that points to the author of the article being replied to." (interactive) - (when (message-position-on-field "To") + (when (and (message-position-on-field "To") + (mail-fetch-field "to") + (not (string-match "\\` *\\'" (mail-fetch-field "to")))) (insert ", ")) (insert (or (message-fetch-reply-field "reply-to") (message-fetch-reply-field "from") ""))) @@ -892,7 +932,9 @@ C-c C-r message-ceasar-buffer-body (rot13 the message body)." (defun message-insert-newsgroups () "Insert the Newsgroups header from the article being replied to." (interactive) - (when (message-position-on-field "Newsgroups") + (when (and (message-position-on-field "Newsgroups") + (mail-fetch-field "newsgroups") + (not (string-match "\\` *\\'" (mail-fetch-field "newsgroups")))) (insert ",")) (insert (or (message-fetch-reply-field "newsgroups") ""))) @@ -902,9 +944,15 @@ C-c C-r message-ceasar-buffer-body (rot13 the message body)." (defun message-insert-signature (&optional force) "Insert a signature. See documentation for the `message-signature' variable." - (interactive (list t)) + (interactive (list 0)) (let* ((signature (cond ((and (null message-signature) + (eq force 0)) + (save-excursion + (goto-char (point-max)) + (not (re-search-backward + message-signature-separator nil t)))) + ((and (null message-signature) force) t) ((message-functionp message-signature) @@ -920,13 +968,11 @@ C-c C-r message-ceasar-buffer-body (rot13 the message body)." (file-exists-p message-signature-file)) signature)))) (when signature - ;; Remove blank lines at the end of the message. - (goto-char (point-max)) - (skip-chars-backward " \t\n") - (end-of-line) - (delete-region (point) (point-max)) ;; Insert the signature. - (insert "\n\n-- \n") + (goto-char (point-max)) + (unless (bolp) + (insert "\n")) + (insert "\n-- \n") (if (eq signature t) (insert-file-contents message-signature-file) (insert signature)) @@ -1006,7 +1052,11 @@ name, rather than giving an automatic name." (name (if enter-string (read-string "New buffer name: " name-default) name-default))) - (rename-buffer name t))))) + (rename-buffer name t) + (setq buffer-auto-save-file-name + (format "%s%s" + (file-name-as-directory message-autosave-directory) + (file-name-nondirectory buffer-auto-save-file-name))))))) (defun message-fill-yanked-message (&optional justifyp) "Fill the paragraphs of a message yanked into this one. @@ -1051,6 +1101,8 @@ Puts point before the text and mark after. Normally indents each nonblank line ARG spaces (default 3). However, if `message-yank-prefix' is non-nil, insert that prefix on each line. +This function uses `message-cite-function' to do the actual citing. + Just \\[universal-argument] as argument means don't indent, insert no prefix, and don't delete any headers." (interactive "P") @@ -1060,11 +1112,11 @@ prefix, and don't delete any headers." (delete-windows-on message-reply-buffer t) (insert-buffer message-reply-buffer) (funcall message-cite-function) - (exchange-point-and-mark) + (message-exchange-point-and-mark) (unless (bolp) (insert ?\n)) (unless modified - (setq message-checksum (message-checksum)))))) + (setq message-checksum (cons (message-checksum) (buffer-size))))))) (defun message-cite-original () (let ((start (point)) @@ -1195,6 +1247,8 @@ the user from the mailer." (y-or-n-p "No changes in the buffer; really send? "))) ;; Make it possible to undo the coming changes. (undo-boundary) + (let ((inhibit-read-only t)) + (put-text-property (point-min) (point-max) 'read-only nil)) (message-fix-before-sending) (run-hooks 'message-send-hook) (message "Sending...") @@ -1209,14 +1263,16 @@ the user from the mailer." "Already sent message via mail; resend? ")) (message-send-mail arg)))) (message-do-fcc) - (when (fboundp 'mail-hist-put-headers-into-history) - (mail-hist-put-headers-into-history)) + ;;(when (fboundp 'mail-hist-put-headers-into-history) + ;; (mail-hist-put-headers-into-history)) (run-hooks 'message-sent-hook) (message "Sending...done") ;; If buffer has no file, mark it as unmodified and delete autosave. (unless buffer-file-name (set-buffer-modified-p nil) (delete-auto-save-file-if-necessary t)) + ;; Delete other mail buffers and stuff. + (message-do-send-housekeeping) (message-do-actions message-send-actions) ;; Return success. t))) @@ -1268,7 +1324,11 @@ the user from the mailer." (save-excursion (set-buffer tembuf) (erase-buffer) - (insert-buffer-substring mailbuf) + ;; Avoid copying text props. + (insert (format + "%s" (save-excursion + (set-buffer mailbuf) + (buffer-string)))) ;; Remove some headers. (save-restriction (message-narrow-to-headers) @@ -1348,8 +1408,15 @@ the user from the mailer." (defun message-send-mail-with-mh () "Send the prepared message buffer with mh." - (let (mh-previous-window-config) - (mh-send-letter))) + (let ((mh-previous-window-config nil) + (name (make-temp-name + (concat (file-name-as-directory message-autosave-directory) + "msg.")))) + (setq buffer-file-name name) + (mh-send-letter) + (condition-case () + (delete-file name) + (error nil)))) (defun message-send-news (&optional arg) (let ((tembuf (generate-new-buffer " *message temp*")) @@ -1358,6 +1425,11 @@ the user from the mailer." (funcall message-post-method arg) message-post-method)) (messbuf (current-buffer)) + (message-syntax-checks + (if arg + (cons '(existing-newsgroups . disabled) + message-syntax-checks) + message-syntax-checks)) result) (save-restriction (message-narrow-to-headers) @@ -1365,13 +1437,18 @@ the user from the mailer." (message-generate-headers message-required-news-headers) ;; Let the user do all of the above. (run-hooks 'message-header-hook)) + (message-cleanup-headers) (when (message-check-news-syntax) (unwind-protect (save-excursion (set-buffer tembuf) (buffer-disable-undo (current-buffer)) (erase-buffer) - (insert-buffer-substring messbuf) + ;; Avoid copying text props. + (insert (format + "%s" (save-excursion + (set-buffer messbuf) + (buffer-string)))) ;; Remove some headers. (save-restriction (message-narrow-to-headers) @@ -1467,7 +1544,15 @@ the user from the mailer." (goto-char (point-min)) (insert "Followup-To: " to "\n")) t)) - + ;; Check "Shoot me". + (or (message-check-element 'shoot) + (save-excursion + (if (re-search-forward + "Message-ID.*.i-have-a-misconfigured-system-so-shoot-me" + nil t) + (y-or-n-p + "You appear to have a misconfigured system. Really post? ") + t))) ;; Check for Approved. (or (message-check-element 'approved) (save-excursion @@ -1516,7 +1601,8 @@ the user from the mailer." (if (not hashtb) t (while groups - (unless (boundp (intern (car groups) hashtb)) + (when (and (not (boundp (intern (car groups) hashtb))) + (not (equal (car groups) "poster"))) (push (car groups) errors)) (pop groups)) (if (not errors) @@ -1536,9 +1622,10 @@ the user from the mailer." (while (and headers (not error)) (when (setq header (mail-fetch-field (car headers))) (if (or - (not (string-match - "\\`\\([-.a-zA-Z0-9]+\\)?\\(,[-.a-zA-Z0-9]+\\)*\\'" - header)) + (not + (string-match + "\\`\\([-+_&.a-zA-Z0-9]+\\)?\\(,[-.a-zA-Z0-9]+\\)*\\'" + header)) (memq nil (mapcar (lambda (g) @@ -1554,7 +1641,6 @@ the user from the mailer." (car headers) header))))) ;; Check the From header. (or - (message-check-element 'from) (save-excursion (let* ((case-fold-search t) (from (message-fetch-field "from"))) @@ -1599,8 +1685,8 @@ the user from the mailer." (concat "^" (regexp-quote mail-header-separator) "$")) (forward-line 1) (let ((b (point))) - (or (re-search-forward message-signature-separator nil t) - (goto-char (point-max))) + (goto-char (point-max)) + (re-search-backward message-signature-separator nil t) (beginning-of-line) (or (re-search-backward "[^ \n\t]" b t) (y-or-n-p "Empty article. Really post? "))))) @@ -1621,21 +1707,24 @@ the user from the mailer." ;; Check whether any new text has been added. (or (message-check-element 'new-text) (not message-checksum) - (not (eq (message-checksum) message-checksum)) + (not (and (eq (message-checksum) (car message-checksum)) + (eq (buffer-size) (cdr message-checksum)))) (y-or-n-p "It looks like no new text has been added. Really post? ")) ;; Check the length of the signature. - (or (message-check-element 'signature) - (progn - (goto-char (point-max)) - (if (not (re-search-backward "^-- $" nil t)) - t - (if (> (count-lines (point) (point-max)) 5) - (y-or-n-p - (format - "Your .sig is %d lines; it should be max 4. Really post? " - (count-lines (point) (point-max)))) - t)))))) + (or + (message-check-element 'signature) + (progn + (goto-char (point-max)) + (if (or (not (re-search-backward message-signature-separator nil t)) + (search-forward message-forward-end-separator nil t)) + t + (if (> (count-lines (point) (point-max)) 5) + (y-or-n-p + (format + "Your .sig is %d lines; it should be max 4. Really post? " + (count-lines (point) (point-max)))) + t)))))) (defun message-check-element (type) "Returns non-nil if this type is not to be checked." @@ -1653,7 +1742,8 @@ the user from the mailer." (re-search-forward (concat "^" (regexp-quote mail-header-separator) "$")) (while (not (eobp)) - (setq sum (logxor sum (following-char))) + (when (not (looking-at "[ \t\n]")) + (setq sum (logxor (ash sum 1) (following-char)))) (forward-char 1))) sum)) @@ -1681,7 +1771,8 @@ the user from the mailer." (if (string-match "^[ \t]*|[ \t]*\\(.*\\)[ \t]*$" file) ;; Pipe the article to the program in question. (call-process-region (point-min) (point-max) shell-file-name - nil nil nil "-c" (match-string 1 file)) + nil nil nil shell-command-switch + (match-string 1 file)) ;; Save the article. (setq file (expand-file-name file)) (unless (file-exists-p (file-name-directory file)) @@ -1746,7 +1837,7 @@ the user from the mailer." (mail-header-subject message-reply-headers)) (message-strip-subject-re psubject)))) "_-_" "")) - "@" (message-make-fqdm) ">")) + "@" (message-make-fqdn) ">")) (defvar message-unique-id-char nil) @@ -1863,7 +1954,10 @@ the user from the mailer." (defun message-make-from () "Make a From header." (let* ((login (message-make-address)) - (fullname (user-full-name))) + (fullname + (or (and (boundp 'user-full-name) + user-full-name) + (user-full-name)))) (when (string= fullname "&") (setq fullname (user-login-name))) (save-excursion @@ -1931,34 +2025,37 @@ give as trustworthy answer as possible." (when user-mail-address (nth 1 (mail-extract-address-components user-mail-address)))) -(defun message-make-fqdm () +(defun message-make-fqdn () "Return user's fully qualified domain name." - (let ((system-name (system-name))) + (let ((system-name (system-name)) + (user-mail (message-user-mail-address))) (cond ((string-match "[^.]\\.[^.]" system-name) ;; `system-name' returned the right result. system-name) - ;; We try `user-mail-address' as a backup. - ((string-match "@\\(.*\\)\\'" (message-user-mail-address)) - (match-string 1 user-mail-address)) ;; Try `mail-host-address'. ((and (boundp 'mail-host-address) - mail-host-address) + (stringp mail-host-address) + (string-match "\\." mail-host-address)) mail-host-address) + ;; We try `user-mail-address' as a backup. + ((and (string-match "\\." user-mail) + (string-match "@\\(.*\\)\\'" user-mail)) + (match-string 1 user-mail)) ;; Default to this bogus thing. (t (concat system-name ".i-have-a-misconfigured-system-so-shoot-me"))))) (defun message-make-host-name () "Return the name of the host." - (let ((fqdm (message-make-fqdm))) - (string-match "^[^.]+\\." fqdm) - (substring fqdm 0 (1- (match-end 0))))) + (let ((fqdn (message-make-fqdn))) + (string-match "^[^.]+\\." fqdn) + (substring fqdn 0 (1- (match-end 0))))) (defun message-make-domain () "Return the domain name." (or mail-host-address - (message-make-fqdm))) + (message-make-fqdn))) (defun message-generate-headers (headers) "Prepare article HEADERS. @@ -2098,6 +2195,36 @@ Headers already prepared in the buffer are not modified." ;;; Setting up a message buffer ;;; +(defun message-fill-address (header value) + (save-restriction + (narrow-to-region (point) (point)) + (insert (capitalize (symbol-name header)) + ": " + (if (consp value) (car value) value) + "\n") + (narrow-to-region (point-min) (1- (point-max))) + (let (quoted last) + (goto-char (point-min)) + (while (not (eobp)) + (skip-chars-forward "^,\"" (point-max)) + (if (or (= (following-char) ?,) + (eobp)) + (when (not quoted) + (if (and (> (current-column) 78) + last) + (progn + (save-excursion + (goto-char last) + (insert "\n\t")) + (setq last (1+ (point)))) + (setq last (1+ (point))))) + (setq quoted (not quoted))) + (unless (eobp) + (forward-char 1)))) + (goto-char (point-max)) + (widen) + (forward-line 1))) + (defun message-fill-header (header value) (let ((begin (point)) (fill-column 78) @@ -2138,24 +2265,73 @@ Headers already prepared in the buffer are not modified." (forward-line 2))) (sit-for 0))) +(defun message-buffer-name (type &optional to group) + "Return a new (unique) buffer name based on TYPE and TO." + (cond + ;; Check whether `message-generate-new-buffers' is a function, + ;; and if so, call it. + ((message-functionp message-generate-new-buffers) + (funcall message-generate-new-buffers type to group)) + ;; Generate a new buffer name The Message Way. + (message-generate-new-buffers + (generate-new-buffer-name + (concat "*" type + (if to + (concat " to " + (or (car (mail-extract-address-components to)) + to) "") + "") + (if (and group (not (string= group ""))) (concat " on " group) "") + "*"))) + ;; Use standard name. + (t + (format "*%s message*" type)))) + (defun message-pop-to-buffer (name) "Pop to buffer NAME, and warn if it already exists and is modified." - (if message-generate-new-buffers - (set-buffer (pop-to-buffer (generate-new-buffer name))) - (let ((buffer (get-buffer name))) - (if (and buffer - (buffer-name buffer)) - (progn - (set-buffer (pop-to-buffer buffer)) - (when (and (buffer-modified-p) - (not (y-or-n-p - "Message already being composed; erase? "))) - (error "Message being composed"))) - (set-buffer (pop-to-buffer name))))) + (let ((buffer (get-buffer name))) + (if (and buffer + (buffer-name buffer)) + (progn + (set-buffer (pop-to-buffer buffer)) + (when (and (buffer-modified-p) + (not (y-or-n-p + "Message already being composed; erase? "))) + (error "Message being composed"))) + (set-buffer (pop-to-buffer name)))) (erase-buffer) (message-mode)) +(defun message-do-send-housekeeping () + "Kill old message buffers." + ;; We might have sent this buffer already. Delete it from the + ;; list of buffers. + (setq message-buffer-list (delq (current-buffer) message-buffer-list)) + (while (and message-max-buffers + (>= (length message-buffer-list) message-max-buffers)) + ;; Kill the oldest buffer -- unless it has been changed. + (let ((buffer (pop message-buffer-list))) + (when (and (buffer-name buffer) + (not (buffer-modified-p buffer))) + (kill-buffer buffer)))) + ;; Rename the buffer. + (if message-send-rename-function + (funcall message-send-rename-function) + (when (string-match "\\`\\*" (buffer-name)) + (rename-buffer + (concat "*sent " (substring (buffer-name) (match-end 0))) t))) + ;; Push the current buffer onto the list. + (when message-max-buffers + (setq message-buffer-list + (nconc message-buffer-list (list (current-buffer)))))) + +(defvar mc-modes-alist) (defun message-setup (headers &optional replybuffer actions) + (when (and (boundp 'mc-modes-alist) + (not (assq 'message-mode mc-modes-alist))) + (push '(message-mode (encrypt . mc-encrypt-message) + (sign . mc-sign-message)) + mc-modes-alist)) (when actions (setq message-send-actions actions)) (setq message-reply-buffer replybuffer) @@ -2170,10 +2346,15 @@ Headers already prepared in the buffer are not modified." (pop h)) alist) headers) - (forward-line -1) + (delete-region (point) (progn (forward-line -1) (point))) (when message-default-headers (insert message-default-headers)) - (insert mail-header-separator "\n") + (put-text-property + (point) + (progn + (insert mail-header-separator "\n") + (1- (point))) + 'read-only nil) (forward-line -1) (when (message-news-p) (when message-default-news-headers @@ -2191,6 +2372,7 @@ Headers already prepared in the buffer are not modified." (delq 'Lines (delq 'Subject (copy-sequence message-required-mail-headers)))))) + (run-hooks 'message-signature-setup-hook) (message-insert-signature) (message-set-auto-save-file-name) (save-restriction @@ -2229,14 +2411,14 @@ Headers already prepared in the buffer are not modified." (defun message-mail (&optional to subject) "Start editing a mail message to be sent." (interactive) - (message-pop-to-buffer "*mail message*") + (message-pop-to-buffer (message-buffer-name "mail" to)) (message-setup `((To . ,(or to "")) (Subject . ,(or subject ""))))) ;;;###autoload (defun message-news (&optional newsgroups subject) "Start editing a news article to be sent." (interactive) - (message-pop-to-buffer "*news message*") + (message-pop-to-buffer (message-buffer-name "news" nil newsgroups)) (message-setup `((Newsgroups . ,(or newsgroups "")) (Subject . ,(or subject ""))))) @@ -2247,6 +2429,7 @@ Headers already prepared in the buffer are not modified." (let ((cur (current-buffer)) from subject date reply-to to cc references message-id follow-to + (inhibit-point-motion-hooks t) mct never-mct gnus-warning) (save-restriction (narrow-to-region @@ -2301,10 +2484,9 @@ Headers already prepared in the buffer are not modified." (message-set-work-buffer) (unless never-mct (insert (or reply-to from ""))) - (insert - (if (bolp) "" ", ") (or to "") - (if mct (concat (if (bolp) "" ", ") mct) "") - (if cc (concat (if (bolp) "" ", ") cc) "")) + (insert (if (bolp) "" ", ") (or to "")) + (insert (if mct (concat (if (bolp) "" ", ") mct) "")) + (insert (if cc (concat (if (bolp) "" ", ") cc) "")) ;; Remove addresses that match `rmail-dont-reply-to-names'. (insert (prog1 (rmail-dont-reply-to (buffer-string)) (erase-buffer))) @@ -2313,7 +2495,7 @@ Headers already prepared in the buffer are not modified." (mapcar (lambda (addr) (cons (mail-strip-quoted-names addr) addr)) - (nreverse (mail-parse-comma-list)))) + (message-tokenize-header (buffer-string)))) (let ((s ccalist)) (while s (setq ccalist (delq (assoc (car (pop s)) s) ccalist))))) @@ -2324,7 +2506,9 @@ Headers already prepared in the buffer are not modified." follow-to))))) (widen)) - (message-pop-to-buffer "*mail message*") + (message-pop-to-buffer (message-buffer-name + (if wide "wide reply" "reply") from + (if wide to-address nil))) (setq message-reply-headers (vector 0 subject from date message-id references 0 0 "")) @@ -2349,6 +2533,7 @@ Headers already prepared in the buffer are not modified." (let ((cur (current-buffer)) from subject date reply-to mct references message-id follow-to + (inhibit-point-motion-hooks t) followup-to distribution newsgroups gnus-warning) (save-restriction (narrow-to-region @@ -2383,7 +2568,7 @@ Headers already prepared in the buffer are not modified." (setq subject (concat "Re: " subject)) (widen)) - (message-pop-to-buffer "*news message*") + (message-pop-to-buffer (message-buffer-name "followup" from newsgroups)) (message-setup `((Subject . ,subject) @@ -2459,7 +2644,7 @@ responses here are directed to other newsgroups.")) distribution (message-fetch-field "distribution"))) ;; Make sure that this article was written by the user. (unless (string-equal - (downcase (mail-strip-quoted-names from)) + (downcase (cadr (mail-extract-address-components from))) (downcase (message-make-address))) (error "This article is not yours")) ;; Make control message. @@ -2490,11 +2675,12 @@ header line with the old Message-ID." (let ((cur (current-buffer))) ;; Check whether the user owns the article that is to be superseded. (unless (string-equal - (downcase (mail-strip-quoted-names (message-fetch-field "from"))) - (downcase (mail-strip-quoted-names (message-make-address)))) + (downcase (cadr (mail-extract-address-components + (message-fetch-field "from")))) + (downcase (message-make-address))) (error "This article is not yours")) ;; Get a normal message buffer. - (message-pop-to-buffer "*supersede message*") + (message-pop-to-buffer (message-buffer-name "supersede")) (insert-buffer-substring cur) (message-narrow-to-head) ;; Remove unwanted headers. @@ -2548,6 +2734,9 @@ Optional NEWS will use news to forward instead of mail." (if message-signature-before-forwarded-message (goto-char (point-max)) (message-goto-body)) + ;; Make sure we're at the start of the line. + (unless (eolp) + (insert "\n")) ;; Narrow to the area we are to insert. (narrow-to-region (point) (point)) ;; Insert the separators and the forwarded buffer. @@ -2617,7 +2806,7 @@ you." (interactive) (let ((cur (current-buffer)) boundary) - (message-pop-to-buffer "*mail message*") + (message-pop-to-buffer (message-buffer-name "bounce")) (insert-buffer-substring cur) (undo-boundary) (message-narrow-to-head) @@ -2640,7 +2829,7 @@ you." ;; We remove everything before the bounced mail. (delete-region (point-min) - (if (re-search-forward "[^ \t]*:" nil t) + (if (re-search-forward "^[^ \n\t]+:" nil t) (match-beginning 0) (point))) (save-restriction @@ -2663,7 +2852,7 @@ you." (special-display-regexps nil) (same-window-buffer-names nil) (same-window-regexps nil)) - (message-pop-to-buffer "*mail message*")) + (message-pop-to-buffer (message-buffer-name "mail" to))) (message-setup `((To . ,(or to "")) (Subject . ,(or subject ""))))) ;;;###autoload @@ -2675,7 +2864,7 @@ you." (special-display-regexps nil) (same-window-buffer-names nil) (same-window-regexps nil)) - (message-pop-to-buffer "*mail message*")) + (message-pop-to-buffer (message-buffer-name "mail" to))) (message-setup `((To . ,(or to "")) (Subject . ,(or subject ""))))) ;;;###autoload @@ -2687,7 +2876,7 @@ you." (special-display-regexps nil) (same-window-buffer-names nil) (same-window-regexps nil)) - (message-pop-to-buffer "*news message*")) + (message-pop-to-buffer (message-buffer-name "news" nil newsgroups))) (message-setup `((Newsgroups . ,(or newsgroups "")) (Subject . ,(or subject ""))))) @@ -2700,7 +2889,7 @@ you." (special-display-regexps nil) (same-window-buffer-names nil) (same-window-regexps nil)) - (message-pop-to-buffer "*news message*")) + (message-pop-to-buffer (message-buffer-name "news" nil newsgroups))) (message-setup `((Newsgroups . ,(or newsgroups "")) (Subject . ,(or subject ""))))) @@ -2738,9 +2927,11 @@ which specify the range to operate on." (if (eq (following-char) (char-after (- (point) 2))) (delete-char -2)))))) +(defalias 'message-exchange-point-and-mark 'exchange-point-and-mark) + ;; Support for toolbar (when (string-match "XEmacs\\|Lucid" emacs-version) - (require 'message-xmas)) + (require 'messagexmas)) ;;; Group name completion. @@ -2783,16 +2974,17 @@ Do a `tab-to-tab-stop' if not in those headers." (message "No matching groups") (pop-to-buffer "*Completions*") (buffer-disable-undo (current-buffer)) - (erase-buffer) - (let ((standard-output (current-buffer))) - (display-completion-list (sort completions 'string<))) - (goto-char (point-min)) - (pop-to-buffer cur)))))) + (let ((buffer-read-only nil)) + (erase-buffer) + (let ((standard-output (current-buffer))) + (display-completion-list (sort completions 'string<))) + (goto-char (point-min)) + (pop-to-buffer cur))))))) ;;; Help stuff. (defmacro message-y-or-n-p (question show &rest text) - "Ask QUESTION, displaying the rest of the arguments in a temporary buffer." + "Ask QUESTION, displaying the rest of the arguments in a temp. buffer if SHOW" `(message-talkative-question 'y-or-n-p ,question ,show ,@text)) (defun message-talkative-question (ask question show &rest text) @@ -2818,6 +3010,8 @@ The following arguments may contain lists of values." (list (list list)))) +(run-hooks 'message-load-hook) + (provide 'message) ;;; message.el ends here