;;; message.el --- composing mail and news messages
-;; Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002
+;; Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003
;; Free Software Foundation, Inc.
;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
(eval-when-compile
(require 'cl)
+ (defvar gnus-message-group-art)
(defvar gnus-list-identifiers)) ; gnus-sum is required where necessary
(require 'canlock)
(require 'mailheader)
(require 'mml)
(require 'rfc822)
(eval-and-compile
- (autoload 'sha1 "sha1-el"))
+ (autoload 'sha1 "sha1-el")
+ (autoload 'gnus-find-method-for-group "gnus")
+ (autoload 'nnvirtual-find-group-art "nnvirtual"))
(defgroup message '((user-mail-address custom-variable)
(user-full-name custom-variable))
the article has been posted to will be inserted there.
If this variable is nil, no such courtesy message will be added."
:group 'message-sending
- :type 'string)
+ :type '(radio (string :format "%t: %v\n" :size 0) (const nil)))
-(defcustom message-ignored-bounced-headers "^\\(Received\\|Return-Path\\):"
+(defcustom message-ignored-bounced-headers
+ "^\\(Received\\|Return-Path\\|Delivered-To\\):"
"*Regexp that matches headers to be removed in resent bounced mail."
:group 'message-interface
:type 'regexp)
:group 'message-headers
:type 'boolean)
-(defcustom message-syntax-checks
+(defcustom message-syntax-checks
(if message-insert-canlock '((sender . disabled)) nil)
;; Guess this one shouldn't be easy to customize...
"*Controls what syntax checks should not be performed on outgoing posts.
`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'."
+`buffer-file-name', `unchanged', `newsgroups', `reply-to',
+`continuation-headers', `long-header-lines', `invisible-text' and
+`illegible-text'."
:group 'message-news
:type '(repeat sexp)) ; Fixme: improve this
-(defcustom message-required-headers '((optional . References))
- "*Headers to be generated or promted for when sending a message.
+(defcustom message-required-headers '((optional . References)
+ From)
+ "*Headers to be generated or prompted for when sending a message.
Also see `message-required-news-headers' and
-1message-required-mail-headers'."
+`message-required-mail-headers'."
:group 'message-news
:group 'message-headers
:type '(repeat sexp))
-(defcustom message-draft-headers '(References)
+(defcustom message-draft-headers '(References From)
"*Headers to be generated when saving a draft message."
:group 'message-news
:group 'message-headers
:group 'message-various
:type 'regexp)
+;; Fixme: Why are all these things autoloaded?
+
;;; marking inserted text
;;;###autoload
(defcustom message-archive-header
"X-No-Archive: Yes\n"
"Header to insert when you don't want your article to be archived.
-Archives \(such as groups.googgle.com\) respect this header."
+Archives \(such as groups.google.com\) respect this header."
:type 'string
:group 'message-various)
;;;###autoload
(defcustom message-archive-note
"X-No-Archive: Yes - save http://groups.google.com/"
- "Note to insert why you wouldn't want this posting archived.
+ "Note to insert why you wouldn't want this posting archived.
If nil, don't insert any text in the body."
- :type 'string
+ :type '(radio (string :format "%t: %v\n" :size 0)
+ (const nil))
:group 'message-various)
;;; Crossposts and Followups
;; inspired by JoH-followup-to by Jochem Huhman <joh at gmx.de>
;; new suggestions by R. Weikusat <rw at another.de>
-(defvar message-xpost-old-target nil
+(defvar message-cross-post-old-target nil
"Old target for cross-posts or follow-ups.")
-(make-variable-buffer-local 'message-xpost-old-target)
+(make-variable-buffer-local 'message-cross-post-old-target)
;;;###autoload
-(defcustom message-xpost-default t
- "When non-nil `message-xpost-fup2' will normally perform a crosspost.
-If nil, `message-xpost-fup2' will only do a followup. Note that you
-can explicitly override this setting by calling `message-xpost-fup2'
-with a prefix."
+(defcustom message-cross-post-default t
+ "When non-nil `message-cross-post-followup-to' will perform a crosspost.
+If nil, `message-cross-post-followup-to' will only do a followup. Note that
+you can explicitly override this setting by calling
+`message-cross-post-followup-to' with a prefix."
:type 'boolean
:group 'message-various)
;;;###autoload
-(defcustom message-xpost-note
+(defcustom message-cross-post-note
"Crosspost & Followup-To: "
- "Note to insert before signature to notify of xpost and follow-up."
+ "Note to insert before signature to notify of cross-post and follow-up."
:type 'string
:group 'message-various)
;;;###autoload
-(defcustom message-fup2-note
+(defcustom message-followup-to-note
"Followup-To: "
"Note to insert before signature to notify of follow-up only."
:type 'string
:group 'message-various)
;;;###autoload
-(defcustom message-xpost-note-function
- 'message-xpost-insert-note
- "Function to use to insert note about Crosspost or Followup-To.
+(defcustom message-cross-post-note-function
+ 'message-cross-post-insert-note
+ "Function to use to insert note about Crosspost or Followup-To.
The function will be called with four arguments. The function should not only
insert a note, but also ensure old notes are deleted. See the documentation
-for `message-xpost-insert-note'. "
+for `message-cross-post-insert-note'."
:type 'function
:group 'message-various)
:group 'message-headers)
(defcustom message-make-forward-subject-function
- 'message-forward-subject-author-subject
+ 'message-forward-subject-name-subject
"*List of functions called to generate subject headers for forwarded messages.
The subject generated by the previous function is passed into each
successive function.
* `message-forward-subject-author-subject' (Source of article (author or
newsgroup)), in brackets followed by the subject
+* `message-forward-subject-name-subject' (Source of article (name of author
+ or newsgroup)), in brackets followed by the subject
* `message-forward-subject-fwd' (Subject of article with 'Fwd:' prepended
to it."
:group 'message-forwarding
:type '(radio (function-item message-forward-subject-author-subject)
(function-item message-forward-subject-fwd)
+ (function-item message-forward-subject-name-subject)
(repeat :tag "List of functions" function)))
(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."
+ "*Non-nil means forward messages as an inline/rfc822 MIME section.
+Otherwise, directly inline the old message in the forwarded message."
:version "21.1"
:group 'message-forwarding
:type 'boolean)
(defcustom message-forward-show-mml t
- "*If non-nil, forward messages are shown as mml. Otherwise, forward messages are unchanged."
+ "*Non-nil means show forwarded messages as mml.
+Otherwise, forwarded messages are unchanged."
:version "21.1"
:group 'message-forwarding
:type 'boolean)
(defcustom message-forward-before-signature t
- "*If non-nil, put forwarded message before signature, else after."
+ "*Non-nil means put forwarded message before signature, else after."
: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."
+ "*Non-nil means try to remove as much cruft as possible from the subject.
+Done before generating the new subject of a forward."
:group 'message-forwarding
:type 'boolean)
(defcustom message-subscribed-address-functions nil
"*Specifies functions for determining list subscription.
-If nil, do not attempt to determine list subscribtion with functions.
+If nil, do not attempt to determine list subscription with functions.
If non-nil, this variable contains a list of functions which return
regular expressions to match lists. These functions can be used in
conjunction with `message-subscribed-regexps' and
If nil, do not look at any files to determine list subscriptions. If
non-nil, each line of this file should be a mailing list address."
:group 'message-interface
- :type 'string)
+ :type '(radio (file :format "%t: %v\n" :size 0)
+ (const nil)))
(defcustom message-subscribed-addresses nil
"*Specifies a list of addresses the user is subscribed to.
If nil, do not use any predefined list subscriptions. This list of
-addresses can be used in conjuction with
+addresses can be used in conjunction with
`message-subscribed-address-functions' and `message-subscribed-regexps'."
:group 'message-interface
:type '(repeat string))
(defcustom message-subscribed-regexps nil
"*Specifies a list of addresses the user is subscribed to.
If nil, do not use any predefined list subscriptions. This list of
-regular expressions can be used in conjuction with
+regular expressions can be used in conjunction with
`message-subscribed-address-functions' and `message-subscribed-addresses'."
:group 'message-interface
:type '(repeat regexp))
:group 'message-sending
:type 'boolean)
+(defcustom message-sendmail-envelope-from nil
+ "*Envelope-from when sending mail with sendmail.
+If this is nil, use `user-mail-address'. If it is the symbol
+`header', use the From: header of the message."
+ :type '(choice (string :tag "From name")
+ (const :tag "Use From: header from message" header)
+ (const :tag "Use `user-mail-address'" nil))
+ :group 'message-sending)
+
;; qmail-related stuff
(defcustom message-qmail-inject-program "/var/qmail/bin/qmail-inject"
"Location of the qmail-inject program."
;; create a dependence to `gnus.el'.
:type 'sexp)
-(defcustom message-generate-headers-first nil
+;; FIXME: This should be a temporary workaround until someone implements a
+;; proper solution. If a crash happens while replying, the auto-save file
+;; will *not* have a `References:' header if `message-generate-headers-first'
+;; is nil. See: http://article.gmane.org/gmane.emacs.gnus.general/51138
+(defcustom message-generate-headers-first '(references)
"*If non-nil, generate all required headers before composing.
The variables `message-required-news-headers' and
`message-required-mail-headers' specify which headers to generate.
are to be deleted and then re-generated before sending, so this variable
will not have a visible effect for those headers."
:group 'message-headers
- :type 'boolean)
+ :type '(choice (const :tag "None" nil)
+ (const :tag "References" '(references))
+ (const :tag "All" t)
+ (repeat (sexp :tag "Header"))))
(defcustom message-setup-hook nil
"Normal hook, run each time a new outgoing message is initialized.
:type '(choice file (const :tags "None" nil))
:group 'message-insertion)
+;;;###autoload
+(defcustom message-signature-insert-empty-line t
+ "*If non-nil, insert an empty line before the signature separator."
+ :type 'boolean
+ :group 'message-insertion)
+
(defcustom message-distribution-function nil
"*Function called to return a Distribution header."
:group 'message-news
"*A list of GNKSA feet you are allowed to shoot.
Gnus gives you all the opportunity you could possibly want for
shooting yourself in the foot. Also, Gnus allows you to shoot the
-feet of Good Net-Keeping Seal of Approval. The following are foot
+feet of Good Net-Keeping Seal of Approval. The following are foot
candidates:
`empty-article' Allow you to post an empty article;
`quoted-text-only' Allow you to post quoted text only;
`multiple-copies' Allow you to post multiple copies;
-`cancel-messages' Allow you to cancel or supersede messages from
+`cancel-messages' Allow you to cancel or supersede messages from
your other email addresses.")
(defsubst message-gnksa-enable-p (feature)
(or (not (listp message-shoot-gnksa-feet))
(memq feature message-shoot-gnksa-feet)))
+(defcustom message-hidden-headers nil
+ "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.."
+ :group 'message
+ :type '(repeat regexp))
+
;;; Internal variables.
;;; Well, not really internal.
The cdr of each entry is a function for applying the face to a region.")
(defcustom message-send-hook nil
- "Hook run before sending messages."
+ "Hook run before sending messages.
+This hook is run quite early when sending."
:group 'message-various
:options '(ispell-message)
:type 'hook)
(defcustom message-send-mail-hook nil
- "Hook run before sending mail messages."
+ "Hook run before sending mail messages.
+This hook is run very late -- just before the message is sent as
+mail."
:group 'message-various
:type 'hook)
(defcustom message-send-news-hook nil
- "Hook run before sending news messages."
+ "Hook run before sending news messages.
+This hook is run very late -- just before the message is sent as
+news."
:group 'message-various
:type 'hook)
:group 'message-headers
:type 'boolean)
+(defcustom message-user-fqdn nil
+ "*Domain part of Messsage-Ids."
+ :group 'message-headers
+ :link '(custom-manual "(message)News Headers")
+ :type '(radio (const :format "%v " nil)
+ (string :format "FQDN: %v\n" :size 0)))
+
+(defcustom message-use-idna (and (condition-case nil (require 'idna)
+ (file-error))
+ (mm-coding-system-p 'utf-8)
+ (executable-find idna-program)
+ 'ask)
+ "Whether to encode non-ASCII in domain names into ASCII according to IDNA."
+ :group 'message-headers
+ :type '(choice (const :tag "Ask" ask)
+ (const :tag "Never" nil)
+ (const :tag "Always" t)))
+
;;; Internal variables.
(defvar message-sending-message "Sending...")
;; We want to match the results of any of these manglings.
;; The following regexp rejects names whose first characters are
;; obviously bogus, but after that anything goes.
- "\\([^\0-\b\n-\r\^?].*\\)? "
+ "\\([^\0-\b\n-\r\^?].*\\)?"
;; The time the message was sent.
"\\([^\0-\r \^?]+\\) +" ; day of the week
(defvar message-bogus-system-names "^localhost\\."
"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?
+ "\\)")
+ "Regular expression that matches a valid FQDN."
+ ;; see also: gnus-button-valid-fqdn-regexp
+ :group 'message-headers
+ :type 'regexp)
+
(eval-and-compile
(autoload 'message-setup-toolbar "messagexmas")
(autoload 'mh-new-draft-name "mh-comp")
(autoload 'gnus-group-name-decode "gnus-group")
(autoload 'gnus-groups-from-server "gnus")
(autoload 'rmail-output "rmailout")
- (autoload 'gnus-delay-article "gnus-delay"))
+ (autoload 'gnus-delay-article "gnus-delay")
+ (autoload 'gnus-make-local-hook "gnus-util"))
\f
`(delete-region (progn (beginning-of-line) (point))
(progn (forward-line ,(or n 1)) (point))))
+(defun message-mark-active-p ()
+ "Non-nil means the mark and region are currently active in this buffer."
+ mark-active)
+
(defun message-unquote-tokens (elems)
"Remove double quotes (\") from strings in list ELEMS."
(mapcar (lambda (item)
(beg 1)
(first t)
quoted elems paren)
- (save-excursion
- (message-set-work-buffer)
+ (with-temp-buffer
+ (mm-enable-multibyte)
(insert header)
(goto-char (point-min))
(while (not (eobp))
(looking-at message-unix-mail-delimiter))))
(defun message-fetch-field (header &optional not-all)
- "The same as `mail-fetch-field', only remove all newlines."
+ "The same as `mail-fetch-field', only remove all newlines.
+The buffer is expected to be narrowed to just the header of the message;
+see `message-narrow-to-headers-or-head'."
(let* ((inhibit-point-motion-hooks t)
(case-fold-search t)
(value (mail-fetch-field header nil (not not-all))))
(defun message-fetch-reply-field (header)
"Fetch field HEADER from the message we're replying to."
(message-with-reply-buffer
- (message-fetch-field header)))
-
-(defun message-set-work-buffer ()
- (if (get-buffer " *message work*")
- (progn
- (set-buffer " *message work*")
- (erase-buffer))
- (set-buffer (get-buffer-create " *message work*"))
- (kill-all-local-variables)
- (mm-enable-multibyte)))
-
-(defun message-functionp (form)
- "Return non-nil if FORM is funcallable."
- (or (and (symbolp form) (fboundp form))
- (and (listp form) (eq (car form) 'lambda))
- (byte-code-function-p form)))
+ (save-restriction
+ (mail-narrow-to-head)
+ (message-fetch-field header))))
(defun message-strip-list-identifiers (subject)
"Remove list identifiers in `gnus-list-identifiers' from string SUBJECT."
;;; Start of functions adopted from `message-utils.el'.
(defun message-strip-subject-trailing-was (subject)
- "Remove trailing \"(Was: <old subject>)\" from subject lines.
+ "Remove trailing \"(Was: <old subject>)\" from SUBJECT lines.
Leading \"Re: \" is not stripped by this function. Use the function
`message-strip-subject-re' for this."
(let* ((query message-subject-trailing-was-query)
(new) (found))
(setq found
- (string-match
+ (string-match
(if (eq query 'ask)
message-subject-trailing-was-ask-regexp
message-subject-trailing-was-regexp)
(if (eq query 'ask)
(if (message-y-or-n-p
"Strip `(was: <old subject>)' in subject? " t
- (concat
+ (concat
"Strip `(was: <old subject>)' in subject "
"and use the new one instead?\n\n"
"Current subject is: \""
;;;###autoload
(defun message-change-subject (new-subject)
- "Ask for
new Subject: header, append (was: <Old Subject>)."
+ "Ask for
NEW-SUBJECT header, append (was: <Old Subject>)."
(interactive
(list
(read-from-minibuffer "New subject: ")))
(zerop (string-width new-subject))
(string-match "^[ \t]*$" new-subject))))
(save-excursion
- (let ((old-subject (message-fetch-field "Subject")))
+ (let ((old-subject
+ (save-restriction
+ (message-narrow-to-headers)
+ (message-fetch-field "Subject"))))
(cond ((not old-subject)
- (error "No current subject."))
+ (error "No current subject"))
((not (string-match
(concat "^[ \t]*"
(regexp-quote new-subject)
;;;###autoload
(defun message-mark-insert-file (file)
- "Inserts FILE at point, marking it with enclosing tags.
+ "Insert FILE at point, marking it with enclosing tags.
See `message-mark-insert-begin' and `message-mark-insert-end'."
(interactive "fFile to insert: ")
;; reverse insertion to get correct result.
(message-sort-headers)))
;;;###autoload
-(defun message-xpost-fup2-header (target-group)
+(defun message-cross-post-followup-to-header (target-group)
"Mangles FollowUp-To and Newsgroups header to point to TARGET-GROUP.
With prefix-argument just set Follow-Up, don't cross-post."
(interactive
(message-goto-newsgroups)
(beginning-of-line)
;; if we already did a crosspost before, kill old target
- (if (and message-xpost-old-target
+ (if (and message-cross-post-old-target
(re-search-forward
- (regexp-quote (concat "," message-xpost-old-target))
+ (regexp-quote (concat "," message-cross-post-old-target))
nil t))
(replace-match ""))
;; unless (followup is to poster or user explicitly asked not
;; to cross-post, or target-group is already in Newsgroups)
;; add target-group to Newsgroups line.
(cond ((and (or
- ;; def: xpost, req:no
- (and message-xpost-default (not current-prefix-arg))
- ;; def: no-xpost, req:yes
- (and (not message-xpost-default) current-prefix-arg))
+ ;; def: cross-post, req:no
+ (and message-cross-post-default (not current-prefix-arg))
+ ;; def: no-cross-post, req:yes
+ (and (not message-cross-post-default) current-prefix-arg))
(not (string-match "poster" target-group))
(not (string-match (regexp-quote target-group)
(message-fetch-field "Newsgroups"))))
(end-of-line)
- (insert-string (concat "," target-group))))
+ (insert (concat "," target-group))))
(end-of-line) ; ensure Followup: comes after Newsgroups:
;; unless new followup would be identical to Newsgroups line
;; make a new Followup-To line
"[ \t]*$")
(message-fetch-field "Newsgroups")))
(insert (concat "\nFollowup-To: " target-group)))
- (setq message-xpost-old-target target-group))
+ (setq message-cross-post-old-target target-group))
;;;###autoload
-(defun message-xpost-insert-note (target-group xpost in-old old-groups)
+(defun message-cross-post-insert-note (target-group cross-post in-old
+ old-groups)
"Insert a in message body note about a set Followup or Crosspost.
If there have been previous notes, delete them. TARGET-GROUP specifies the
-group to Followup-To. When XPOST is t, insert note about
+group to Followup-To. When CROSS-POST is t, insert note about
crossposting. IN-OLD specifies whether TARGET-GROUP is a member of
OLD-GROUPS. OLD-GROUPS lists the old-groups the posting would have
been made to before the user asked for a Crosspost."
nil t))) ; just search in body
(message-goto-signature)
(while (re-search-backward
- (concat "^" (regexp-quote message-xpost-note) ".*")
+ (concat "^" (regexp-quote message-cross-post-note) ".*")
head t)
(message-delete-line))
(message-goto-signature)
(while (re-search-backward
- (concat "^" (regexp-quote message-fup2-note) ".*")
+ (concat "^" (regexp-quote message-followup-to-note) ".*")
head t)
(message-delete-line))
;; insert new note
(if (message-goto-signature)
(re-search-backward message-signature-separator))
(if (or in-old
- (not xpost)
+ (not cross-post)
(string-match "^[ \t]*poster[ \t]*$" target-group))
- (insert (concat message-fup2-note target-group "\n"))
- (insert (concat message-xpost-note target-group "\n")))))
+ (insert (concat message-followup-to-note target-group "\n"))
+ (insert (concat message-cross-post-note target-group "\n")))))
;;;###autoload
-(defun message-xpost-fup2 (target-group)
- "Crossposts message and sets Followup-To to TARGET-GROUP.
+(defun message-cross-post-followup-to (target-group)
+ "Crossposts message and set Followup-To to TARGET-GROUP.
With prefix-argument just set Follow-Up, don't cross-post."
(interactive
(list ; Completion based on Gnus
(save-excursion
(let* ((old-groups (message-fetch-field "Newsgroups"))
(in-old (string-match
- (regexp-quote target-group)
+ (regexp-quote target-group)
(or old-groups ""))))
;; check whether target exactly matches old Newsgroups
(cond ((not old-groups)
- (error "No current newsgroup."))
+ (error "No current newsgroup"))
((or (not in-old)
(not (string-match
(concat "^[ \t]*"
"[ \t]*$")
old-groups)))
;; yes, Newsgroups line must change
- (message-xpost-fup2-header target-group)
- ;; insert note whether we do xpost or fup2
- (funcall message-xpost-note-function
+ (message-cross-post-followup-to-header target-group)
+ ;; insert note whether we do cross-post or followup-to
+ (funcall message-cross-post-note-function
target-group
- (if (or (and message-xpost-default
+ (if (or (and message-cross-post-default
(not current-prefix-arg))
- (and (not message-xpost-default)
+ (and (not message-cross-post-default)
current-prefix-arg)) t)
in-old old-groups))))))))
(defun message-reduce-to-to-cc ()
"Replace contents of To: header with contents of Cc: or Bcc: header."
(interactive)
- (let ((cc-content (message-fetch-field "cc"))
+ (let ((cc-content
+ (save-restriction (message-narrow-to-headers)
+ (message-fetch-field "cc")))
(bcc nil))
(if (and (not cc-content)
- (setq cc-content (message-fetch-field "bcc")))
+ (setq cc-content
+ (save-restriction
+ (message-narrow-to-headers)
+ (message-fetch-field "bcc"))))
(setq bcc t))
(cond (cc-content
(save-excursion
(message-goto-to)
(message-delete-line)
(insert (concat "To: " cc-content "\n"))
- (message-remove-header (if bcc
- "bcc"
- "cc")))))))
+ (save-restriction
+ (message-narrow-to-headers)
+ (message-remove-header (if bcc
+ "bcc"
+ "cc"))))))))
;;; End of functions adopted from `message-utils.el'.
(define-key message-mode-map "\C-c\C-f\C-m" 'message-goto-mail-followup-to)
(define-key message-mode-map "\C-c\C-f\C-k" 'message-goto-keywords)
(define-key message-mode-map "\C-c\C-f\C-u" 'message-goto-summary)
- (define-key message-mode-map "\C-c\C-f\C-i" 'message-insert-or-toggle-importance)
- (define-key message-mode-map "\C-c\C-f\C-a" 'message-gen-unsubscribed-mft)
+ (define-key message-mode-map "\C-c\C-f\C-i"
+ 'message-insert-or-toggle-importance)
+ (define-key message-mode-map "\C-c\C-f\C-a"
+ 'message-generate-unsubscribed-mail-followup-to)
;; modify headers (and insert notes in body)
(define-key message-mode-map "\C-c\C-fs" 'message-change-subject)
;;
- (define-key message-mode-map "\C-c\C-fx" 'message-xpost-fup2)
- ;; prefix+message-xpost-fup2 = same w/o xpost
+ (define-key message-mode-map "\C-c\C-fx" 'message-cross-post-followup-to)
+ ;; prefix+message-cross-post-followup-to = same w/o cross-post
(define-key message-mode-map "\C-c\C-ft" 'message-reduce-to-to-cc)
(define-key message-mode-map "\C-c\C-fa" 'message-add-archive-header)
;; mark inserted text
(define-key message-mode-map "\C-c\M-m" 'message-mark-inserted-region)
(define-key message-mode-map "\C-c\M-f" 'message-mark-insert-file)
-
+
(define-key message-mode-map "\C-c\C-b" 'message-goto-body)
(define-key message-mode-map "\C-c\C-i" 'message-goto-signature)
(define-key message-mode-map "\C-c\C-t" 'message-insert-to)
- (define-key message-mode-map "\C-c\C-p" 'message-insert-wide-reply)
+ (define-key message-mode-map "\C-c\C-fw" 'message-insert-wide-reply)
(define-key message-mode-map "\C-c\C-n" 'message-insert-newsgroups)
(define-key message-mode-map "\C-c\C-l" 'message-to-list-only)
(define-key message-mode-map "\C-c\C-u" 'message-insert-or-toggle-importance)
- (define-key message-mode-map "\C-c\M-n" 'message-insert-disposition-notification-to)
+ (define-key message-mode-map "\C-c\M-n"
+ 'message-insert-disposition-notification-to)
(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-z" 'message-kill-to-signature)
(define-key message-mode-map "\M-\r" 'message-newline-and-reformat)
;;(define-key message-mode-map "\M-q" 'message-fill-paragraph)
+ (define-key message-mode-map [remap split-line] 'message-split-line)
(define-key message-mode-map "\C-c\C-a" 'mml-attach-file)
(easy-menu-define
message-mode-menu message-mode-map "Message Menu."
`("Message"
- ["Sort Headers" message-sort-headers t]
- ["Yank Original" message-yank-original t]
+ ["Yank Original" message-yank-original message-reply-buffer]
["Fill Yanked Message" message-fill-yanked-message t]
["Insert Signature" message-insert-signature t]
["Caesar (rot13) Message" message-caesar-buffer-body t]
- ["Caesar (rot13) Region" message-caesar-region (mark t)]
- ["Elide Region" message-elide-region (mark t)]
- ["Delete Outside Region" message-delete-not-region (mark t)]
+ ["Caesar (rot13) Region" message-caesar-region (message-mark-active-p)]
+ ["Elide Region" message-elide-region
+ :active (message-mark-active-p)
+ ,@(if (featurep 'xemacs) nil
+ '(:help "Replace text in region with an ellipsis"))]
+ ["Delete Outside Region" message-delete-not-region
+ :active (message-mark-active-p)
+ ,@(if (featurep 'xemacs) nil
+ '(:help "Delete all quoted text outside region"))]
["Kill To Signature" message-kill-to-signature t]
["Newline and Reformat" message-newline-and-reformat t]
["Rename buffer" message-rename-buffer t]
- ["Flag As Important" message-insert-importance-high
- ,@(if (featurep 'xemacs) '(t)
- '(:help "Mark this message as important"))]
- ["Flag As Unimportant" message-insert-importance-low
- ,@(if (featurep 'xemacs) '(t)
- '(:help "Mark this message as unimportant"))]
- ["Request Receipt"
- message-insert-disposition-notification-to
- ,@(if (featurep 'xemacs) '(t)
- '(:help "Request a Disposition Notification of this article"))]
["Spellcheck" ispell-message
,@(if (featurep 'xemacs) '(t)
'(:help "Spellcheck this message"))]
"----"
- ["Insert Region Marked" message-mark-inserted-region
- ,@(if (featurep 'xemacs) '(t)
+ ["Insert Region Marked" message-mark-inserted-region
+ :active (message-mark-active-p)
+ ,@(if (featurep 'xemacs) nil
'(:help "Mark region with enclosing tags"))]
- ["Insert File Marked..." message-mark-insert-file
+ ["Insert File Marked..." message-mark-insert-file
,@(if (featurep 'xemacs) '(t)
'(:help "Insert file at point marked with enclosing tags"))]
"----"
(easy-menu-define
message-mode-field-menu message-mode-map ""
- '("Field"
+ `("Field"
["Fetch To" message-insert-to t]
["Fetch Newsgroups" message-insert-newsgroups t]
"----"
["Bcc" message-goto-bcc t]
["Fcc" message-goto-fcc t]
["Reply-To" message-goto-reply-to t]
+ ["Flag As Important" message-insert-importance-high
+ ,@(if (featurep 'xemacs) '(t)
+ '(:help "Mark this message as important"))]
+ ["Flag As Unimportant" message-insert-importance-low
+ ,@(if (featurep 'xemacs) '(t)
+ '(:help "Mark this message as unimportant"))]
+ ["Request Receipt"
+ message-insert-disposition-notification-to
+ ,@(if (featurep 'xemacs) '(t)
+ '(:help "Request a receipt notification"))]
"----"
;; (typical) news stuff
["Summary" message-goto-summary t]
["Keywords" message-goto-keywords t]
["Newsgroups" message-goto-newsgroups t]
["Followup-To" message-goto-followup-to t]
- ;; ["Followup-To (with note in body)" message-xpost-fup2 t]
- ["Crosspost / Followup-To..." message-xpost-fup2 t]
+ ;; ["Followup-To (with note in body)" message-cross-post-followup-to t]
+ ["Crosspost / Followup-To..." message-cross-post-followup-to t]
["Distribution" message-goto-distribution t]
["X-No-Archive:" message-add-archive-header t ]
"----"
["Mail-Followup-To" message-goto-mail-followup-to t]
["Reduce To: to Cc:" message-reduce-to-to-cc t]
"----"
- ["Body" message-goto-body t]
- ["Signature" message-goto-signature t]))
+ ["Sort Headers" message-sort-headers t]
+ ["Encode non-ASCII domain names" message-idna-to-ascii-rhs t]
+ ["Goto Body" message-goto-body t]
+ ["Goto Signature" message-goto-signature t]))
(defvar message-tool-bar-map nil)
;; No reason this should be clutter up customize. We make it a
;; property list (rather than a list of property symbols), to be
;; directly useful for `remove-text-properties'.
- '(field nil read-only nil intangible nil invisible nil
+ '(field nil read-only nil invisible nil intangible nil
mouse-face nil modification-hooks nil insert-in-front-hooks nil
insert-behind-hooks nil point-entered nil point-left nil)
;; Other special properties:
See also `message-forbidden-properties'."
(when (and message-strip-special-text-properties
(message-tamago-not-in-use-p begin))
- (remove-text-properties begin end message-forbidden-properties)))
+ (while (not (= begin end))
+ (when (not (get-text-property begin 'message-hidden))
+ (remove-text-properties begin (1+ begin)
+ message-forbidden-properties))
+ (incf begin))))
;;;###autoload
(define-derived-mode message-mode text-mode "Message"
(set (make-local-variable 'message-checksum) nil)
(set (make-local-variable 'message-mime-part) 0)
(message-setup-fill-variables)
+ (set
+ (make-local-variable 'paragraph-separate)
+ (format "\\(%s\\)\\|\\(%s\\)"
+ paragraph-separate
+ "<#!*/?\\(multipart\\|part\\|external\\|mml\\|secure\\)"))
;; Allow using comment commands to add/remove quoting.
(set (make-local-variable 'comment-start) message-yank-prefix)
(if (featurep 'xemacs)
(set (make-local-variable 'tool-bar-map) (message-tool-bar-map))))
(easy-menu-add message-mode-menu message-mode-map)
(easy-menu-add message-mode-field-menu message-mode-map)
- ;; make-local-hook is harmless though obsolete in Emacs 21.
- ;; Emacs 20 and XEmacs need make-local-hook.
- (make-local-hook 'after-change-functions)
+ (gnus-make-local-hook 'after-change-functions)
;; Mmmm... Forbidden properties...
(add-hook 'after-change-functions 'message-strip-forbidden-properties
nil 'local)
(when (eq message-mail-alias-type 'abbrev)
(if (fboundp 'mail-abbrevs-setup)
(mail-abbrevs-setup)
- (mail-aliases-setup)))
+ (if (fboundp 'mail-aliases-setup) ; warning avoidance
+ (mail-aliases-setup))))
(unless buffer-file-name
(message-set-auto-save-file-name))
(unless (buffer-base-buffer)
(goto-char (point-max))
nil))
-(defun message-gen-unsubscribed-mft (&optional include-cc)
+(defun message-generate-unsubscribed-mail-followup-to (&optional include-cc)
"Insert a reasonable MFT header in a post to an unsubscribed list.
When making original posts to a mailing list you are not subscribed to,
you have to type in a MFT header by hand. The contents, usually, are
the addresses of the list and your own address. This function inserts
such a header automatically. It fetches the contents of the To: header
-in the current mail buffer, and appends the current user-mail-address.
+in the current mail buffer, and appends the current `user-mail-address'.
-If the optional argument `include-cc' is non-nil, the addresses in the
+If the optional argument INCLUDE-CC is non-nil, the addresses in the
Cc: header are also put into the MFT."
(interactive "P")
- (message-remove-header "Mail-Followup-To")
- (let* ((cc (and include-cc (message-fetch-field "Cc")))
- (tos (if cc
- (concat (message-fetch-field "To") "," cc)
- (message-fetch-field "To"))))
+ (let* (cc tos)
+ (save-restriction
+ (message-narrow-to-headers)
+ (message-remove-header "Mail-Followup-To")
+ (setq cc (and include-cc (message-fetch-field "Cc")))
+ (setq tos (if cc
+ (concat (message-fetch-field "To") "," cc)
+ (message-fetch-field "To"))))
(message-goto-mail-followup-to)
(insert (concat tos ", " user-mail-address))))
(let ((point (point)))
(message-goto-signature)
(unless (eobp)
- (forward-line -2))
+ (end-of-line -1))
(kill-region point (point))
(unless (bolp)
(insert "\n"))))
(delete-region (point) (re-search-forward "[ \t]*"))
(when (and quoted (not bolp))
(insert quoted leading-space)))
+ (undo-boundary)
(if quoted
(let* ((adaptive-fill-regexp
(regexp-quote (concat quoted leading-space)))
(defun message-fill-paragraph (&optional arg)
"Like `fill-paragraph'."
(interactive (list (if current-prefix-arg 'full)))
- (if (and (boundp 'filladapt-mode) filladapt-mode)
+ (if (if (boundp 'filladapt-mode) filladapt-mode)
nil
(message-newline-and-reformat arg t)
t))
((and (null message-signature)
force)
t)
- ((message-functionp message-signature)
+ ((functionp message-signature)
(funcall message-signature))
((listp message-signature)
(eval message-signature))
;; Insert the signature.
(unless (bolp)
(insert "\n"))
- (insert "\n-- \n")
+ (when message-signature-insert-empty-line
+ (insert "\n"))
+ (insert "-- \n")
(if (eq signature t)
(insert-file-contents message-signature-file)
(insert signature))
"Insert header to mark message as important."
(interactive)
(save-excursion
- (message-remove-header "Importance")
+ (save-restriction
+ (message-narrow-to-headers)
+ (message-remove-header "Importance"))
(message-goto-eoh)
(insert "Importance: high\n")))
"Insert header to mark message as unimportant."
(interactive)
(save-excursion
- (message-remove-header "Importance")
+ (save-restriction
+ (message-narrow-to-headers)
+ (message-remove-header "Importance"))
(message-goto-eoh)
(insert "Importance: low\n")))
(let ((valid '("high" "normal" "low"))
(new "high")
cur)
- (when (setq cur (message-fetch-field "Importance"))
- (message-remove-header "Importance")
- (setq new (cond ((string= cur "high")
- "low")
- ((string= cur "low")
- "normal")
- (t
- "high"))))
+ (save-restriction
+ (message-narrow-to-headers)
+ (when (setq cur (message-fetch-field "Importance"))
+ (message-remove-header "Importance")
+ (setq new (cond ((string= cur "high")
+ "low")
+ ((string= cur "low")
+ "normal")
+ (t
+ "high")))))
(message-goto-eoh)
(insert (format "Importance: %s\n" new)))))
Note that this should not be used in newsgroups."
(interactive)
(save-excursion
- (message-remove-header "Disposition-Notification-To")
+ (save-restriction
+ (message-narrow-to-headers)
+ (message-remove-header "Disposition-Notification-To"))
(message-goto-eoh)
(insert (format "Disposition-Notification-To: %s\n"
- (or (message-fetch-field "From") (message-make-from))))))
+ (or (save-excursion
+ (save-restriction
+ (message-narrow-to-headers)
+ (message-fetch-field "From")))
+ (message-make-from))))))
(defun message-elide-region (b e)
"Elide the text in the region.
(when (funcall (cadr elem))
(when (and (or (not (memq (car elem)
message-sent-message-via))
+ (not (message-fetch-field "supersedes"))
(if (or (message-gnksa-enable-p 'multiple-copies)
(not (eq (car elem) 'news)))
(y-or-n-p
(goto-char (point-max))
(unless (bolp)
(insert "\n"))
- ;; Delete all invisible text.
+ ;; Make the hidden headers visible.
+ (let ((points (message-text-with-property 'message-hidden)))
+ (when points
+ (goto-char (car points))
+ (dolist (point points)
+ (add-text-properties point (1+ point)
+ '(invisible nil intangible nil)))))
+ ;; Make invisible text visible.
+ ;; It doesn't seem as if this is useful, since the invisible property
+ ;; is clobbered by an after-change hook anyhow.
(message-check 'invisible-text
(let ((points (message-text-with-property 'invisible)))
(when points
(goto-char (car points))
(dolist (point points)
- (add-text-properties point (1+ point)
- '(invisible nil highlight t)))
+ (put-text-property point (1+ point) 'invisible nil)
+ (message-overlay-put (message-make-overlay point (1+ point))
+ 'face 'highlight))
(unless (yes-or-no-p
- "Invisible text found and made visible; continue posting? ")
+ "Invisible text found and made visible; continue sending? ")
(error "Invisible text found and made visible")))))
(message-check 'illegible-text
(let (found choice)
(when (let ((char (char-after)))
(or (< (mm-char-int char) 128)
(and (mm-multibyte-p)
- (memq (char-charset char)
- '(eight-bit-control eight-bit-graphic
- control-1)))))
- (add-text-properties (point) (1+ (point)) '(highlight t))
+ (> (length (mm-find-mime-charset-region
+ (point) (point-max)))
+ 1))))
+ (message-overlay-put (message-make-overlay (point) (1+ (point)))
+ 'face 'highlight)
(setq found t))
(forward-char)
(skip-chars-forward mm-7bit-chars))
(when found
(setq choice
- (gnus-multiple-choice
- "Illegible text found. Continue posting? "
- '((?d "Remove and continue posting")
- (?r "Replace with dots and continue posting")
- (?i "Ignore and continue posting")
+ (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")
+ (?i "Ignore non-printable characters and send")
(?e "Continue editing"))))
(if (eq choice ?e)
- (error "Illegible text found"))
+ (error "Non-printable characters"))
(message-goto-body)
(skip-chars-forward mm-7bit-chars)
(while (not (eobp))
(when (let ((char (char-after)))
(or (< (mm-char-int char) 128)
(and (mm-multibyte-p)
+ ;; Fixme: Wrong for Emacs 22 and for things
+ ;; like undecable utf-8. Should at least
+ ;; use find-coding-systems-region.
(memq (char-charset char)
'(eight-bit-control eight-bit-graphic
control-1)))))
(if (eq choice ?i)
- (remove-text-properties (point) (1+ (point)) '(highlight t))
+ (message-kill-all-overlays)
(delete-char 1)
- (if (eq choice ?r)
- (insert "."))))
+ (when (eq choice ?r)
+ (insert "."))))
(forward-char)
(skip-chars-forward mm-7bit-chars))))))
(ignore-errors
(cond
;; A simple function.
- ((message-functionp (car actions))
+ ((functionp (car actions))
(funcall (car actions)))
;; Something to be evaled.
(t
(message-remove-header "Lines")
(goto-char (point-max))
(insert "Mime-Version: 1.0\n")
- (setq header (buffer-substring (point-min) (point-max))))
+ (setq header (buffer-string)))
(goto-char (point-max))
(insert (format "Content-Type: message/partial; id=\"%s\"; number=%d; total=%d\n\n"
id n total))
(not (mail-fetch-field "mail-followup-to")))
(setq headers
(cons
- (cons "Mail-Followup-To" (message-make-mft))
+ (cons "Mail-Followup-To" (message-make-mail-followup-to))
message-required-mail-headers))
;; otherwise, delete the MFT header if the field is empty
(when (equal "" (mail-fetch-field "mail-followup-to"))
;; require one newline at the end.
(or (= (preceding-char) ?\n)
(insert ?\n))
+ (message-cleanup-headers)
+ ;; FIXME: we're inserting the courtesy copy after encoding.
+ ;; This is wrong if the courtesy copy string contains
+ ;; non-ASCII characters. -- jh
(when
(save-restriction
(message-narrow-to-headers)
(and news
(or (message-fetch-field "cc")
+ (message-fetch-field "bcc")
(message-fetch-field "to"))
- (let ((content-type (message-fetch-field "content-type")))
- (or
- (not content-type)
- (string= "text/plain"
- (car
- (mail-header-parse-content-type
- content-type)))))))
+ (let ((content-type (message-fetch-field
+ "content-type")))
+ (and
+ (or
+ (not content-type)
+ (string= "text/plain"
+ (car
+ (mail-header-parse-content-type
+ content-type))))
+ (not
+ (string= "base64"
+ (message-fetch-field
+ "content-transfer-encoding")))))))
(message-insert-courtesy-copy))
(if (or (not message-send-mail-partially-limit)
(< (point-max) message-send-mail-partially-limit)
The size limit is controlled by `message-send-mail-partially-limit'.
If you always want Gnus to send messages in one piece, set
-`message-send-mail-partially-limit' to `nil'.
+`message-send-mail-partially-limit' to nil.
")))
(mm-with-unibyte-current-buffer
(message "Sending via mail...")
;; But some systems are more broken with -f, so
;; we'll let users override this.
(if (null message-sendmail-f-is-evil)
- (list "-f" (message-make-address)))
+ (list "-f" (message-sendmail-envelope-from)))
;; These mean "report errors by mail"
;; and "deliver in background".
(if (null message-interactive) '("-oem" "-odb"))
(if resend-to-addresses
(list resend-to-addresses)
'("-t"))))))
- (unless (or (null cpr) (zerop cpr))
+ (unless (or (null cpr) (and (numberp cpr) (zerop cpr)))
(error "Sending...failed with exit value %d" cpr)))
(when message-interactive
(save-excursion
(replace-match "; "))
(if (not (zerop (buffer-size)))
(error "Sending...failed to %s"
- (buffer-substring (point-min) (point-max)))))))
+ (buffer-string))))))
(when (bufferp errbuf)
(kill-buffer errbuf)))))
;; free for -inject-arguments -- a big win for the user and for us
;; since we don't have to play that double-guessing game and the user
;; gets full control (no gestapo'ish -f's, for instance). --sj
- (if (message-functionp message-qmail-inject-args)
+ (if (functionp message-qmail-inject-args)
(funcall message-qmail-inject-args)
message-qmail-inject-args)))
;; qmail-inject doesn't say anything on it's stdout/stderr,
(smtpmail-send-it))
(defun message-canlock-generate ()
- "Return a string that is non-trival to guess.
+ "Return a string that is non-trivial to guess.
Do not use this for anything important, it is cryptographically weak."
(let (sha1-maximum-internal-length)
(sha1 (concat (message-unique-id)
(defun message-send-news (&optional arg)
(let* ((tembuf (message-generate-new-buffer-clone-locals " *message temp*"))
(case-fold-search nil)
- (method (if (message-functionp message-post-method)
+ (method (if (functionp message-post-method)
(funcall message-post-method arg)
message-post-method))
(newsgroups-field (save-restriction
(y-or-n-p
"The control code \"cmsg\" is in the subject. Really post? ")
t))
+ ;; Check long header lines.
+ (message-check 'long-header-lines
+ (let ((start (point))
+ (header nil)
+ (length 0)
+ found)
+ (while (and (not found)
+ (re-search-forward "^\\([^ \t:]+\\): " nil t))
+ (if (> (- (point) (match-beginning 0)) 998)
+ (setq found t
+ length (- (point) (match-beginning 0)))
+ (setq header (match-string-no-properties 1)))
+ (setq start (match-beginning 0))
+ (forward-line 1))
+ (if found
+ (y-or-n-p (format "Your %s header is too long (%d). Really post? "
+ header length))
+ t)))
;; Check for multiple identical headers.
(message-check 'multiple-headers
(let (found)
(length
(setq to (completing-read
"Followups to (default: no Followup-To header) "
- (mapcar (lambda (g) (list g))
+ (mapcar #'list
(cons "poster"
(message-tokenize-header
newsgroups)))))))))
;; Check "Shoot me".
(message-check 'shoot
(if (re-search-forward
- "Message-ID.*.i-did-not-set--mail-host-address--so-shoot-me" nil t)
+ "Message-ID.*.i-did-not-set--mail-host-address--so-tickle-me" nil t)
(y-or-n-p "You appear to have a misconfigured system. Really post? ")
t))
;; Check for Approved.
(if followup-to
(concat newsgroups "," followup-to)
newsgroups)))
- (post-method (if (message-functionp message-post-method)
+ (post-method (if (functionp message-post-method)
(funcall message-post-method)
message-post-method))
;; KLUDGE to handle nnvirtual groups. Doing this right
(gnus-groups-from-server method)))
errors)
(while groups
- (unless (or (equal (car groups) "poster")
- (member (car groups) known-groups))
+ (when (and (not (equal (car groups) "poster"))
+ (not (member (car groups) known-groups))
+ (not (member (car groups) errors)))
(push (car groups) errors))
(pop groups))
(cond
errors)
(y-or-n-p
(format
- "Really post to %s possibly unknown group%s: %s? "
+ "Really use %s possibly unknown group%s: %s? "
(if (= (length errors) 1) "this" "these")
(if (= (length errors) 1) "" "s")
(mapconcat 'identity errors ", "))))
(if (= (length errors) 1) "this" "these")
(if (= (length errors) 1) "" "s")
(mapconcat 'identity errors ", ")))))))
+ ;; Check continuation headers.
+ (message-check 'continuation-headers
+ (goto-char (point-min))
+ (let ((do-posting t))
+ (while (re-search-forward "^[^ \t\n][^:\n]*$" nil t)
+ (if (y-or-n-p "Fix continuation lines? ")
+ (progn
+ (goto-char (match-beginning 0))
+ (insert " "))
+ (unless (y-or-n-p "Send anyway? ")
+ (setq do-posting nil))))
+ do-posting))
;; Check the Newsgroups & Followup-To headers for syntax errors.
(message-check 'valid-newsgroups
(let ((case-fold-search t)
(lsh (% message-unique-id-char 25) 16)) 4)
(message-number-base36 (+ (nth 1 tm)
(lsh (/ message-unique-id-char 25) 16)) 4)
- ;; Append the newsreader name, because while the generated
- ;; ID is unique to this newsreader, other newsreaders might
- ;; otherwise generate the same ID via another algorithm.
+ ;; Append a given name, because while the generated ID is unique
+ ;; to this newsreader, other newsreaders might otherwise generate
+ ;; the same ID via another algorithm.
".fsf")))
(defun message-number-base36 (num len)
"Make an Organization header."
(let* ((organization
(when message-user-organization
- (if (message-functionp message-user-organization)
+ (if (functionp message-user-organization)
(funcall message-user-organization)
message-user-organization))))
- (save-excursion
- (message-set-work-buffer)
+ (with-temp-buffer
+ (mm-enable-multibyte)
(cond ((stringp organization)
(insert organization))
((and (eq t organization)
(date (mail-header-date message-reply-headers))
(msg-id (mail-header-message-id message-reply-headers)))
(when from
- (let ((stop-pos
- (string-match " *at \\| *@ \\| *(\\| *<" from)))
+ (let ((name (mail-extract-address-components from)))
(concat msg-id (if msg-id " (")
- (if (and stop-pos
- (not (zerop stop-pos)))
- (substring from 0 stop-pos) from)
+ (or (car name)
+ (nth 1 name))
"'s message of \""
(if (or (not date) (string= date ""))
"(unknown date)" date)
(defun message-make-distribution ()
"Make a Distribution header."
(let ((orig-distribution (message-fetch-reply-field "distribution")))
- (cond ((message-functionp message-distribution-function)
+ (cond ((functionp message-distribution-function)
(funcall message-distribution-function))
(t orig-distribution))))
(user-full-name))))
(when (string= fullname "&")
(setq fullname (user-login-name)))
- (save-excursion
- (message-set-work-buffer)
+ (with-temp-buffer
+ (mm-enable-multibyte)
(cond
((or (null style)
(equal fullname ""))
(aset tmp (1- (match-end 0)) ?-))
(string-match "[\\()]" tmp)))))
(insert fullname)
+ (goto-char (point-min))
+ ;; Look for a character that cannot appear unquoted
+ ;; according to RFC 822.
+ (when (re-search-forward "[^- !#-'*+/-9=?A-Z^-~]" nil 1)
+ ;; Quote fullname, escaping specials.
+ (goto-char (point-min))
+ (insert "\"")
+ (while (re-search-forward "[\"\\]" nil 1)
+ (replace-match "\\\\\\&" t))
+ (insert "\""))
(insert " <" login ">"))
(t ; 'parens or default
(insert login " (")
(defun message-user-mail-address ()
"Return the pertinent part of `user-mail-address'."
- (when user-mail-address
+ (when (and user-mail-address
+ (string-match "@.*\\." user-mail-address))
(if (string-match " " user-mail-address)
(nth 1 (mail-extract-address-components user-mail-address))
user-mail-address)))
+(defun message-sendmail-envelope-from ()
+ "Return the envelope from."
+ (cond ((eq message-sendmail-envelope-from 'header)
+ (nth 1 (mail-extract-address-components
+ (message-fetch-field "from"))))
+ ((stringp message-sendmail-envelope-from)
+ message-sendmail-envelope-from)
+ (t
+ (message-make-address))))
+
(defun message-make-fqdn ()
"Return user's fully qualified domain name."
- (let ((system-name (system-name))
- (user-mail (message-user-mail-address)))
+ (let* ((system-name (system-name))
+ (user-mail (message-user-mail-address))
+ (user-domain
+ (if (and user-mail
+ (string-match "@\\(.*\\)\\'" user-mail))
+ (match-string 1 user-mail))))
(cond
- ((and (string-match "[^.]\\.[^.]" system-name)
+ ((and message-user-fqdn
+ (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)
+ ;; `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.
system-name)
;; Try `mail-host-address'.
((and (boundp 'mail-host-address)
(stringp mail-host-address)
- (string-match "\\." mail-host-address))
+ (string-match message-valid-fqdn-regexp mail-host-address)
+ (not (string-match message-bogus-system-names mail-host-address)))
mail-host-address)
;; We try `user-mail-address' as a backup.
- ((and user-mail
- (string-match "\\." user-mail)
- (string-match "@\\(.*\\)\\'" user-mail))
- (match-string 1 user-mail))
+ ((and user-domain
+ (stringp user-domain)
+ (string-match message-valid-fqdn-regexp user-domain)
+ (not (string-match message-bogus-system-names user-domain)))
+ user-domain)
;; Default to this bogus thing.
(t
- (concat system-name ".i-did-not-set--mail-host-address--so-tickle-me")))))
+ (concat system-name
+ ".i-did-not-set--mail-host-address--so-tickle-me")))))
(defun message-make-host-name ()
"Return the name of the host."
"Send a message to the list only.
Remove all addresses but the list address from To and Cc headers."
(interactive)
- (let ((listaddr (message-make-mft t)))
+ (let ((listaddr (message-make-mail-followup-to t)))
(when listaddr
(save-excursion
(message-remove-header "to")
(message-position-on-field "To" "X-Draft-From")
(insert listaddr)))))
-(defun message-make-mft (&optional only-show-subscribed)
- "Return the Mail-Followup-To header. If passed the optional
-argument `only-show-subscribed' only return the subscribed address (and
-not the additional To and Cc header contents)."
+(defun message-make-mail-followup-to (&optional only-show-subscribed)
+ "Return the Mail-Followup-To header.
+If passed the optional argument ONLY-SHOW-SUBSCRIBED only return the
+subscribed address (and not the additional To and Cc header contents)."
(let* ((case-fold-search t)
(to (message-fetch-field "To"))
(cc (message-fetch-field "cc"))
list
msg-recipients))))))
+(defun message-idna-inside-rhs-p ()
+ "Return t iff point is inside a RHS (heuristically).
+Only works properly if header contains mailbox-list or address-list.
+I.e., calling it on a Subject: header is useless."
+ (save-restriction
+ (narrow-to-region (save-excursion (or (re-search-backward "^[^ \t]" nil t)
+ (point-min)))
+ (save-excursion (or (re-search-forward "^[^ \t]" nil t)
+ (point-max))))
+ (if (re-search-backward "[\\\n\r\t ]"
+ (save-excursion (search-backward "@" nil t)) t)
+ ;; whitespace between @ and point
+ nil
+ (let ((dquote 1) (paren 1))
+ (while (save-excursion (re-search-backward "[^\\]\"" nil t dquote))
+ (incf dquote))
+ (while (save-excursion (re-search-backward "[^\\]\(" nil t paren))
+ (incf paren))
+ (and (= (% dquote 2) 1) (= (% paren 2) 1))))))
+
+(autoload 'idna-to-ascii "idna")
+
+(defun message-idna-to-ascii-rhs-1 (header)
+ "Interactively potentially IDNA encode domain names in HEADER."
+ (let (rhs ace start startpos endpos ovl)
+ (goto-char (point-min))
+ (while (re-search-forward (concat "^" header) nil t)
+ (while (re-search-forward "@\\([^ \t\r\n>]+\\)"
+ (or (save-excursion
+ (re-search-forward "^[^ \t]" nil t))
+ (point-max))
+ t)
+ (setq rhs (match-string-no-properties 1)
+ startpos (match-beginning 1)
+ endpos (match-end 1))
+ (when (save-match-data
+ (and (message-idna-inside-rhs-p)
+ (setq ace (idna-to-ascii rhs))
+ (not (string= rhs ace))
+ (if (eq message-use-idna 'ask)
+ (unwind-protect
+ (progn
+ (setq ovl (message-make-overlay startpos
+ endpos))
+ (message-overlay-put ovl 'face 'highlight)
+ (y-or-n-p
+ (format "Replace with `%s'? " ace)))
+ (message "")
+ (message-delete-overlay ovl))
+ message-use-idna)))
+ (replace-match (concat "@" ace)))))))
+
+(defun message-idna-to-ascii-rhs ()
+ "Possibly IDNA encode non-ASCII domain names in From:, To: and Cc: headers.
+See `message-idna-encode'."
+ (interactive)
+ (when message-use-idna
+ (save-excursion
+ (save-restriction
+ (message-narrow-to-head)
+ (message-idna-to-ascii-rhs-1 "From")
+ (message-idna-to-ascii-rhs-1 "To")
+ (message-idna-to-ascii-rhs-1 "Cc")))))
+
(defun message-generate-headers (headers)
"Prepare article HEADERS.
Headers already prepared in the buffer are not modified."
(User-Agent message-newsreader)
(Expires (message-make-expires))
(case-fold-search t)
+ (optionalp nil)
header value elem)
;; First we remove any old generated headers.
(let ((headers message-deletable-headers))
(setq elem (pop headers))
(if (consp elem)
(if (eq (car elem) 'optional)
- (setq header (cdr elem))
+ (setq header (cdr elem)
+ optionalp t)
(setq header (car elem)))
(setq header elem))
(when (or (not (re-search-forward
;; The header was found. We insert a space after the
;; colon, if there is none.
(if (/= (char-after) ? ) (insert " ") (forward-char 1))
- ;; Find out whether the header is empty...
+ ;; Find out whether the header is empty.
(looking-at "[ \t]*\n[^ \t]")))
;; So we find out what value we should insert.
(setq value
;; is something that is nil, then we do not insert
;; this header.
(setq header (cdr elem))
- (or (and (message-functionp (cdr elem))
+ (or (and (functionp (cdr elem))
(funcall (cdr elem)))
(and (boundp (cdr elem))
(symbol-value (cdr elem)))))
;; this function.
(or (and (stringp (cdr elem))
(cdr elem))
- (and (message-functionp (cdr elem))
+ (and (functionp (cdr elem))
(funcall (cdr elem)))))
((and (boundp header)
(symbol-value header))
(progn
;; This header didn't exist, so we insert it.
(goto-char (point-max))
- (insert (if (stringp header) header (symbol-name header))
- ": " value)
- ;; We check whether the value was ended by a
- ;; newline. If now, we insert one.
- (unless (bolp)
- (insert "\n"))
- (forward-line -1))
+ (let ((formatter
+ (cdr (assq header message-header-format-alist))))
+ (if formatter
+ (funcall formatter header value)
+ (insert (if (stringp header)
+ header (symbol-name header))
+ ": " value))
+ ;; We check whether the value was ended by a
+ ;; newline. If now, we insert one.
+ (unless (bolp)
+ (insert "\n"))
+ (forward-line -1)))
;; The value of this header was empty, so we clear
;; totally and insert the new value.
(delete-region (point) (gnus-point-at-eol))
- (insert value))
+ ;; If the header is optional, and the header was
+ ;; empty, we con't insert it anyway.
+ (unless optionalp
+ (insert value)))
;; Add the deletable property to the headers that require it.
(and (memq header message-deletable-headers)
(progn (beginning-of-line) (looking-at "[^:]+: "))
(beginning-of-line))
(when (or (message-news-p)
(string-match "@.+\\.." secure-sender))
- (insert "Sender: " secure-sender "\n")))))))
+ (insert "Sender: " secure-sender "\n"))))
+ ;; Check for IDNA
+ (message-idna-to-ascii-rhs))))
(defun message-insert-courtesy-copy ()
"Insert a courtesy message in mail copies of combined messages."
(widen)
(forward-line 1)))
+(defun message-split-line ()
+ "Split current line, moving portion beyond point vertically down.
+If the current line has `message-yank-prefix', insert it on the new line."
+ (interactive "*")
+ (condition-case nil
+ (split-line message-yank-prefix) ;; Emacs 21.3.50+ supports arg.
+ (error
+ (split-line))))
+
+
(defun message-fill-header (header value)
(let ((begin (point))
(fill-column 78)
(sit-for 0)))
(defcustom message-beginning-of-line t
- "Whether C-a goes to beginning of header values."
+ "Whether \\<message-mode-map>\\[message-beginning-of-line]\
+ goes to beginning of header values."
:group 'message-buffers
:type 'boolean)
(defun message-beginning-of-line (&optional n)
- "Move point to beginning of header value or to beginning of line."
+ "Move point to beginning of header value or to beginning of line.
+The prefix argument N is passed directly to `beginning-of-line'.
+
+This command is identical to `beginning-of-line' if point is
+outside the message header or if the option `message-beginning-of-line'
+is nil.
+
+If point is in the message header and on a (non-continued) header
+line, move point to the beginning of the header value. If point
+is already there, move point to beginning of line. Therefore,
+repeated calls will toggle point between beginning of field and
+beginning of line."
(interactive "p")
(let ((zrs 'zmacs-region-stays))
(when (and (interactive-p) (boundp zrs))
"*")))
;; Check whether `message-generate-new-buffers' is a function,
;; and if so, call it.
- ((message-functionp message-generate-new-buffers)
+ ((functionp message-generate-new-buffers)
(funcall message-generate-new-buffers type to group))
((eq message-generate-new-buffers 'unsent)
(generate-new-buffer-name
(when message-default-mail-headers
(insert message-default-mail-headers)
(or (bolp) (insert ?\n)))
+ (save-restriction
+ (message-narrow-to-headers)
+ (if message-alternative-emails
+ (message-use-alternative-email-as-from)))
(when message-generate-headers-first
(message-generate-headers
(message-headers-to-generate
(message-insert-signature)
(save-restriction
(message-narrow-to-headers)
- (if message-alternative-emails
- (message-use-alternative-email-as-from))
(run-hooks 'message-header-setup-hook))
(set-buffer-modified-p nil)
(setq buffer-undo-list nil)
;; Allow customizations to have their say.
(if (not wide)
;; This is a regular reply.
- (when (message-functionp message-reply-to-function)
+ (when (functionp message-reply-to-function)
(save-excursion
(setq follow-to (funcall message-reply-to-function))))
;; This is a followup.
- (when (message-functionp message-wide-reply-to-function)
+ (when (functionp message-wide-reply-to-function)
(save-excursion
(setq follow-to
(funcall message-wide-reply-to-function)))))
(if (search-forward "\n\n" nil t)
(1- (point))
(point-max)))
- (when (message-functionp message-followup-to-function)
+ (when (functionp message-followup-to-function)
(setq follow-to
(funcall message-followup-to-function)))
(setq from (message-fetch-field "from")
(setq message-reply-headers
(vector 0 subject from date message-id references 0 0 ""))
-
+
(message-setup
`((Subject . ,subject)
,@(cond
cur)))
+(defun message-is-yours-p ()
+ "Non-nil means current article is yours.
+If you have added 'cancel-messages to 'message-shoot-gnksa-feet', all articles
+are yours except those that have Cancel-Lock header not belonging to you.
+Instead of shooting GNKSA feet, you should modify 'message-alternative-emails'
+regexp to match all of yours addresses."
+ ;; Canlock-logic as suggested by Per Abrahamsen
+ ;; <abraham@dina.kvl.dk>
+ ;;
+ ;; IF article has cancel-lock THEN
+ ;; IF we can verify it THEN
+ ;; issue cancel
+ ;; ELSE
+ ;; error: cancellock: article is not yours
+ ;; ELSE
+ ;; Use old rules, comparing sender...
+ (save-excursion
+ (save-restriction
+ (message-narrow-to-head-1)
+ (if (message-fetch-field "Cancel-Lock")
+ (if (null (canlock-verify))
+ t
+ (error "Failed to verify Cancel-lock: This article is not yours"))
+ (let (sender from)
+ (or
+ (message-gnksa-enable-p 'cancel-messages)
+ (and (setq sender (message-fetch-field "sender"))
+ (string-equal (downcase sender)
+ (downcase (message-make-sender))))
+ ;; 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))))))
+ ;; 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))))))))))
;;;###autoload
(defun message-cancel-news (&optional arg)
(interactive "P")
(unless (message-news-p)
(error "This is not a news article; canceling is impossible"))
- (let (from newsgroups message-id distribution buf sender)
+ (let (from newsgroups message-id distribution buf)
(save-excursion
;; Get header info from original article.
(save-restriction
(message-narrow-to-head-1)
(setq from (message-fetch-field "from")
- sender (message-fetch-field "sender")
newsgroups (message-fetch-field "newsgroups")
message-id (message-fetch-field "message-id" t)
distribution (message-fetch-field "distribution")))
;; Make sure that this article was written by the user.
- (unless (or
- ;; Canlock-logic as suggested by Per Abrahamsen
- ;; <abraham@dina.kvl.dk>
- ;;
- ;; IF article has cancel-lock THEN
- ;; IF we can verify it THEN
- ;; issue cancel
- ;; ELSE
- ;; error: cancellock: article is not yours
- ;; ELSE
- ;; Use old rules, comparing sender...
- (if (message-fetch-field "Cancel-Lock")
- (if (null (canlock-verify))
- t
- (error "Failed to verify Cancel-lock: This article is not yours"))
- nil)
- (message-gnksa-enable-p 'cancel-messages)
- (and sender
- (string-equal
- (downcase sender)
- (downcase (message-make-sender))))
- (string-equal
- (downcase (cadr (mail-extract-address-components from)))
- (downcase (cadr (mail-extract-address-components
- (message-make-from))))))
+ (unless (message-is-yours-p)
(error "This article is not yours"))
(when (yes-or-no-p "Do you really want to cancel this article? ")
;; Make control message.
This is done simply by taking the old article and adding a Supersedes
header line with the old Message-ID."
(interactive)
- (let ((cur (current-buffer))
- (sender (message-fetch-field "sender"))
- (from (message-fetch-field "from")))
+ (let ((cur (current-buffer)))
;; Check whether the user owns the article that is to be superseded.
- (unless (or
- ;; Canlock-logic as suggested by Per Abrahamsen
- ;; <abraham@dina.kvl.dk>
- ;;
- ;; IF article has cancel-lock THEN
- ;; IF we can verify it THEN
- ;; issue cancel
- ;; ELSE
- ;; error: cancellock: article is not yours
- ;; ELSE
- ;; Use old rules, comparing sender...
- (if (message-fetch-field "Cancel-Lock")
- (if (null (canlock-verify))
- t
- (error "Failed to verify Cancel-lock: This article is not yours"))
- nil)
- (message-gnksa-enable-p 'cancel-messages)
- (and sender
- (string-equal
- (downcase sender)
- (downcase (message-make-sender))))
- (string-equal
- (downcase (cadr (mail-extract-address-components from)))
- (downcase (cadr (mail-extract-address-components
- (message-make-from))))))
+ (unless (message-is-yours-p)
(error "This article is not yours"))
;; Get a normal message buffer.
(message-pop-to-buffer (message-buffer-name "supersede"))
(mail-decode-encoded-word-string prefix)))
"] " subject))
+(defun message-forward-subject-name-subject (subject)
+ "Generate a SUBJECT for a forwarded message.
+The form is: [Source] Subject, where if the original message was mail,
+Source is the name of the sender, and if the original message was
+news, Source is the list of newsgroups is was posted to."
+ (concat "["
+ (let ((prefix
+ (or (message-fetch-field "newsgroups")
+ (let ((from (message-fetch-field "from")))
+ (and from
+ (cdr (mail-header-parse-address from))))
+ "(nowhere)")))
+ (if message-forward-decoded-p
+ prefix
+ (mail-decode-encoded-word-string prefix)))
+ "] " subject))
+
(defun message-forward-subject-fwd (subject)
"Generate a SUBJECT for a forwarded message.
The form is: Fwd: Subject, where Subject is the original subject of
;; Apply funcs in order, passing subject generated by previous
;; func to the next one.
(while funcs
- (when (message-functionp (car funcs))
+ (when (functionp (car funcs))
(setq subject (funcall (car funcs) subject)))
(setq funcs (cdr funcs)))
subject))))
(not message-forward-decoded-p))
(insert
(with-temp-buffer
- (mm-disable-multibyte-mule4)
+ (mm-disable-multibyte)
(insert
(with-current-buffer forward-buffer
- (mm-string-as-unibyte (buffer-string))))
- (mm-enable-multibyte-mule4)
+ (mm-with-unibyte-current-buffer (buffer-string))))
+ (mm-enable-multibyte)
(mime-to-mml)
(goto-char (point-min))
(when (looking-at "From ")
(rmail-msg-restore-non-pruned-header)))
(message-forward-make-body forward-buffer))
+(eval-when-compile (defvar rmail-enable-mime-composing))
+
+;; Fixme: Should have defcustom.
;;;###autoload
(defun message-insinuate-rmail ()
- "Let RMAIL uses message to forward."
+ "Let RMAIL use message to forward."
(interactive)
(setq rmail-enable-mime-composing t)
(setq rmail-insert-mime-forwarded-message-function
(unless (message-mail-user-agent)
(set-buffer (get-buffer-create " *message resend*"))
(erase-buffer))
- (let ((message-this-is-mail t))
+ (let ((message-this-is-mail t)
+ message-setup-hook)
(message-setup `((To . ,address))))
;; Insert our usual headers.
(message-generate-headers '(From Date To))
(message-narrow-to-headers)
+ ;; Remove X-Draft-From header etc.
+ (message-remove-header message-ignored-mail-headers t)
;; Rename them all to "Resent-*".
+ (goto-char (point-min))
(while (re-search-forward "^[A-Za-z]" nil t)
(forward-char -1)
(insert "Resent-"))
(delete-char -2))))))
(defalias 'message-exchange-point-and-mark 'exchange-point-and-mark)
+(defalias 'message-make-overlay 'make-overlay)
+(defalias 'message-delete-overlay 'delete-overlay)
+(defalias 'message-overlay-put 'overlay-put)
+(defun message-kill-all-overlays ()
+ (if (featurep 'xemacs)
+ (map-extents (lambda (extent ignore) (delete-extent extent)))
+ (mapcar #'delete-overlay (overlays-in (point-min) (point-max)))))
;; Support for toolbar
(eval-when-compile
(defun message-tool-bar-map ()
(or message-tool-bar-map
(setq message-tool-bar-map
- (and
+ (and
(condition-case nil (require 'tool-bar) (error nil))
(fboundp 'tool-bar-add-item-from-menu)
tool-bar-mode
'mml-attach-file "attach" tool-bar-map mml-mode-map)
(message-tool-bar-local-item-from-menu
'ispell-message "spell" tool-bar-map message-mode-map)
+ (message-tool-bar-local-item-from-menu
+ 'mml-preview "preview"
+ tool-bar-map mml-mode-map)
(message-tool-bar-local-item-from-menu
'message-insert-importance-high "important"
tool-bar-map message-mode-map)
(defcustom message-completion-alist
(list (cons message-newgroups-header-regexp 'message-expand-group)
'("^\\(Resent-\\)?\\(To\\|B?Cc\\):" . message-expand-name)
- '("^\\(Reply-To\\|From\\|Mail-Followup-To\\|Mail-Copies-To\\):"
+ '("^\\(Reply-To\\|From\\|Mail-Followup-To\\|Mail-Copies-To\\):"
. message-expand-name)
- '("^\\(Disposition-Notification-To\\|Return-Receipt-To\\):"
+ '("^\\(Disposition-Notification-To\\|Return-Receipt-To\\):"
. message-expand-name))
"Alist of (RE . FUN). Use FUN for completion on header lines matching RE."
:group 'message
(list list))))
(defun message-generate-new-buffer-clone-locals (name &optional varstr)
- "Create and return a buffer with name based on NAME using `generate-new-buffer.'
+ "Create and return a buffer with name based on NAME using `generate-new-buffer'.
Then clone the local variables and values from the old buffer to the
new one, cloning only the locals having a substring matching the
-regexp varstr."
+regexp VARSTR."
(let ((oldbuf (current-buffer)))
(save-excursion
(set-buffer (generate-new-buffer name))
(cdr local)))))
locals)))
-;;; Miscellaneous functions
-
-(defsubst message-replace-chars-in-string (string from to)
- (mm-subst-char-in-string from to string))
-
;;;
;;; MIME functions
;;;
(if (and (or to cc) bcc) ", ")
(or bcc "")))))))
+(defun message-hide-headers ()
+ "Hide headers based on the `message-hidden-headers' variable."
+ (let ((regexps (if (stringp message-hidden-headers)
+ (list message-hidden-headers)
+ message-hidden-headers))
+ (inhibit-point-motion-hooks t)
+ (after-change-functions nil))
+ (when regexps
+ (save-excursion
+ (save-restriction
+ (message-narrow-to-headers)
+ (goto-char (point-min))
+ (while (not (eobp))
+ (if (not (message-hide-header-p regexps))
+ (message-next-header)
+ (let ((begin (point)))
+ (message-next-header)
+ (add-text-properties
+ begin (point)
+ '(invisible t message-hidden t))))))))))
+
+(defun message-hide-header-p (regexps)
+ (let ((result nil)
+ (reverse nil))
+ (when (eq (car regexps) 'not)
+ (setq reverse t)
+ (pop regexps))
+ (dolist (regexp regexps)
+ (setq result (or result (looking-at regexp))))
+ (if reverse
+ (not result)
+ result)))
+
(when (featurep 'xemacs)
(require 'messagexmas)
(message-xmas-redefine))
projects / gnus / blobdiff