;;; 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 <larsi@gnus.org>
;; Keywords: mail, news
;;; Code:
-;; For Emacs <22.2 and XEmacs.
-(eval-and-compile
- (unless (fboundp 'declare-function) (defmacro declare-function (&rest r))))
(eval-when-compile
(require 'cl))
(require 'mml)
(require 'rfc822)
(require 'format-spec)
+(require 'dired)
(autoload 'mailclient-send-it "mailclient") ;; Emacs 22 or contrib/
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)
(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 "25.1"
+ :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
(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)
(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 <john.doe@example.invalid>\".
%n The mail address, e.g. \"john.doe@example.invalid\".
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'."
:type '(radio (const :format "%v " nil)
(string :format "FQDN: %v")))
-(defcustom message-use-idna (and (condition-case nil (require 'idna)
- (file-error))
- (mm-coding-system-p 'utf-8)
- (executable-find idna-program)
- (string= (idna-to-ascii "räksmörgås")
- "xn--rksmrgs-5wao1o")
- t)
+(defcustom message-use-idna
+ (and (or (mm-coding-system-p 'utf-8)
+ (condition-case nil
+ (let (mucs-ignore-version-incompatibilities)
+ (require 'un-define))
+ (error)))
+ (condition-case nil (require 'idna) (file-error))
+ idna-program
+ (executable-find idna-program)
+ (string= (idna-to-ascii "räksmörgås") "xn--rksmrgs-5wao1o")
+ t)
"Whether to encode non-ASCII in domain names into ASCII according to IDNA.
GNU Libidn, and in particular the elisp package \"idna.el\" and
the external program \"idn\", must be installed for this
"cat\\|com\\|coop\\|edu\\|gov\\|"
"info\\|int\\|jobs\\|"
"mil\\|mobi\\|museum\\|name\\|net\\|"
- "org\\|pro\\|tel\\|travel\\|uucp\\)")
+ "org\\|pro\\|tel\\|travel\\|uucp\\|"
+ ;; ICANN-era generic top-level domains
+ "academy\\|actor\\|agency\\|airforce\\|archi\\|associates\\|axa\\|"
+ "bar\\|bargains\\|bayern\\|beer\\|berlin\\|best\\|bid\\|bike\\|"
+ "biz\\|black\\|blackfriday\\|blue\\|boutique\\|build\\|builders\\|"
+ "buzz\\|cab\\|camera\\|camp\\|capital\\|cards\\|care\\|career\\|"
+ "careers\\|cash\\|catering\\|center\\|ceo\\|cheap\\|christmas\\|"
+ "church\\|citic\\|cleaning\\|clinic\\|clothing\\|club\\|codes\\|"
+ "coffee\\|college\\|cologne\\|com\\|community\\|company\\|computer\\|"
+ "construction\\|contractors\\|cooking\\|cool\\|country\\|creditcard\\|"
+ "cruises\\|dance\\|dating\\|democrat\\|dental\\|desi\\|design\\|"
+ "diamonds\\|directory\\|discount\\|domains\\|education\\|email\\|"
+ "engineering\\|enterprises\\|equipment\\|estate\\|eus\\|events\\|"
+ "exchange\\|expert\\|exposed\\|fail\\|farm\\|feedback\\|finance\\|"
+ "financial\\|fish\\|fishing\\|fitness\\|flights\\|florist\\|foo\\|"
+ "foundation\\|frogans\\|fund\\|furniture\\|futbol\\|gal\\|"
+ "gallery\\|gift\\|glass\\|globo\\|gmo\\|gop\\|graphics\\|gratis\\|"
+ "gripe\\|guide\\|guitars\\|guru\\|hamburg\\|haus\\|hiphop\\|"
+ "holdings\\|holiday\\|homes\\|horse\\|house\\|immobilien\\|"
+ "industries\\|info\\|ink\\|institute\\|insure\\|international\\|"
+ "investments\\|jetzt\\|juegos\\|kaufen\\|kim\\|kitchen\\|kiwi\\|"
+ "koeln\\|kred\\|land\\|lat\\|latino\\|lease\\|life\\|lighting\\|"
+ "limited\\|limo\\|link\\|loans\\|london\\|luxe\\|luxury\\|"
+ "management\\|mango\\|marketing\\|media\\|meet\\|menu\\|miami\\|"
+ "moda\\|moe\\|monash\\|moscow\\|motorcycles\\|nagoya\\|name\\|"
+ "net\\|neustar\\|ninja\\|nyc\\|okinawa\\|onl\\|org\\|paris\\|"
+ "partners\\|parts\\|photo\\|photography\\|photos\\|pics\\|"
+ "pictures\\|pink\\|plumbing\\|pro\\|productions\\|properties\\|"
+ "pub\\|qpon\\|quebec\\|recipes\\|red\\|reisen\\|ren\\|rentals\\|"
+ "repair\\|report\\|rest\\|reviews\\|rich\\|rocks\\|rodeo\\|"
+ "ruhr\\|ryukyu\\|saarland\\|schule\\|scot\\|services\\|sexy\\|"
+ "shiksha\\|shoes\\|singles\\|social\\|sohu\\|solar\\|solutions\\|"
+ "soy\\|supplies\\|supply\\|support\\|surgery\\|systems\\|tattoo\\|"
+ "tax\\|technology\\|tienda\\|tips\\|today\\|tokyo\\|tools\\|"
+ "town\\|toys\\|trade\\|training\\|university\\|uno\\|vacations\\|"
+ "vegas\\|ventures\\|viajes\\|villas\\|vision\\|vodka\\|vote\\|"
+ "voting\\|voto\\|voyage\\|wang\\|watch\\|webcam\\|wed\\|wien\\|"
+ "wiki\\|works\\|wtc\\|wtf\\|xyz\\|yachts\\|yokohama\\|you\\|"
+ "zone\\)")
;; http://en.wikipedia.org/wiki/List_of_Internet_top-level_domains
;; http://en.wikipedia.org/wiki/GTLD
;; `approved, but not yet in operation': .xxx
"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) ":")))
(goto-char (point-max))
;; Insert the signature.
(unless (bolp)
- (insert "\n"))
+ (newline))
(when message-signature-insert-empty-line
- (insert "\n"))
- (insert "-- \n")
+ (newline))
+ (insert "-- ")
+ (newline)
(if (eq signature t)
(insert-file-contents signature-file)
(insert signature))
(goto-char (point-max))
- (or (bolp) (insert "\n")))))
+ (or (bolp) (newline)))))
(defun message-insert-importance-high ()
"Insert header to mark message as important."
(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.
;; (with-temp-buffer
;; (message-insert-formatted-citation-line
;; "John Doe <john.doe@example.invalid>"
- ;; (current-time))
+ ;; (message-make-date))
;; (buffer-string))
(when (or message-reply-headers (and from date))
(unless from
(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)))))
(>= 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)))
(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.
(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
"Make date string for the Expires header. Expiry in DAYS days.
In posting styles use `(\"Expires\" (make-expires-date 30))'."
- (let* ((cur (decode-time (current-time)))
+ (let* ((cur (decode-time))
(nday (+ days (nth 3 cur))))
(setf (nth 3 cur) nday)
(message-make-date (apply 'encode-time cur))))
:link '(custom-manual "(message)Movement")
:type 'boolean)
+(defvar visual-line-mode)
+(declare-function beginning-of-visual-line "simple" (&optional n))
+
(defun message-beginning-of-line (&optional n)
"Move point to beginning of header value or to beginning of line.
The prefix argument N is passed directly to `beginning-of-line'.
(goto-char
(if (and eoh (or (< eoh here) (= bol here)))
eoh bol)))
- (beginning-of-line n)))
+ (if (and (boundp 'visual-line-mode) visual-line-mode)
+ (beginning-of-visual-line n)
+ (beginning-of-line n))))
(defun message-buffer-name (type &optional to group)
"Return a new (unique) buffer name based on TYPE and TO."
(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:
(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)))
(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)
(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)
;; falling back to message-tab-body-function.
(lambda () (funcall fun) 'completion-attempted)))))
-(eval-and-compile
- (condition-case nil
- (with-temp-buffer
- (let ((standard-output (current-buffer)))
- (eval '(display-completion-list nil "")))
- (defalias 'message-display-completion-list 'display-completion-list))
- (error ;; Don't use `wrong-number-of-arguments' here because of XEmacs.
- (defun message-display-completion-list (completions &optional ignore)
- "Display the list of completions, COMPLETIONS, using `standard-output'."
- (display-completion-list completions)))))
-
(defun message-expand-group ()
"Expand the group name under point."
(let ((b (save-excursion
(let ((buffer-read-only nil))
(erase-buffer)
(let ((standard-output (current-buffer)))
- (message-display-completion-list (sort completions 'string<)
- string))
+ (display-completion-list (sort completions 'string<)))
(setq buffer-read-only nil)
(goto-char (point-min))
(delete-region (point)
(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 "<img src=%S>\n\n" file)))
+ (message-goto-to))
+
(when (featurep 'xemacs)
(require 'messagexmas)
(message-xmas-redefine))
projects / gnus / blobdiff