X-Git-Url: http://cgit.sxemacs.org/?p=gnus;a=blobdiff_plain;f=lisp%2Fmessage.el;h=424a56e2da763a6ed73a339ca55a307f291da769;hp=e9a069d1d5ea8f9fe883d7ee95d466bc2cc9bee0;hb=9b715a1bb01321f7753340c00552ab7e3c48637d;hpb=cbfeedda7357c974b4a6f102fc22e743418e5a92 diff --git a/lisp/message.el b/lisp/message.el index e9a069d1d..424a56e2d 100644 --- a/lisp/message.el +++ b/lisp/message.el @@ -1,6 +1,6 @@ ;;; message.el --- composing mail and news messages -;; Copyright (C) 1996-2013 Free Software Foundation, Inc. +;; Copyright (C) 1996-2014 Free Software Foundation, Inc. ;; Author: Lars Magne Ingebrigtsen ;; Keywords: mail, news @@ -28,9 +28,6 @@ ;;; Code: -;; For Emacs <22.2 and XEmacs. -(eval-and-compile - (unless (fboundp 'declare-function) (defmacro declare-function (&rest r)))) (eval-when-compile (require 'cl)) @@ -50,6 +47,7 @@ (require 'mml) (require 'rfc822) (require 'format-spec) +(require 'dired) (autoload 'mailclient-send-it "mailclient") ;; Emacs 22 or contrib/ @@ -614,7 +612,8 @@ Done before generating the new subject of a forward." regexp)) (defcustom message-forward-ignored-headers "^Content-Transfer-Encoding:\\|^X-Gnus" - "*All headers that match this regexp will be deleted when forwarding a message." + "*All headers that match this regexp will be deleted when forwarding a message. +This may also be a list of regexps." :version "21.1" :group 'message-forwarding :type '(repeat :value-to-internal (lambda (widget value) @@ -624,6 +623,19 @@ Done before generating the new subject of a forward." (widget-editable-list-match widget value))) regexp)) +(defcustom message-forward-included-headers nil + "If non-nil, delete non-matching headers when forwarding a message. +Only headers that match this regexp will be included. This +variable should be a regexp or a list of regexps." + :version "24.5" + :group 'message-forwarding + :type '(repeat :value-to-internal (lambda (widget value) + (custom-split-regexp-maybe value)) + :match (lambda (widget value) + (or (stringp value) + (widget-editable-list-match widget value))) + regexp)) + (defcustom message-ignored-cited-headers "." "*Delete these headers from the messages you yank." :group 'message-insertion @@ -972,6 +984,8 @@ the signature is inserted." (set-keymap-parent map minibuffer-local-map) map) "Keymap for `message-read-from-minibuffer'." + ;; FIXME improve type. + :type '(restricted-sexp :match-alternatives (symbolp keymapp)) :version "22.1" :group 'message-various) @@ -996,8 +1010,8 @@ configuration. See the variable `gnus-cite-attribution-suffix'." (defcustom message-citation-line-format "On %a, %b %d %Y, %N wrote:\n" "Format of the \"Whomever writes:\" line. -The string is formatted using `format-spec'. The following -constructs are replaced: +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\". @@ -1005,11 +1019,14 @@ constructs are replaced: back to the mail address. %F The first name if present, e.g.: \"John\". %L The last name if present, e.g.: \"Doe\". + %Z, %z The time zone in the numeric form, e.g.:\"+0000\". 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. +which is called using the date from the article your replying to, but +the date in the formatted string will be expressed in the author's +time zone as much as possible. +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'." @@ -2493,6 +2510,7 @@ With prefix-argument just set Follow-Up, don't cross-post." "Remove HEADER in the narrowed buffer. If IS-REGEXP, HEADER is a regular expression. If FIRST, only remove the first instance of the header. +If REVERSE, remove headers that doesn't match HEADER. Return the number of headers removed." (goto-char (point-min)) (let ((regexp (if is-regexp header (concat "^" (regexp-quote header) ":"))) @@ -3949,9 +3967,13 @@ This function uses `mail-citation-hook' if that is non-nil." (defvar gnus-extract-address-components) (autoload 'format-spec "format-spec") +(autoload 'gnus-date-get-time "gnus-util") -(defun message-insert-formatted-citation-line (&optional from date) +(defun message-insert-formatted-citation-line (&optional from date tz) "Function that inserts a formatted citation line. +The optional FROM, and DATE are strings containing the contents of +the From header and the Date header respectively. The optional TZ +is a number of seconds, overrides the time zone of DATE. See `message-citation-line-format'." ;; The optional args are for testing/debugging. They will disappear later. @@ -3959,7 +3981,7 @@ See `message-citation-line-format'." ;; (with-temp-buffer ;; (message-insert-formatted-citation-line ;; "John Doe " - ;; (current-time)) + ;; (message-make-date)) ;; (buffer-string)) (when (or message-reply-headers (and from date)) (unless from @@ -3976,28 +3998,43 @@ See `message-citation-line-format'." (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))))) + (time + (when (string-match "%[^fnNFL]" message-citation-line-format) + (cond ((numberp (car-safe date)) date) ;; backward compatibility + (date (gnus-date-get-time date)) + (t + (gnus-date-get-time + (setq date (mail-header-date message-reply-headers))))))) + (tz (or tz + (when (stringp date) + (nth 8 (parse-time-string date))))) (flist (let ((i ?A) lst) (when (stringp name) ;; Guess first name and last name: - (let* ((names (delq nil (mapcar (lambda (x) - (if (string-match "\\`\\(\\w\\|[-.]\\)+\\'" x) x nil)) - (split-string name "[ \t]+")))) - (count (length names))) - (cond ((= count 1) (setq fname (car names) - lname "")) - ((or (= count 2) (= count 3)) (setq fname (car names) - lname (mapconcat 'identity (cdr names) " "))) - ((> count 3) (setq fname (mapconcat 'identity (butlast names (- count 2)) " ") - lname (mapconcat 'identity (nthcdr 2 names) " "))) ) + (let* ((names (delq + nil + (mapcar + (lambda (x) + (if (string-match "\\`\\(\\w\\|[-.]\\)+\\'" + x) + x + nil)) + (split-string name "[ \t]+")))) + (count (length names))) + (cond ((= count 1) + (setq fname (car names) + lname "")) + ((or (= count 2) (= count 3)) + (setq fname (car names) + lname (mapconcat 'identity (cdr names) " "))) + ((> count 3) + (setq fname (mapconcat 'identity + (butlast names (- count 2)) + " ") + lname (mapconcat 'identity + (nthcdr 2 names) + " ")))) (when (string-match "\\(.*\\),\\'" fname) (let ((newlname (match-string 1 fname))) (setq fname lname lname newlname))))) @@ -4027,7 +4064,7 @@ See `message-citation-line-format'." (>= i ?a))) (push i lst) (push (condition-case nil - (format-time-string (format "%%%c" i) replydate) + (gmm-format-time-string (format "%%%c" i) time tz) (error (format ">%c<" i))) lst)) (setq i (1+ i))) @@ -4141,11 +4178,12 @@ Instead, just auto-save the buffer and then bury it." (defun message-bury (buffer) "Bury this mail BUFFER." + ;; Note that this is not quite the same as (bury-buffer buffer), + ;; since bury-buffer does extra stuff with a nil argument. + ;; Eg http://lists.gnu.org/archive/html/emacs-devel/2014-01/msg00539.html + (with-current-buffer buffer (bury-buffer)) (if message-return-action - (progn - (bury-buffer buffer) - (apply (car message-return-action) (cdr message-return-action))) - (with-current-buffer buffer (bury-buffer)))) + (apply (car message-return-action) (cdr message-return-action)))) (defun message-send (&optional arg) "Send the message in the current buffer. @@ -4783,7 +4821,9 @@ that instead." (list resend-to-addresses) '("-t")))))) (unless (or (null cpr) (and (numberp cpr) (zerop cpr))) - (if errbuf (pop-to-buffer errbuf)) + (when errbuf + (pop-to-buffer errbuf) + (setq errbuf nil)) (error "Sending...failed with exit value %d" cpr))) (when message-interactive (with-current-buffer errbuf @@ -6344,8 +6384,7 @@ between beginning of field and beginning of line." (goto-char (if (and eoh (or (< eoh here) (= bol here))) eoh bol))) - (if (and (not (featurep 'xemacs)) - (boundp 'visual-line-mode) visual-line-mode) + (if (and (boundp 'visual-line-mode) visual-line-mode) (beginning-of-visual-line n) (beginning-of-line n)))) @@ -7255,7 +7294,7 @@ header line with the old Message-ID." (let ((buffer-read-only nil)) (erase-buffer) (insert-file-contents file-name nil))) - (t (error "message-recover cancelled"))))) + (t (error "message-recover canceled"))))) ;;; Washing Subject: @@ -7414,17 +7453,25 @@ Optional DIGEST will use digest to forward." (message-remove-ignored-headers b e))) (defun message-remove-ignored-headers (b e) - (when message-forward-ignored-headers + (when (or message-forward-ignored-headers + message-forward-included-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)))))) + (when message-forward-ignored-headers + (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)))) + (when message-forward-included-headers + (message-remove-header + (if (listp message-forward-included-headers) + (regexp-opt message-forward-included-headers) + message-forward-included-headers) + t nil t))))) (defun message-forward-make-body-mime (forward-buffer &optional beg end) (let ((b (point))) @@ -7472,8 +7519,7 @@ Optional DIGEST will use digest to forward." (goto-char (point-max)))) (setq e (point)) (insert "<#/mml>\n") - (when (and (not message-forward-decoded-p) - message-forward-ignored-headers) + (when (not message-forward-decoded-p) (message-remove-ignored-headers b e)))) (defun message-forward-make-body-digest-plain (forward-buffer) @@ -7968,8 +8014,9 @@ If nil, the function bound in `text-mode-map' or `global-map' is executed." (defun message-tab () "Complete names according to `message-completion-alist'. -Execute function specified by `message-tab-body-function' when not in -those headers." +Execute function specified by `message-tab-body-function' when +not in those headers. If that variable is nil, indent with the +regular text mode tabbing command." (interactive) (cond ((if (and (boundp 'completion-fail-discreetly) @@ -8461,6 +8508,17 @@ Used in `message-simplify-recipients'." (message-fetch-field hdr) t)) ", ")))) +;;; multipart/related and HTML support. + +(defun message-make-html-message-with-image-files (files) + (interactive (list (dired-get-marked-files nil current-prefix-arg))) + (message-mail) + (message-goto-body) + (insert "<#part type=text/html>\n\n") + (dolist (file files) + (insert (format "\n\n" file))) + (message-goto-to)) + (when (featurep 'xemacs) (require 'messagexmas) (message-xmas-redefine))