;;; message.el --- composing mail and news messages
-;; Copyright (C) 1996-2014 Free Software Foundation, Inc.
+;; Copyright (C) 1996-2015 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/
"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"
+ :version "25.1"
:group 'message-forwarding
:type '(repeat :value-to-internal (lambda (widget value)
(custom-split-regexp-maybe value))
(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\".
%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\".
+ %F The first name if present, e.g.: \"John\", else fall
+ back to the mail address.
%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)
+ (invalid-operation))
+ 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
;; "dead" nato bitnet uucp
"Regular expression that matches a valid FQDN."
;; see also: gnus-button-valid-fqdn-regexp
- :version "22.1"
+ :version "25.1"
:group 'message-headers
:type 'regexp)
((not (string-match
(concat "^[ \t]*"
(regexp-quote new-subject)
- " \t]*$")
+ "[ \t]*$")
old-subject)) ; yes, it really is a new subject
;; delete eventual Re: prefix
(setq old-subject
(autoload 'ecomplete-setup "ecomplete") ;; for Emacs <23.
+(defvar message-smileys '(":-)" ":)"
+ ":-(" ":("
+ ";-)" ";)")
+ "A list of recognized smiley faces in `message-mode'.")
+
+(defun message--syntax-propertize (beg end)
+ "Syntax-propertize certain message text specially."
+ (let ((citation-regexp (concat "^" message-cite-prefix-regexp ".*$"))
+ (smiley-regexp (regexp-opt message-smileys)))
+ (goto-char beg)
+ (while (search-forward-regexp citation-regexp
+ end 'noerror)
+ (let ((start (match-beginning 0))
+ (end (match-end 0)))
+ (add-text-properties start (1+ start)
+ `(syntax-table ,(string-to-syntax "<")))
+ (add-text-properties end (min (1+ end) (point-max))
+ `(syntax-table ,(string-to-syntax ">")))))
+ (goto-char beg)
+ (while (search-forward-regexp smiley-regexp
+ end 'noerror)
+ (add-text-properties (match-beginning 0) (match-end 0)
+ `(syntax-table ,(string-to-syntax "."))))))
+
;;;###autoload
(define-derived-mode message-mode text-mode "Message"
"Major mode for editing mail and news to be sent.
;; multibyte is not necessary at all. -- zsh
(mm-enable-multibyte))
(set (make-local-variable 'indent-tabs-mode) nil) ;No tabs for indentation.
- (mml-mode))
+ (mml-mode)
+ ;; Syntactic fontification. Helps `show-paren-mode',
+ ;; `electric-pair-mode', and C-M-* navigation by syntactically
+ ;; excluding citations and other artifacts.
+ ;;
+ (set (make-local-variable 'syntax-propertize-function) 'message--syntax-propertize)
+ (set (make-local-variable 'parse-sexp-ignore-comments) t))
(defun message-setup-fill-variables ()
"Setup message fill variables."
(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)))))
;; The following letters are not used in `format-time-string':
(push ?E lst) (push "<E>" lst)
- (push ?F lst) (push fname lst)
+ (push ?F lst) (push (or fname name-or-net) lst)
;; We might want to use "" instead of "<X>" later.
(push ?J lst) (push "<J>" lst)
(push ?K lst) (push "<K>" lst)
(>= 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)))
It is useful if your ISP requires the POP-before-SMTP
authentication. See the Gnus manual for details."
(run-hooks 'message-send-mail-hook)
+ ;; Change header-delimiter to be what smtpmail expects.
+ (goto-char (point-min))
+ (when (re-search-forward
+ (concat "^" (regexp-quote mail-header-separator) "\n"))
+ (replace-match "\n"))
(smtpmail-send-it))
(defun message-send-mail-with-mailclient ()
"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))))
(defun message-make-fqdn ()
"Return user's fully qualified domain name."
- (let* ((system-name (system-name))
+ (let* ((sysname (system-name))
(user-mail (message-user-mail-address))
(user-domain
(if (and user-mail
(not (string-match message-bogus-system-names message-user-fqdn)))
;; `message-user-fqdn' seems to be valid
message-user-fqdn)
- ((and (string-match message-valid-fqdn-regexp system-name)
- (not (string-match message-bogus-system-names system-name)))
+ ((and (string-match message-valid-fqdn-regexp sysname)
+ (not (string-match message-bogus-system-names sysname)))
;; `system-name' returned the right result.
- system-name)
+ sysname)
;; Try `mail-host-address'.
((and (boundp 'mail-host-address)
(stringp mail-host-address)
user-domain)
;; Default to this bogus thing.
(t
- (concat system-name
+ (concat sysname
".i-did-not-set--mail-host-address--so-tickle-me")))))
(defun message-make-domain ()
(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)
(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