X-Git-Url: https://cgit.sxemacs.org/?a=blobdiff_plain;f=lisp%2Fmessage.el;h=c2485862f5bb6cac2d43ccdcf39c790311021289;hb=2d356801ab1a350e4f51424464e78ebf0f88f59e;hp=07e358551f623b7e4d6cdd6a07040b058a6c84d1;hpb=af948193f92fd87f0a7f488ed24d5e05e976b270;p=gnus diff --git a/lisp/message.el b/lisp/message.el index 07e358551..c2485862f 100644 --- a/lisp/message.el +++ b/lisp/message.el @@ -34,12 +34,12 @@ (eval-when-compile (require 'cl) (defvar gnus-message-group-art) - (defvar gnus-list-identifiers) ; gnus-sum is required where necessary - (require 'hashcash)) + (defvar gnus-list-identifiers)) ; gnus-sum is required where necessary +(require 'hashcash) (require 'canlock) (require 'mailheader) -(require 'nnheader) (require 'gmm-utils) +(require 'nnheader) ;; This is apparently necessary even though things are autoloaded. ;; Because we dynamically bind mail-abbrev-mode-regexp, we'd better ;; require mailabbrev here. @@ -154,7 +154,6 @@ If this variable is nil, no such courtesy message will be added." :group 'message-interface :type 'regexp) -;;;###autoload (defcustom message-from-style 'default "*Specifies how \"From\" headers look. @@ -188,14 +187,13 @@ To disable checking of long signatures, for instance, add 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', `quoting-style', `redirected-followup', `signature', -`approved', `sender', `empty', `empty-headers', `message-id', `from', -`subject', `shorten-followup-to', `existing-newsgroups', -`buffer-file-name', `unchanged', `newsgroups', `reply-to', -`continuation-headers', `long-header-lines', `invisible-text' and -`illegible-text'." +Checks include `approved', `continuation-headers', `control-chars', +`empty', `existing-newsgroups', `from', `illegible-text', +`invisible-text', `long-header-lines', `long-lines', `message-id', +`multiple-headers', `new-text', `newsgroups', `quoting-style', +`repeated-newsgroups', `reply-to', `sender', `sendsys', `shoot', +`shorten-followup-to', `signature', `size', `subject', `subject-cmsg' +and `valid-newsgroups'." :group 'message-news :type '(repeat sexp)) ; Fixme: improve this @@ -210,7 +208,7 @@ Also see `message-required-news-headers' and :link '(custom-manual "(message)Message Headers") :type '(repeat sexp)) -(defcustom message-draft-headers '(References From) +(defcustom message-draft-headers '(References From Date) "*Headers to be generated when saving a draft message." :version "22.1" :group 'message-news @@ -410,7 +408,6 @@ for `message-cross-post-insert-note'." ;;; End of variables adopted from `message-utils.el'. -;;;###autoload (defcustom message-signature-separator "^-- *$" "Regexp matching the signature separator." :type 'regexp @@ -470,8 +467,14 @@ If t, use `message-user-organization-file'." :type '(choice string (const :tag "consult file" t))) -;;;###autoload -(defcustom message-user-organization-file "/usr/lib/news/organization" +(defcustom message-user-organization-file + (let (orgfile) + (dolist (f (list "/etc/organization" + "/etc/news/organization" + "/usr/lib/news/organization")) + (when (file-readable-p f) + (setq orgfile f))) + orgfile) "*Local news organization file." :type 'file :link '(custom-manual "(message)News Headers") @@ -589,7 +592,6 @@ Done before generating the new subject of a forward." :type 'string) ;; Useful to set in site-init.el -;;;###autoload (defcustom message-send-mail-function (let ((program (if (boundp 'sendmail-program) ;; see paths.el @@ -759,6 +761,14 @@ If this is nil, use `user-mail-address'. If it is the symbol :link '(custom-manual "(message)Mail Variables") :group 'message-sending) +(defcustom message-sendmail-extra-arguments nil + "Additional arguments to `sendmail-program'." + ;; E.g. '("-a" "account") for msmtp + :version "23.0" ;; No Gnus + :type '(repeat string) + ;; :link '(custom-manual "(message)Mail Variables") + :group 'message-sending) + ;; qmail-related stuff (defcustom message-qmail-inject-program "/var/qmail/bin/qmail-inject" "Location of the qmail-inject program." @@ -864,19 +874,51 @@ the signature is inserted." :version "22.1" :group 'message-various) -;;;###autoload (defcustom message-citation-line-function 'message-insert-citation-line "*Function called to insert the \"Whomever writes:\" line. +Predefined functions include `message-insert-citation-line' and +`message-insert-formated-citation-line' (see the variable +`message-citation-line-format'). + Note that Gnus provides a feature where the reader can click on `writes:' to hide the cited text. If you change this line too much, people who read your message will have to change their Gnus configuration. See the variable `gnus-cite-attribution-suffix'." - :type 'function + :type '(choice + (function-item :tag "plain" message-insert-citation-line) + (function-item :tag "formatted" message-insert-formated-citation-line) + (function :tag "Other")) :link '(custom-manual "(message)Insertion Variables") :group 'message-insertion) -;;;###autoload +(defcustom message-citation-line-format "On %a, %b %d %Y, %N wrote:" + "Format of the \"Whomever writes:\" line. + +The string is formatted using `format-spec'. The following +constructs are replaced: + + %f The full From, e.g. \"John Doe \". + %n The mail address, e.g. \"john.doe@example.invalid\". + %N The real name if present, e.g.: \"John Doe\", else fall + back to the mail address. + %F The first name if present, e.g.: \"John\". + %L The last name if present, e.g.: \"Doe\". + +All other format specifiers are passed to `format-time-string' +which is called using the date from the article your replying to. +Extracting the first (%F) and last name (%L) is done +heuristically, so you should always check it yourself. + +Please also read the note in the documentation of +`message-citation-line-function'." + :type '(choice (const :tag "Plain" "%f writes:") + (const :tag "Include date" "On %a, %b %d %Y, %n wrote:") + string) + :link '(custom-manual "(message)Insertion Variables") + :version "23.0" ;; No Gnus + :group 'message-insertion) + (defcustom message-yank-prefix "> " "*Prefix inserted on the lines of yanked messages. Fix `message-cite-prefix-regexp' if it is set to an abnormal value. @@ -909,7 +951,6 @@ Used by `message-yank-original' via `message-yank-cite'." :link '(custom-manual "(message)Insertion Variables") :type 'integer) -;;;###autoload (defcustom message-cite-function 'message-cite-original "*Function for citing an original message. Predefined functions include `message-cite-original' and @@ -922,7 +963,6 @@ Note that these functions use `mail-citation-hook' if that is non-nil." :link '(custom-manual "(message)Insertion Variables") :group 'message-insertion) -;;;###autoload (defcustom message-indent-citation-function 'message-indent-citation "*Function for modifying a citation just inserted in the mail buffer. This can also be a list of functions. Each function can find the @@ -932,7 +972,6 @@ point and mark around the citation text as modified." :link '(custom-manual "(message)Insertion Variables") :group 'message-insertion) -;;;###autoload (defcustom message-signature t "*String to be inserted at the end of the message buffer. If t, the `message-signature-file' file will be inserted instead. @@ -942,7 +981,6 @@ If a form, the result from the form will be used instead." :link '(custom-manual "(message)Insertion Variables") :group 'message-insertion) -;;;###autoload (defcustom message-signature-file "~/.signature" "*Name of file containing the text inserted at end of message buffer. Ignored if the named file doesn't exist. @@ -951,7 +989,6 @@ If nil, don't insert a signature." :link '(custom-manual "(message)Insertion Variables") :group 'message-insertion) -;;;###autoload (defcustom message-signature-insert-empty-line t "*If non-nil, insert an empty line before the signature separator." :version "22.1" @@ -1081,14 +1118,25 @@ the prefix.") (defcustom message-mail-alias-type 'abbrev "*What alias expansion type to use in Message buffers. -The default is `abbrev', which uses mailabbrev. nil switches -mail aliases off." +The default is `abbrev', which uses mailabbrev. `ecomplete' uses +an electric completion mode. nil switches mail aliases off. +This can also be a list of values." :group 'message :link '(custom-manual "(message)Mail Aliases") :type '(choice (const :tag "Use Mailabbrev" abbrev) (const :tag "Use ecomplete" ecomplete) (const :tag "No expansion" nil))) +(defcustom message-self-insert-commands '(self-insert-command) + "List of `self-insert-command's used to trigger ecomplete. +When one of those commands is invoked to enter a character in To or Cc +header, ecomplete will suggest the candidates of recipients (see also +`message-mail-alias-type'). If you use some tool to enter non-ASCII +text and it replaces `self-insert-command' with the other command, e.g. +`egg-self-insert-command', you may want to add it to this list." + :group 'message-various + :type '(repeat function)) + (defcustom message-auto-save-directory (file-name-as-directory (nnheader-concat message-directory "drafts")) "*Directory where Message auto-saves buffers if Gnus isn't running. @@ -1108,13 +1156,28 @@ If nil, you might be asked to input the charset." (defcustom message-dont-reply-to-names (and (boundp 'rmail-dont-reply-to-names) rmail-dont-reply-to-names) - "*A regexp specifying addresses to prune when doing wide replies. -A value of nil means exclude your own user name only." + "*Addresses to prune when doing wide replies. +This can be a regexp or a list of regexps. Also, a value of nil means +exclude your own user name only." :version "21.1" :group 'message :link '(custom-manual "(message)Wide Reply") :type '(choice (const :tag "Yourself" nil) - regexp)) + regexp + (repeat :tag "Regexp List" regexp))) + +;; #### FIXME: this might become a generally usefull function at some point +;; --dlv. +(defsubst message-dont-reply-to-names () + "Potentially convert a list of regexps into a single one." + (cond ((null message-dont-reply-to-names) + nil) + ((stringp message-dont-reply-to-names) + message-dont-reply-to-names) + ((listp message-dont-reply-to-names) + (mapconcat (lambda (elt) (concat "\\(" elt "\\)")) + message-dont-reply-to-names + "\\|")))) (defvar message-shoot-gnksa-feet nil "*A list of GNKSA feet you are allowed to shoot. @@ -1132,7 +1195,8 @@ candidates: (or (not (listp message-shoot-gnksa-feet)) (memq feature message-shoot-gnksa-feet))) -(defcustom message-hidden-headers "^References:" +(defcustom message-hidden-headers '("^References:" "^Face:" "^X-Face:" + "^X-Draft-From:") "Regexp of headers to be hidden when composing new messages. This can also be a list of regexps to match headers. Or a list starting with `not' and followed by regexps." @@ -1513,12 +1577,18 @@ functionality to work." (const :tag "Never" nil) (const :tag "Always" t))) -(defcustom message-generate-hashcash nil +(defcustom message-generate-hashcash (if (executable-find "hashcash") t) "*Whether to generate X-Hashcash: headers. +If `t', always generate hashcash headers. If `opportunistic', +only generate hashcash headers if it can be done without the user +waiting (i.e., only asynchronously). + You must have the \"hashcash\" binary installed, see `hashcash-path'." :group 'message-headers :link '(custom-manual "(message)Mail Headers") - :type 'boolean) + :type '(choice (const :tag "Always" t) + (const :tag "Never" nil) + (const :tag "Opportunistic" opportunistic))) ;;; Internal variables. @@ -1633,17 +1703,22 @@ You must have the \"hashcash\" binary installed, see `hashcash-path'." (defvar message-send-mail-real-function nil "Internal send mail function.") -(defvar message-bogus-system-names "^localhost\\." +(defvar message-bogus-system-names "^localhost\\.\\|\\.local$" "The regexp of bogus system names.") (defcustom message-valid-fqdn-regexp (concat "[a-z0-9][-.a-z0-9]+\\." ;; [hostname.subdomain.]domain. ;; valid TLDs: - "\\([a-z][a-z]" ;; two letter country TDLs - "\\|biz\\|com\\|edu\\|gov\\|int\\|mil\\|net\\|org" - "\\|aero\\|coop\\|info\\|name\\|museum" - "\\|arpa\\|pro\\|uucp\\|bitnet\\|bofh" ;; old style? - "\\)") + "\\([a-z][a-z]\\|" ;; two letter country TDLs + "aero\\|arpa\\|bitnet\\|biz\\|bofh\\|" + "cat\\|com\\|coop\\|edu\\|gov\\|" + "info\\|int\\|jobs\\|" + "mil\\|mobi\\|museum\\|name\\|net\\|" + "org\\|pro\\|travel\\|uucp\\)") + ;; http://en.wikipedia.org/wiki/List_of_Internet_top-level_domains + ;; http://en.wikipedia.org/wiki/GTLD + ;; `in the process of being approved': .asia .post .tel .sex + ;; "dead" nato bitnet uucp "Regular expression that matches a valid FQDN." ;; see also: gnus-button-valid-fqdn-regexp :version "22.1" @@ -1837,6 +1912,96 @@ see `message-narrow-to-headers-or-head'." (substring subject (match-end 0)) subject)) +(defcustom message-replacement-char "." + "Replacement character used instead of unprintable or not decodable chars." + :group 'message-various + :version "22.1" ;; Gnus 5.10.9 + :type '(choice string + (const ".") + (const "?"))) + +;; FIXME: We also should call `message-strip-subject-encoded-words' +;; when forwarding. Probably in `message-make-forward-subject' and +;; `message-forward-make-body'. + +(defun message-strip-subject-encoded-words (subject) + "Fix non-decodable words in SUBJECT." + ;; Cf. `gnus-simplify-subject-fully'. + (let* ((case-fold-search t) + (replacement-chars (format "[%s%s%s]" + message-replacement-char + message-replacement-char + message-replacement-char)) + (enc-word-re "=\\?\\([^?]+\\)\\?\\([QB]\\)\\?\\([^?]+\\)\\(\\?=\\)") + cs-string + (have-marker + (with-temp-buffer + (insert subject) + (goto-char (point-min)) + (when (re-search-forward enc-word-re nil t) + (setq cs-string (match-string 1))))) + cs-coding q-or-b word-beg word-end) + (if (or (not have-marker) ;; No encoded word found... + ;; ... or double encoding was correct: + (and (stringp cs-string) + (setq cs-string (downcase cs-string)) + (mm-coding-system-p (intern cs-string)) + (not (prog1 + (y-or-n-p + (format "\ +Decoded Subject \"%s\" +contains a valid encoded word. Decode again? " + subject)) + (setq cs-coding (intern cs-string)))))) + subject + (with-temp-buffer + (insert subject) + (goto-char (point-min)) + (while (re-search-forward enc-word-re nil t) + (setq cs-string (downcase (match-string 1)) + q-or-b (match-string 2) + word-beg (match-beginning 0) + word-end (match-end 0)) + (setq cs-coding + (if (mm-coding-system-p (intern cs-string)) + (setq cs-coding (intern cs-string)) + nil)) + ;; No double encoded subject? => bogus charset. + (unless cs-coding + (setq cs-coding + (mm-read-coding-system + (format "\ +Decoded Subject \"%s\" +contains an encoded word. The charset `%s' is unknown or invalid. +Hit RET to replace non-decodable characters with \"%s\" or enter replacement +charset: " + subject cs-string message-replacement-char))) + (if cs-coding + (replace-match (concat "=?" (symbol-name cs-coding) + "?\\2?\\3\\4\\5")) + (save-excursion + (goto-char word-beg) + (re-search-forward "=\\?\\([^?]+\\)\\?\\([QB]\\)\\?" word-end t) + (replace-match "") + ;; QP or base64 + (if (string-match "\\`Q\\'" q-or-b) + ;; QP + (progn + (message "Replacing non-decodable characters with \"%s\"." + message-replacement-char) + (while (re-search-forward "\\(=[A-F0-9][A-F0-9]\\)+" + word-end t) + (replace-match message-replacement-char))) + ;; base64 + (message "Replacing non-decodable characters with \"%s\"." + replacement-chars) + (re-search-forward "[^?]+" word-end t) + (replace-match replacement-chars)) + (re-search-forward "\\?=") + (replace-match ""))))) + (rfc2047-decode-region (point-min) (point-max)) + (buffer-string))))) + ;;; Start of functions adopted from `message-utils.el'. (defun message-strip-subject-trailing-was (subject) @@ -2513,11 +2678,17 @@ These properties are essential to work, so we should never strip them." (get-text-property pos 'egg-lang) (get-text-property pos 'egg-start))))) +(defsubst message-mail-alias-type-p (type) + (if (atom message-mail-alias-type) + (eq message-mail-alias-type type) + (memq type message-mail-alias-type))) + (defun message-strip-forbidden-properties (begin end &optional old-length) "Strip forbidden properties between BEGIN and END, ignoring the third arg. This function is intended to be called from `after-change-functions'. See also `message-forbidden-properties'." - (when (eq message-mail-alias-type 'ecomplete) + (when (and (message-mail-alias-type-p 'ecomplete) + (memq this-command message-self-insert-commands)) (message-display-abbrev)) (when (and message-strip-special-text-properties (message-tamago-not-in-use-p begin)) @@ -2609,12 +2780,12 @@ M-RET `message-newline-and-reformat' (break the line and reformat)." nil 'local) ;; Allow mail alias things. (cond - ((eq message-mail-alias-type 'abbrev) + ((message-mail-alias-type-p 'abbrev) (if (fboundp 'mail-abbrevs-setup) (mail-abbrevs-setup) (if (fboundp 'mail-aliases-setup) ; warning avoidance (mail-aliases-setup)))) - ((eq message-mail-alias-type 'ecomplete) + ((message-mail-alias-type-p 'ecomplete) (ecomplete-setup))) (unless buffer-file-name (message-set-auto-save-file-name)) @@ -2752,17 +2923,17 @@ M-RET `message-newline-and-reformat' (break the line and reformat)." (or (search-forward (concat "\n" mail-header-separator "\n") nil t) (search-forward-regexp "[^:]+:\\([^\n]\\|\n[ \t]\\)+\n\n" nil t))) +(defun message-in-body-p () + "Return t if point is in the message body." + (let ((body (save-excursion (message-goto-body) (point)))) + (>= (point) body))) + (defun message-goto-eoh () "Move point to the end of the headers." (interactive) (message-goto-body) (forward-line -1)) -(defun message-in-body-p () - "Return t if point is in the message body." - (let ((body (save-excursion (message-goto-body) (point)))) - (>= (point) body))) - (defun message-goto-signature () "Move point to the beginning of the message signature. If there is no signature in the article, go to the end and @@ -3040,15 +3211,11 @@ Message buffers and is not meant to be called directly." (message-newline-and-reformat arg t)) t)) -;; Is it better to use `mail-header-end'? (defun message-point-in-header-p () "Return t if point is in the header." (save-excursion - (let ((p (point))) - (goto-char (point-min)) - (not (re-search-forward - (concat "^" (regexp-quote mail-header-separator) "\n") - p t))))) + (not (re-search-backward + (concat "^" (regexp-quote mail-header-separator) "\n") nil t)))) (defun message-do-auto-fill () "Like `do-auto-fill', but don't fill in message header." @@ -3194,17 +3361,17 @@ text was killed." (substring table ?a (+ ?a n)) (substring table (+ ?a 26) 255)))) -(defun message-caesar-buffer-body (&optional rotnum) +(defun message-caesar-buffer-body (&optional rotnum wide) "Caesar rotate all letters in the current buffer by 13 places. Used to encode/decode possibly offensive messages (commonly in rec.humor). With prefix arg, specifies the number of places to rotate each letter forward. -Mail and USENET news headers are not rotated." +Mail and USENET news headers are not rotated unless WIDE is non-nil." (interactive (if current-prefix-arg (list (prefix-numeric-value current-prefix-arg)) (list nil))) (save-excursion (save-restriction - (when (message-goto-body) + (when (and (not wide) (message-goto-body)) (narrow-to-region (point) (point-max))) (message-caesar-region (point-min) (point-max) rotnum)))) @@ -3251,14 +3418,15 @@ Numeric argument means justify as well." (let ((fill-prefix message-yank-prefix)) (fill-individual-paragraphs (point) (point-max) justifyp)))) -(defun message-indent-citation () +(defun message-indent-citation (&optional start end yank-only) "Modify text just inserted from a message to be cited. The inserted text should be the region. When this function returns, the region is again around the modified text. Normally, indent each nonblank line `message-indentation-spaces' spaces. However, if `message-yank-prefix' is non-nil, insert that prefix on each line." - (let ((start (point))) + (unless start (setq start (point))) + (unless yank-only ;; Remove unwanted headers. (when message-ignored-cited-headers (let (all-removed) @@ -3286,21 +3454,32 @@ However, if `message-yank-prefix' is non-nil, insert that prefix on each line." (insert "\n")) (while (and (zerop (forward-line -1)) (looking-at "$")) - (message-delete-line)) - ;; Do the indentation. - (if (null message-yank-prefix) - (indent-rigidly start (mark t) message-indentation-spaces) - (save-excursion - (goto-char start) - (while (< (point) (mark t)) - (cond ((looking-at ">") - (insert message-yank-cited-prefix)) - ((looking-at "^$") - (insert message-yank-empty-prefix)) - (t - (insert message-yank-prefix))) - (forward-line 1)))) - (goto-char start))) + (message-delete-line))) + ;; Do the indentation. + (if (null message-yank-prefix) + (indent-rigidly start (or end (mark t)) message-indentation-spaces) + (save-excursion + (goto-char start) + (while (< (point) (or end (mark t))) + (cond ((looking-at ">") + (insert message-yank-cited-prefix)) + ((looking-at "^$") + (insert message-yank-empty-prefix)) + (t + (insert message-yank-prefix))) + (forward-line 1)))) + (goto-char start)) + +(defvar message-cite-reply-above nil + "If non-nil, start own text above the quote. + +Note: Top posting is bad netiquette. Don't use it unless you +really must. You probably want to set variable only for specific +groups, e.g. using `gnus-posting-styles': + + (eval (set (make-local-variable 'message-cite-reply-above) t)) + +This variable has no effect in news postings.") (defun message-yank-original (&optional arg) "Insert the message being replied to, if any. @@ -3313,16 +3492,36 @@ 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") - (let ((modified (buffer-modified-p))) + (let ((modified (buffer-modified-p)) + body-text) (when (and message-reply-buffer message-cite-function) + (when message-cite-reply-above + (if (and (not (message-news-p)) + (or (eq message-cite-reply-above 'is-evil) + (y-or-n-p "\ +Top posting is bad netiquette. Please don't top post unless you really must. +Really top post? "))) + (save-excursion + (setq body-text + (buffer-substring (message-goto-body) + (point-max))) + (delete-region (message-goto-body) (point-max))) + (set (make-local-variable 'message-cite-reply-above) nil))) (delete-windows-on message-reply-buffer t) (push-mark (save-excursion (insert-buffer-substring message-reply-buffer) (point))) (unless arg (funcall message-cite-function)) - (message-exchange-point-and-mark) + (if message-cite-reply-above + (progn + (message-goto-body) + (insert body-text) + (newline) + (message-goto-body) + (message-exchange-point-and-mark)) + (message-exchange-point-and-mark)) (unless (bolp) (insert ?\n)) (unless modified @@ -3375,7 +3574,7 @@ This function uses `mail-citation-hook' if that is non-nil." (setq x-no-archive (message-fetch-field "x-no-archive")) (vector 0 (or (message-fetch-field "subject") "none") - (message-fetch-field "from") + (or (message-fetch-field "from") "nobody") (message-fetch-field "date") (message-fetch-field "message-id" t) (message-fetch-field "references") @@ -3407,12 +3606,100 @@ This function uses `mail-citation-hook' if that is non-nil." (undo-boundary) (delete-region (point) (mark t)) (insert "> [Quoted text removed due to X-No-Archive]\n") + (push-mark) (forward-line -1))))) (defun message-cite-original () "Cite function in the standard Message manner." (message-cite-original-1 nil)) +(defun message-insert-formated-citation-line (&optional from date) + "Function that inserts a formated citation line. + +See `message-citation-line-format'." + ;; The optional args are for testing/debugging. They will disappear later. + ;; Example: + ;; (with-temp-buffer + ;; (message-insert-formated-citation-line + ;; "John Doe " + ;; (current-time)) + ;; (buffer-string)) + (when (or message-reply-headers (and from date)) + (unless from + (setq from (mail-header-from message-reply-headers))) + (let* ((data (condition-case () + (funcall (if (boundp gnus-extract-address-components) + gnus-extract-address-components + 'mail-extract-address-components) + from) + (error nil))) + (name (car data)) + (fname name) + (lname name) + (net (car (cdr data))) + (name-or-net (or (car data) + (car (cdr data)) from)) + (replydate + (or + date + ;; We need Gnus functionality if the user wants date or time from + ;; the original article: + (when (string-match "%[^fnNFL]" message-citation-line-format) + (autoload 'gnus-date-get-time "gnus-util") + (gnus-date-get-time (mail-header-date message-reply-headers))))) + (flist + (let ((i ?A) lst) + (when (stringp name) + ;; Guess first name and last name: + (cond ((string-match + "\\`\\(\\w\\|[-.]\\)+ \\(\\w\\|[-.]\\)+\\'" name) + (setq fname (nth 0 (split-string name "[ \t]+")) + lname (nth 1 (split-string name "[ \t]+")))) + ((string-match + "\\`\\(\\w\\|[-.]\\)+, \\(\\w\\|[-.]\\)+\\'" name) + (setq fname (nth 1 (split-string name "[ \t,]+")) + lname (nth 0 (split-string name "[ \t,]+")))) + ((string-match + "\\`\\(\\w\\|[-.]\\)+\\'" name) + (setq fname name + lname "")))) + ;; The following letters are not used in `format-time-string': + (push ?E lst) (push "" lst) + (push ?F lst) (push fname lst) + ;; We might want to use "" instead of "" later. + (push ?J lst) (push "" lst) + (push ?K lst) (push "" lst) + (push ?L lst) (push lname lst) + (push ?N lst) (push name-or-net lst) + (push ?O lst) (push "" lst) + (push ?P lst) (push "

" lst) + (push ?Q lst) (push "" lst) + (push ?f lst) (push from lst) + (push ?i lst) (push "" lst) + (push ?n lst) (push net lst) + (push ?o lst) (push "" lst) + (push ?q lst) (push "" lst) + (push ?t lst) (push "" lst) + (push ?v lst) (push "" lst) + ;; Delegate the rest to `format-time-string': + (while (<= i ?z) + (when (and (not (memq i lst)) + ;; Skip (Z,a) + (or (<= i ?Z) + (>= i ?a))) + (push i lst) + (push (condition-case nil + (progn (format-time-string (format "%%%c" i) + replydate)) + (format ">%c<" i)) + lst)) + (setq i (1+ i))) + (reverse lst))) + (spec (apply 'format-spec-make flist))) + (insert (format-spec message-citation-line-format spec))) + (newline) + (newline))) + (defun message-cite-original-without-signature () "Cite function in the standard Message manner. This function strips off the signature from the original message." @@ -3604,7 +3891,7 @@ It should typically alter the sending method in some way or other." (run-hooks 'message-sent-hook)) (message "Sending...done") ;; Do ecomplete address snarfing. - (when (eq message-mail-alias-type 'ecomplete) + (when (message-mail-alias-type-p 'ecomplete) (message-put-addresses-in-ecomplete)) ;; Mark the buffer as unmodified and delete auto-save. (set-buffer-modified-p nil) @@ -3708,8 +3995,10 @@ not have PROP." (setq choice (gnus-multiple-choice "Non-printable characters found. Continue sending?" - '((?d "Remove non-printable characters and send") - (?r "Replace non-printable characters with dots and send") + `((?d "Remove non-printable characters and send") + (?r ,(format + "Replace non-printable characters with \"%s\" and send" + message-replacement-char)) (?i "Ignore non-printable characters and send") (?e "Continue editing")))) (if (eq choice ?e) @@ -3732,7 +4021,7 @@ not have PROP." (message-kill-all-overlays) (delete-char 1) (when (eq choice ?r) - (insert ".")))) + (insert message-replacement-char)))) (forward-char) (skip-chars-forward mm-7bit-chars)))))) @@ -3845,7 +4134,8 @@ not have PROP." (gnus-setup-posting-charset nil) message-posting-charset)) (headers message-required-mail-headers)) - (when message-generate-hashcash + (when (and message-generate-hashcash + (not (eq message-generate-hashcash 'opportunistic))) (message "Generating hashcash...") ;; Wait for calculations already started to finish... (hashcash-wait-async) @@ -3869,6 +4159,16 @@ not have PROP." (let ((message-deletable-headers (if news nil message-deletable-headers))) (message-generate-headers headers)) + ;; Check continuation headers. + (message-check 'continuation-headers + (goto-char (point-min)) + (while (re-search-forward "^[^ \t\n][^ \t\n:]*[ \t\n]" nil t) + (goto-char (match-beginning 0)) + (if (y-or-n-p "Fix continuation lines? ") + (insert " ") + (forward-line 1) + (unless (y-or-n-p "Send anyway? ") + (error "Failed to send the message"))))) ;; Let the user do all of the above. (run-hooks 'message-header-hook)) (unwind-protect @@ -3987,10 +4287,17 @@ If you always want Gnus to send messages in one piece, set 'call-process-region (append (list (point-min) (point-max) - (if (boundp 'sendmail-program) - sendmail-program - "/usr/lib/sendmail") + (cond ((boundp 'sendmail-program) + sendmail-program) + ((file-exists-p "/usr/sbin/sendmail") + "/usr/sbin/sendmail") + ((file-exists-p "/usr/lib/sendmail") + "/usr/lib/sendmail") + ((file-exists-p "/usr/ucblib/sendmail") + "/usr/ucblib/sendmail") + (t "fakemail")) nil errbuf nil "-oi") + message-sendmail-extra-arguments ;; Always specify who from, ;; since some systems have broken sendmails. ;; But some systems are more broken with -f, so @@ -4425,11 +4732,11 @@ Otherwise, generate and save a value for `canlock-password' first." (message-check 'continuation-headers (goto-char (point-min)) (let ((do-posting t)) - (while (re-search-forward "^[^ \t\n][^:\n]*$" nil t) + (while (re-search-forward "^[^ \t\n][^ \t\n:]*[ \t\n]" nil t) + (goto-char (match-beginning 0)) (if (y-or-n-p "Fix continuation lines? ") - (progn - (goto-char (match-beginning 0)) - (insert " ")) + (insert " ") + (forward-line 1) (unless (y-or-n-p "Send anyway? ") (setq do-posting nil)))) do-posting)) @@ -4990,8 +5297,8 @@ give as trustworthy answer as possible." (stringp message-user-fqdn) (string-match message-valid-fqdn-regexp message-user-fqdn) (not (string-match message-bogus-system-names message-user-fqdn))) + ;; `message-user-fqdn' seems to be valid message-user-fqdn) - ;; `message-user-fqdn' seems to be valid ((and (string-match message-valid-fqdn-regexp system-name) (not (string-match message-bogus-system-names system-name))) ;; `system-name' returned the right result. @@ -5616,7 +5923,7 @@ between beginning of field and beginning of line." (defun message-headers-to-generate (headers included-headers excluded-headers) "Return a list that includes all headers from HEADERS. -If INCLUDED-HEADERS is a list, just include those headers. If if is +If INCLUDED-HEADERS is a list, just include those headers. If it is t, include all headers. In any case, headers from EXCLUDED-HEADERS are not included." (let ((result nil) @@ -5876,7 +6183,7 @@ want to get rid of this query permanently."))) (while (string-match "[ \t][ \t]+" recipients) (setq recipients (replace-match " " t t recipients))) ;; Remove addresses that match `rmail-dont-reply-to-names'. - (let ((rmail-dont-reply-to-names message-dont-reply-to-names)) + (let ((rmail-dont-reply-to-names (message-dont-reply-to-names))) (setq recipients (rmail-dont-reply-to recipients))) ;; Perhaps "Mail-Copies-To: never" removed the only address? (if (string-equal recipients "") @@ -5922,6 +6229,39 @@ want to get rid of this query permanently."))) (push (cons 'Cc recipients) follow-to))) follow-to)) +(defcustom message-simplify-subject-functions + '(message-strip-list-identifiers + message-strip-subject-re + message-strip-subject-trailing-was + message-strip-subject-encoded-words) + "List of functions taking a string argument that simplify subjects. +The functions are applied when replying to a message. + +Useful functions to put in this list include: +`message-strip-list-identifiers', `message-strip-subject-re', +`message-strip-subject-trailing-was', and +`message-strip-subject-encoded-words'." + :version "22.1" ;; Gnus 5.10.9 + :group 'message-various + :type '(repeat function)) + +(defun message-simplify-subject (subject &optional functions) + "Return simplified SUBJECT." + (unless functions + ;; Simplify fully: + (setq functions message-simplify-subject-functions)) + (when (and (memq 'message-strip-list-identifiers functions) + gnus-list-identifiers) + (setq subject (message-strip-list-identifiers subject))) + (when (memq 'message-strip-subject-re functions) + (setq subject (concat "Re: " (message-strip-subject-re subject)))) + (when (and (memq 'message-strip-subject-trailing-was functions) + message-subject-trailing-was-query) + (setq subject (message-strip-subject-trailing-was subject))) + (when (memq 'message-strip-subject-encoded-words functions) + (setq subject (message-strip-subject-encoded-words subject))) + subject) + ;;;###autoload (defun message-reply (&optional to-address wide) "Start editing a reply to the article in the current buffer." @@ -5949,13 +6289,11 @@ want to get rid of this query permanently."))) (setq message-id (message-fetch-field "message-id" t) references (message-fetch-field "references") date (message-fetch-field "date") - from (message-fetch-field "from") + from (or (message-fetch-field "from") "nobody") subject (or (message-fetch-field "subject") "none")) - (when gnus-list-identifiers - (setq subject (message-strip-list-identifiers subject))) - (setq subject (concat "Re: " (message-strip-subject-re subject))) - (when message-subject-trailing-was-query - (setq subject (message-strip-subject-trailing-was subject))) + + ;; Strip list identifiers, "Re: ", and "was:" + (setq subject (message-simplify-subject subject)) (when (and (setq gnus-warning (message-fetch-field "gnus-warning")) (string-match "<[^>]+>" gnus-warning)) @@ -6025,11 +6363,8 @@ If TO-NEWSGROUPS, use that as the new Newsgroups line." (let ((case-fold-search t)) (string-match "world" distribution))) (setq distribution nil)) - (if gnus-list-identifiers - (setq subject (message-strip-list-identifiers subject))) - (setq subject (concat "Re: " (message-strip-subject-re subject))) - (when message-subject-trailing-was-query - (setq subject (message-strip-subject-trailing-was subject))) + ;; Strip list identifiers, "Re: ", and "was:" + (setq subject (message-simplify-subject subject)) (widen)) (message-pop-to-buffer (message-buffer-name "followup" from newsgroups)) @@ -6133,16 +6468,16 @@ regexp to match all of yours addresses." ;; Email address in From field equals to our address (and (setq from (message-fetch-field "from")) (string-equal - (downcase (cadr (mail-extract-address-components from))) - (downcase (cadr (mail-extract-address-components - (message-make-from)))))) + (downcase (car (mail-header-parse-address from))) + (downcase (car (mail-header-parse-address + (message-make-from)))))) ;; Email address in From field matches ;; 'message-alternative-emails' regexp (and from message-alternative-emails (string-match message-alternative-emails - (cadr (mail-extract-address-components from)))))))))) + (car (mail-header-parse-address from)))))))))) ;;;###autoload (defun message-cancel-news (&optional arg) @@ -6383,13 +6718,20 @@ Optional DIGEST will use digest to forward." (setq e (point)) (insert "\n-------------------- End of forwarded message --------------------\n") - (when 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-remove-ignored-headers b e))) + +(defun message-remove-ignored-headers (b e) + (when 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))) + (let ((ignored (if (stringp message-forward-ignored-headers) + (list message-forward-ignored-headers) + message-forward-ignored-headers))) + (dolist (elem ignored) + (message-remove-header elem t)))))) (defun message-forward-make-body-mime (forward-buffer) (insert "\n\n<#part type=message/rfc822 disposition=inline raw=t>\n") @@ -6431,12 +6773,7 @@ Optional DIGEST will use digest to forward." (insert "<#/mml>\n") (when (and (not message-forward-decoded-p) 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-remove-ignored-headers b e)))) (defun message-forward-make-body-digest-plain (forward-buffer) (insert @@ -6465,6 +6802,62 @@ Optional DIGEST will use digest to forward." (message-forward-make-body-digest-mime forward-buffer) (message-forward-make-body-digest-plain forward-buffer))) +(eval-and-compile + (autoload 'mm-uu-dissect-text-parts "mm-uu") + (autoload 'mm-uu-dissect "mm-uu")) + +(defun message-signed-or-encrypted-p (&optional dont-emulate-mime handles) + "Say whether the current buffer contains signed or encrypted message. +If DONT-EMULATE-MIME is nil, this function does the MIME emulation on +messages that don't conform to PGP/MIME described in RFC2015. HANDLES +is for the internal use." + (unless handles + (let ((mm-decrypt-option 'never) + (mm-verify-option 'never)) + (if (setq handles (mm-dissect-buffer nil t)) + (unless dont-emulate-mime + (mm-uu-dissect-text-parts handles)) + (unless dont-emulate-mime + (setq handles (mm-uu-dissect)))))) + ;; Check text/plain message in which there is a signed or encrypted + ;; body that has been encoded by B or Q. + (unless (or handles dont-emulate-mime) + (let ((cur (current-buffer)) + (mm-decrypt-option 'never) + (mm-verify-option 'never)) + (with-temp-buffer + (insert-buffer-substring cur) + (when (setq handles (mm-dissect-buffer t t)) + (if (and (prog1 + (bufferp (car handles)) + (mm-destroy-parts handles)) + (equal (mm-handle-media-type handles) "text/plain")) + (progn + (mm-decode-content-transfer-encoding + (mm-handle-encoding handles)) + (setq handles (mm-uu-dissect))) + (setq handles nil)))))) + (when handles + (prog1 + (catch 'found + (dolist (handle (if (stringp (car handles)) + (if (member (car handles) + '("multipart/signed" + "multipart/encrypted")) + (throw 'found t) + (cdr handles)) + (list handles))) + (if (stringp (car handle)) + (when (message-signed-or-encrypted-p dont-emulate-mime handle) + (throw 'found t)) + (when (and (bufferp (car handle)) + (equal (mm-handle-media-type handle) + "message/rfc822")) + (with-current-buffer (mm-handle-buffer handle) + (when (message-signed-or-encrypted-p dont-emulate-mime) + (throw 'found t))))))) + (mm-destroy-parts handles)))) + ;;;###autoload (defun message-forward-make-body (forward-buffer &optional digest) ;; Put point where we want it before inserting the forwarded @@ -6477,11 +6870,13 @@ Optional DIGEST will use digest to forward." (if message-forward-as-mime (if (and message-forward-show-mml (not (and (eq message-forward-show-mml 'best) + ;; Use the raw form in the body if it contains + ;; signed or encrypted message so as not to be + ;; destroyed by re-encoding. (with-current-buffer forward-buffer - (goto-char (point-min)) - (re-search-forward - "Content-Type: *multipart/\\(signed\\|encrypted\\)" - nil t))))) + (condition-case nil + (message-signed-or-encrypted-p) + (error t)))))) (message-forward-make-body-mml forward-buffer) (message-forward-make-body-mime forward-buffer)) (message-forward-make-body-plain forward-buffer))) @@ -7172,9 +7567,8 @@ From headers in the original article." (let ((value (message-fetch-field header))) (dolist (string (mail-header-parse-addresses value 'raw)) (setq string - (replace-regexp-in-string - "\n" "" - (replace-regexp-in-string "^ +\\| *$" "" string))) + (gnus-replace-in-string + (gnus-replace-in-string string "^ +\\| +$" "") "\n" "")) (ecomplete-add-item 'mail (car (mail-header-parse-address string)) string)))) (ecomplete-save)) @@ -7182,7 +7576,7 @@ From headers in the original article." (defun message-display-abbrev (&optional choose) "Display the next possible abbrev for the text before point." (interactive (list t)) - (when (and (member (char-after (line-beginning-position)) '(?C ?T ? )) + (when (and (member (char-after (point-at-bol)) '(?C ?T ? )) (message-point-in-header-p) (save-excursion (save-restriction