X-Git-Url: https://cgit.sxemacs.org/?a=blobdiff_plain;f=lisp%2Fmessage.el;h=a17617d2960c28c397c97ce7efe7cb0e2af057c7;hb=bd281c33591086cd286aeccaebc71da28164eb5b;hp=6b709a7c5b2f785d2fb56f584ee5e514e13e9688;hpb=6acac76dbfeaa2e3e042fda84fb9afaac3f4968f;p=gnus diff --git a/lisp/message.el b/lisp/message.el index 6b709a7c5..a17617d29 100644 --- a/lisp/message.el +++ b/lisp/message.el @@ -169,7 +169,8 @@ Don't touch this variable unless you really know what you're doing. Checks include subject-cmsg multiple-headers sendsys message-id from long-lines control-chars size new-text redirected-followup signature approved sender empty empty-headers message-id from subject -shorten-followup-to existing-newsgroups buffer-file-name unchanged." +shorten-followup-to existing-newsgroups buffer-file-name unchanged +newsgroups." :group 'message-news) (defcustom message-required-news-headers @@ -231,7 +232,7 @@ any confusion." :type 'regexp :group 'message-various) -(defcustom message-elide-elipsis "\n[...]\n\n" +(defcustom message-elide-ellipsis "\n[...]\n\n" "*The string which is inserted for elided text." :type 'string :group 'message-various) @@ -294,6 +295,11 @@ The provided functions are: :type '(radio (function-item message-forward-subject-author-subject) (function-item message-forward-subject-fwd))) +(defcustom message-forward-as-mime t + "*If non-nil, forward messages as an inline/rfc822 MIME section. Otherwise, directly inline the old message in the forwarded message." + :group 'message-forwarding + :type 'boolean) + (defcustom message-wash-forwarded-subjects nil "*If non-nil, try to remove as much old cruft as possible from the subject of messages before generating the new subject of a forward." :group 'message-forwarding @@ -304,6 +310,12 @@ The provided functions are: :group 'message-interface :type 'regexp) +(defcustom message-forward-ignored-headers nil + "*All headers that match this regexp will be deleted when forwarding a message." + :group 'message-forwarding + :type '(choice (const :tag "None" nil) + regexp)) + (defcustom message-ignored-cited-headers "." "*Delete these headers from the messages you yank." :group 'message-insertion @@ -372,10 +384,9 @@ always query the user whether to use the value. If it is the symbol (const use) (const ask))) -;; stuff relating to broken sendmail in MMDF (defcustom message-sendmail-f-is-evil nil - "*Non-nil means that \"-f username\" should not be added to the sendmail -command line, because it is even more evil than leaving it out." + "*Non-nil means that \"-f username\" should not be added to the sendmail command line. +Doing so would be even more evil than leaving it out." :group 'message-sending :type 'boolean) @@ -395,6 +406,11 @@ might set this variable to '(\"-f\" \"you@some.where\")." :group 'message-sending :type '(repeat string)) +(defvar message-cater-to-broken-inn t + "Non-nil means Gnus should not fold the `References' header. +Folding `References' makes ancient versions of INN create incorrect +NOV lines.") + (defvar gnus-post-method) (defvar gnus-select-method) (defcustom message-post-method @@ -648,6 +664,13 @@ Valid valued are `unique' and `unsent'." :group 'message :type 'symbol) +(defcustom message-dont-reply-to-names rmail-dont-reply-to-names + "*A regexp specifying names to prune when doing wide replies. +A value of nil means exclude your own name only." + :group 'message + :type '(choice (const :tag "Yourself" nil) + regexp)) + ;;; Internal variables. ;;; Well, not really internal. @@ -860,12 +883,7 @@ The cdr of ech entry is a function for applying the face to a region.") "Coding system to encode outgoing mail.") (defvar message-draft-coding-system - (cond - ((not (fboundp 'coding-system-p)) nil) - ((coding-system-p 'emacs-mule) 'emacs-mule) - ((memq 'escape-quoted (mm-get-coding-system-list)) 'escape-quoted) - ((coding-system-p 'no-conversion) 'no-conversion) - (t nil)) + mm-auto-save-coding-system "Coding system to compose mail.") ;;; Internal variables. @@ -943,6 +961,7 @@ The cdr of ech entry is a function for applying the face to a region.") "^ *---+ +Original message +---+ *$\\|" "^ *--+ +begin message +--+ *$\\|" "^ *---+ +Original message follows +---+ *$\\|" + "^ *---+ +Undelivered message follows +---+ *$\\|" "^|? *---+ +Message text follows: +---+ *|?$") "A regexp that matches the separator before the text of a failed message.") @@ -1045,7 +1064,7 @@ The cdr of ech entry is a function for applying the face to a region.") (when value (while (string-match "\n[\t ]+" value) (setq value (replace-match " " t t value))) - ;; We remove all text props.delete-region + ;; We remove all text props. (format "%s" value)))) (defun message-narrow-to-field () @@ -1075,6 +1094,7 @@ The cdr of ech entry is a function for applying the face to a region.") (insert (car headers) ?\n)))) (setq headers (cdr headers)))) + (defun message-fetch-reply-field (header) "Fetch FIELD from the message we're replying to." (when (and message-reply-buffer @@ -1284,6 +1304,7 @@ Point is left at the beginning of the narrowed-to region." (define-key message-mode-map "\C-c\C-n" 'message-insert-newsgroups) (define-key message-mode-map "\C-c\C-y" 'message-yank-original) + (define-key message-mode-map "\C-c\M-\C-y" 'message-yank-buffer) (define-key message-mode-map "\C-c\C-q" 'message-fill-yanked-message) (define-key message-mode-map "\C-c\C-w" 'message-insert-signature) (define-key message-mode-map "\C-c\M-h" 'message-insert-headers) @@ -1371,7 +1392,8 @@ C-c C-e message-elide-region (elide the text between point and mark). C-c C-v message-delete-not-region (remove the text outside the region). C-c C-z message-kill-to-signature (kill the text up to the signature). C-c C-r message-caesar-buffer-body (rot13 the message body). -C-c C-a mml-attach-file (attach a file as MIME)." +C-c C-a mml-attach-file (attach a file as MIME). +M-RET message-newline-and-reformat (break the line and reformat)." (interactive) (kill-all-local-variables) (set (make-local-variable 'message-reply-buffer) nil) @@ -1436,12 +1458,12 @@ C-c C-a mml-attach-file (attach a file as MIME)." '(message-font-lock-keywords t))) (make-local-variable 'adaptive-fill-regexp) (setq adaptive-fill-regexp - (concat "[ \t]*[-a-z0-9A-Z]*>+[ \t]*\\|" adaptive-fill-regexp)) + (concat "[ \t]*[-a-z0-9A-Z]*\\(>[ \t]*\\)+[ \t]*\\|" adaptive-fill-regexp)) (unless (boundp 'adaptive-fill-first-line-regexp) (setq adaptive-fill-first-line-regexp nil)) (make-local-variable 'adaptive-fill-first-line-regexp) (setq adaptive-fill-first-line-regexp - (concat "[ \t]*[-a-z0-9A-Z]*>+[ \t]*\\|" + (concat "[ \t]*[-a-z0-9A-Z]*\\(>[ \t]*\\)+[ \t]*\\|" adaptive-fill-first-line-regexp)) (mm-enable-multibyte) (make-local-variable 'indent-tabs-mode) ;Turn off tabs for indentation. @@ -1524,7 +1546,7 @@ C-c C-a mml-attach-file (attach a file as MIME)." "Move point to the end of the headers." (interactive) (message-goto-body) - (forward-line -2)) + (forward-line -1)) (defun message-goto-signature () "Move point to the beginning of the message signature. @@ -1602,17 +1624,24 @@ With the prefix argument FORCE, insert the header anyway." (defun message-newline-and-reformat () "Insert four newlines, and then reformat if inside quoted text." (interactive) - (let ((point (point)) - quoted) - (save-excursion - (beginning-of-line) - (setq quoted (looking-at (regexp-quote message-yank-prefix)))) - (insert "\n\n\n\n") + (let ((prefix "[]>ยป|:}+ \t]*") + (supercite-thing "[-._a-zA-Z0-9]*[>]+[ \t]*") + quoted point) + (unless (bolp) + (save-excursion + (beginning-of-line) + (when (looking-at (concat prefix + supercite-thing)) + (setq quoted (match-string 0)))) + (insert "\n")) + (setq point (point)) + (insert "\n\n\n") + (delete-region (point) (re-search-forward "[ \t]*")) (when quoted - (insert message-yank-prefix)) + (insert quoted)) (fill-paragraph nil) (goto-char point) - (forward-line 2))) + (forward-line 1))) (defun message-insert-signature (&optional force) "Insert a signature. See documentation for the `message-signature' variable." @@ -1653,13 +1682,11 @@ With the prefix argument FORCE, insert the header anyway." (defun message-elide-region (b e) "Elide the text between point and mark. -An ellipsis (from `message-elide-elipsis') will be inserted where the +An ellipsis (from `message-elide-ellipsis') will be inserted where the text was killed." (interactive "r") (kill-region b e) - (unless (bolp) - (insert "\n")) - (insert message-elide-elipsis)) + (insert message-elide-ellipsis)) (defvar message-caesar-translation-table nil) @@ -1728,7 +1755,7 @@ Mail and USENET news headers are not rotated." (unless (equal 0 (call-process-region (point-min) (point-max) program t t)) (insert body) - (message "%s failed." program)))))) + (message "%s failed" program)))))) (defun message-rename-buffer (&optional enter-string) "Rename the *message* buffer to \"*message* RECIPIENT\". @@ -1762,7 +1789,7 @@ Numeric argument means justify as well." (goto-char (point-min)) (search-forward (concat "\n" mail-header-separator "\n") nil t) (let ((fill-prefix message-yank-prefix)) - (fill-individual-paragraphs (point) (point-max) justifyp t)))) + (fill-individual-paragraphs (point) (point-max) justifyp)))) (defun message-indent-citation () "Modify text just inserted from a message to be cited. @@ -1833,6 +1860,24 @@ prefix, and don't delete any headers." (unless modified (setq message-checksum (message-checksum)))))) +(defun message-yank-buffer (buffer) + "Insert BUFFER into the current buffer and quote it." + (interactive "bYank buffer: ") + (let ((message-reply-buffer buffer)) + (save-window-excursion + (message-yank-original)))) + +(defun message-buffers () + "Return a list of active message buffers." + (let (buffers) + (save-excursion + (dolist (buffer (buffer-list t)) + (set-buffer buffer) + (when (and (eq major-mode 'message-mode) + (null message-sent-message-via)) + (push (buffer-name buffer) buffers)))) + (nreverse buffers))) + (defun message-cite-original-without-signature () "Cite function in the standard Message manner." (let ((start (point)) @@ -2005,19 +2050,19 @@ the user from the mailer." elem sent) (while (and success (setq elem (pop alist))) - (when (and (or (not (funcall (cadr elem))) - (and (or (not (memq (car elem) - message-sent-message-via)) - (y-or-n-p - (format - "Already sent message via %s; resend? " - (car elem)))) - (setq success (funcall (caddr elem) arg))))) + (when (or (not (funcall (cadr elem))) + (and (or (not (memq (car elem) + message-sent-message-via)) + (y-or-n-p + (format + "Already sent message via %s; resend? " + (car elem)))) + (setq success (funcall (caddr elem) arg)))) (setq sent t))) + (unless (or sent (not success)) + (error "No methods specified to send by")) (when (and success sent) (message-do-fcc) - ;;(when (fboundp 'mail-hist-put-headers-into-history) - ;; (mail-hist-put-headers-into-history)) (save-excursion (run-hooks 'message-sent-hook)) (message "Sending...done") @@ -2110,6 +2155,9 @@ the user from the mailer." (message-encode-message-body) (save-restriction (message-narrow-to-headers) + ;; We (re)generate the Lines header. + (when (memq 'Lines message-required-mail-headers) + (message-generate-headers '(Lines))) ;; Remove some headers. (message-remove-header message-ignored-mail-headers t) (mail-encode-encoded-word-buffer)) @@ -2129,7 +2177,7 @@ the user from the mailer." (defun message-send-mail-with-sendmail () "Send off the prepared buffer with sendmail." (let ((errbuf (if message-interactive - (generate-new-buffer " sendmail errors") + (message-generate-new-buffer-clone-locals " sendmail errors") 0)) resend-to-addresses delimline) (let ((case-fold-search t)) @@ -2166,7 +2214,7 @@ the user from the mailer." ;; But some systems are more broken with -f, so ;; we'll let users override this. (if (null message-sendmail-f-is-evil) - (list "-f" (user-login-name))) + (list "-f" (message-make-address))) ;; These mean "report errors by mail" ;; and "deliver in background". (if (null message-interactive) '("-oem" "-odb")) @@ -2288,6 +2336,9 @@ to find out how to use this." ;; Remove some headers. (save-restriction (message-narrow-to-headers) + ;; We (re)generate the Lines header. + (when (memq 'Lines message-required-mail-headers) + (message-generate-headers '(Lines))) ;; Remove some headers. (message-remove-header message-ignored-news-headers t) (let ((mail-parse-charset message-posting-charset)) @@ -2340,6 +2391,15 @@ to find out how to use this." (defun message-check-news-header-syntax () (and + ;; Check Newsgroups header. + (message-check 'newsgroyps + (let ((group (message-fetch-field "newsgroups"))) + (or + (and group + (not (string-match "\\`[ \t]*\\'" group))) + (ignore + (message + "The newsgroups field is empty or missing. Posting is denied."))))) ;; Check the Subject header. (message-check 'subject (let* ((case-fold-search t) @@ -2502,12 +2562,15 @@ to find out how to use this." (message-check 'from (let* ((case-fold-search t) (from (message-fetch-field "from")) - (ad (nth 1 (mail-extract-address-components from)))) + ad) (cond ((not from) (message "There is no From line. Posting is denied.") nil) - ((or (not (string-match "@[^\\.]*\\." ad)) ;larsi@ifi + ((or (not (string-match + "@[^\\.]*\\." + (setq ad (nth 1 (mail-extract-address-components + from))))) ;larsi@ifi (string-match "\\.\\." ad) ;larsi@ifi..uio (string-match "@\\." ad) ;larsi@.ifi.uio (string-match "\\.$" ad) ;larsi@ifi.uio. @@ -2685,7 +2748,7 @@ If NOW, use that time instead." parse-time-months)))) (format-time-string "%Y %H:%M:%S " now) ;; We do all of this because XEmacs doesn't have the %z spec. - (format "%s%02d%02d" sign (/ zone 3600) (% zone 3600))))) + (format "%s%02d%02d" sign (/ zone 3600) (/ (% zone 3600) 60))))) (defun message-make-message-id () "Make a unique Message-ID." @@ -3116,7 +3179,7 @@ Headers already prepared in the buffer are not modified." (defun message-fill-header (header value) (let ((begin (point)) - (fill-column 990) + (fill-column 78) (fill-prefix "\t")) (insert (capitalize (symbol-name header)) ": " @@ -3135,23 +3198,60 @@ Headers already prepared in the buffer are not modified." (replace-match " " t t)) (goto-char (point-max))))) +(defun message-shorten-1 (list cut surplus) + ;; Cut SURPLUS elements out of LIST, beginning with CUTth one. + (setcdr (nthcdr (- cut 2) list) + (nthcdr (+ (- cut 2) surplus 1) list))) + (defun message-shorten-references (header references) - "Limit REFERENCES to be shorter than 988 characters." - (let ((max 988) - (cut 4) + "Trim REFERENCES to be less than 31 Message-ID long, and fold them. +If folding is disallowed, also check that the REFERENCES are less +than 988 characters long, and if they are not, trim them until they are." + (let ((maxcount 31) + (count 0) + (cut 6) refs) (with-temp-buffer (insert references) (goto-char (point-min)) + ;; Cons a list of valid references. (while (re-search-forward "<[^>]+>" nil t) (push (match-string 0) refs)) - (setq refs (nreverse refs)) - (while (> (length (mapconcat 'identity refs " ")) max) - (when (< (length refs) (1+ cut)) - (decf cut)) - (setcdr (nthcdr cut refs) (cddr (nthcdr cut refs))))) - (insert (capitalize (symbol-name header)) ": " - (mapconcat 'identity refs " ") "\n"))) + (setq refs (nreverse refs) + count (length refs))) + + ;; If the list has more than MAXCOUNT elements, trim it by + ;; removing the CUTth element and the required number of + ;; elements that follow. + (when (> count maxcount) + (let ((surplus (- count maxcount))) + (message-shorten-1 refs cut surplus) + (decf count surplus))) + + ;; If folding is disallowed, make sure the total length (including + ;; the spaces between) will be less than MAXSIZE characters. + (when message-cater-to-broken-inn + (let ((maxsize 988) + (totalsize (+ (apply #'+ (mapcar #'length refs)) + (1- count))) + (surplus 0) + (ptr (nthcdr (1- cut) refs))) + ;; Decide how many elements to cut off... + (while (> totalsize maxsize) + (decf totalsize (1+ (length (car ptr)))) + (incf surplus) + (setq ptr (cdr ptr))) + ;; ...and do it. + (when (> surplus 0) + (message-shorten-1 refs cut surplus)))) + + ;; Finally, collect the references back into a string and insert + ;; it into the buffer. + (let ((refstring (mapconcat #'identity refs " "))) + (if message-cater-to-broken-inn + (insert (capitalize (symbol-name header)) ": " + refstring "\n") + (message-fill-header header refstring))))) (defun message-position-point () "Move point to where the user probably wants to find it." @@ -3376,6 +3476,7 @@ OTHER-HEADERS is an alist of header/value pairs." from subject date reply-to to cc references message-id follow-to (inhibit-point-motion-hooks t) + (message-this-is-mail t) mct never-mct gnus-warning) (save-restriction (message-narrow-to-head) @@ -3438,8 +3539,9 @@ OTHER-HEADERS is an alist of header/value pairs." (while (re-search-forward "[ \t]+" nil t) (replace-match " " t t)) ;; Remove addresses that match `rmail-dont-reply-to-names'. - (insert (prog1 (rmail-dont-reply-to (buffer-string)) - (erase-buffer))) + (let ((rmail-dont-reply-to-names message-dont-reply-to-names)) + (insert (prog1 (rmail-dont-reply-to (buffer-string)) + (erase-buffer)))) (goto-char (point-min)) ;; Perhaps Mail-Copies-To: never removed the only address? (when (eobp) @@ -3784,15 +3886,29 @@ Optional NEWS will use news to forward instead of mail." ;; Put point where we want it before inserting the forwarded ;; message. (message-goto-body) - (insert "\n\n<#part type=message/rfc822 disposition=inline>\n") - (mml-insert-buffer cur) - (insert "<#/part>\n") + (if message-forward-as-mime + (insert "\n\n<#part type=message/rfc822 disposition=inline>\n") + (insert "\n\n")) + (let ((b (point)) + e) + (mml-insert-buffer cur) + (setq e (point)) + (and message-forward-as-mime + (insert "<#/part>\n")) + (when (and (not current-prefix-arg) + message-forward-ignored-headers) + (save-restriction + (narrow-to-region b e) + (goto-char b) + (narrow-to-region (point) (or (search-forward "\n\n" nil t) (point))) + (message-remove-header message-forward-ignored-headers t)))) (message-position-point))) ;;;###autoload (defun message-resend (address) "Resend the current article to ADDRESS." - (interactive "sResend message to: ") + (interactive + (list (message-read-from-minibuffer "Resend message to: "))) (message "Resending message to %s..." address) (save-excursion (let ((cur (current-buffer)) @@ -3844,33 +3960,27 @@ This only makes sense if the current message is a bounce message than contains some mail you have written which has been bounced back to you." (interactive) - (let ((cur (current-buffer)) + (let ((handles (mm-dissect-buffer t)) boundary) (message-pop-to-buffer (message-buffer-name "bounce")) - (insert-buffer-substring cur) - (undo-boundary) - (message-narrow-to-head) - (if (and (message-fetch-field "Mime-Version") - (setq boundary (message-fetch-field "Content-Type"))) - (if (string-match "boundary=\"\\([^\"]+\\)\"" boundary) - (setq boundary (concat (match-string 1 boundary) " *\n" - "Content-Type: message/rfc822")) - (setq boundary nil))) - (widen) - (goto-char (point-min)) - (search-forward "\n\n" nil t) - (or (and boundary - (re-search-forward boundary nil t) - (forward-line 2)) - (and (re-search-forward message-unsent-separator nil t) - (forward-line 1)) - (re-search-forward "^Return-Path:.*\n" nil t)) - ;; We remove everything before the bounced mail. - (delete-region - (point-min) - (if (re-search-forward "^[^ \n\t]+:" nil t) - (match-beginning 0) - (point))) + (if (stringp (car handles)) + ;; This is a MIME bounce. + (mm-insert-part (car (last handles))) + ;; This is a non-MIME bounce, so we try to remove things + ;; manually. + (mm-insert-part handles) + (undo-boundary) + (goto-char (point-min)) + (search-forward "\n\n" nil t) + (or (and (re-search-forward message-unsent-separator nil t) + (forward-line 1)) + (re-search-forward "^Return-Path:.*\n" nil t)) + ;; We remove everything before the bounced mail. + (delete-region + (point-min) + (if (re-search-forward "^[^ \n\t]+:" nil t) + (match-beginning 0) + (point)))) (save-restriction (message-narrow-to-head) (message-remove-header message-ignored-bounced-headers t) @@ -4069,20 +4179,22 @@ regexp varstr." (let ((oldbuf (current-buffer))) (save-excursion (set-buffer (generate-new-buffer name)) - (message-clone-locals oldbuf) + (message-clone-locals oldbuf varstr) (current-buffer)))) -(defun message-clone-locals (buffer) +(defun message-clone-locals (buffer &optional varstr) "Clone the local variables from BUFFER to the current buffer." (let ((locals (save-excursion (set-buffer buffer) (buffer-local-variables))) - (regexp "^gnus\\|^nn\\|^message")) + (regexp "^gnus\\|^nn\\|^message\\|^user-mail-address")) (mapcar (lambda (local) (when (and (consp local) (car local) - (string-match regexp (symbol-name (car local)))) + (string-match regexp (symbol-name (car local))) + (or (null varstr) + (string-match varstr (symbol-name (car local))))) (ignore-errors (set (make-local-variable (car local)) (cdr local))))) @@ -4128,7 +4240,7 @@ regexp varstr." (delete-char 1) (search-forward "\n\n") (setq lines (buffer-substring (point-min) (1- (point)))) - (delete-region (point-min) (point)))))) + (delete-region (point-min) (point)))))) (save-restriction (message-narrow-to-headers-or-head) (message-remove-header "Mime-Version") @@ -4153,6 +4265,15 @@ regexp varstr." (forward-line 1) (insert "Content-Type: text/plain; charset=us-ascii\n"))))) +(defun message-read-from-minibuffer (prompt) + "Read from the minibuffer while providing abbrev expansion." + (if (fboundp 'mail-abbrevs-setup) + (let ((mail-abbrev-mode-regexp "") + (minibuffer-setup-hook 'mail-abbrevs-setup)) + (read-from-minibuffer prompt))) + (let ((minibuffer-setup-hook 'mail-abbrev-minibuffer-setup-hook)) + (read-string prompt))) + (provide 'message) (run-hooks 'message-load-hook)