(require 'gnus)
(require 'sendmail)
(require 'gnus-ems)
+(require 'message)
(eval-when-compile (require 'cl))
;; Added by Sudish Joseph <joseph@cis.ohio-state.edu>.
the case, the user will be queried for what select method to use when
posting.")
-(defvar gnus-organization-file "/usr/lib/news/organization"
- "*Local news organization file.")
-
-(defvar gnus-prepare-article-hook nil
- "*A hook called after preparing body, but before preparing header headers.")
-
-(defvar gnus-post-prepare-function nil
- "*Function that is run after a post buffer has been prepared.
-It is called with the name of the newsgroup that is posted to. It
-might be used, for instance, for inserting signatures based on the
-newsgroup name. (In that case, `gnus-signature-file' and
-`mail-signature' should both be set to nil).")
-
-(defvar gnus-post-prepare-hook nil
- "*Hook that is run after a post buffer has been prepared.
-If you want to insert the signature, you might put
-`gnus-inews-insert-signature' in this hook.")
-
-(defvar gnus-use-followup-to 'ask
- "*Specifies what to do with Followup-To header.
-If nil, ignore the header. If it is t, use its value, but ignore
-\"poster\". If it is the symbol `ask', query the user whether to
-ignore the \"poster\" value. If it is the symbol `use', always use
-the value.")
-
-(defvar gnus-followup-to-function nil
- "*A variable that contains a function that returns a followup address.
-The function will be called in the buffer of the article that is being
-followed up. The buffer will be narrowed to the headers of the
-article. To pick header headers, one might use `mail-fetch-field'. The
-function will be called with the name of the current newsgroup as the
-argument.
-
-Here's an example `gnus-followup-to-function':
-
-(setq gnus-followup-to-function
- (lambda (group)
- (cond ((string= group \"mail.list\")
- (or (mail-fetch-field \"sender\")
- (mail-fetch-field \"from\")))
- (t
- (or (mail-fetch-field \"reply-to\")
- (mail-fetch-field \"from\"))))))")
-
-(defvar gnus-reply-to-function nil
- "*A variable that contains a function that returns a reply address.
-See the `gnus-followup-to-function' variable for an explanation of how
-this variable is used.
-
-This function should return a string that will be used to fill in the
-header. This function may also return a list. In that case, every
-list element should be a cons where the first car should be a string
-with the header name, and the cdr should be a string with the header
-value.")
-
-(defvar gnus-author-copy (getenv "AUTHORCOPY")
- "*Save outgoing articles in this file.
-Initialized from the AUTHORCOPY environment variable.
-
-If this variable begins with the character \"|\", outgoing articles
-will be piped to the named program. It is possible to save an article
-in an MH folder as follows:
-
-\(setq gnus-author-copy \"|/usr/local/lib/mh/rcvstore +Article\")
-
-If the first character is not a pipe, articles are saved using the
-function specified by the `gnus-author-copy-saver' variable.")
-
-(defvar gnus-mail-self-blind nil
- "*Non-nil means insert a BCC header in all outgoing articles.
-This will result in having a copy of the article mailed to yourself.
-The BCC header is inserted when the post buffer is initialized, so you
-can remove or alter the BCC header to override the default.")
-
-(defvar gnus-author-copy-saver (function rmail-output)
- "*A function called to save outgoing articles.
-This function will be called with the same of the file to store the
-article in. The default function is `rmail-output' which saves in Unix
-mailbox format.")
-
(defvar gnus-outgoing-message-group nil
"*All outgoing messages will be put in this group.
If you want to store all your outgoing mail and articles in the group
of names).")
(defvar gnus-message-archive-group
- '((if (eq major-mode 'news-reply-mode) "misc-news" "misc-mail"))
+ '((if (message-news-p) "misc-news" "misc-mail"))
"*Name of the group in which to save the messages you've written.
This can either be a string, a list of strings; or an alist
of regexps/functions/forms to be evaluated to return a string (or a list
gatewayed to a newsgroup, and you want to followup to an article in
the group.")
-(defvar gnus-draft-group-directory
- (expand-file-name
- (concat (file-name-as-directory gnus-article-save-directory)
- "drafts"))
- "*The directory where draft messages will be stored.")
-
-(defvar gnus-use-draft t
- "*Whether Gnus should use the draft group.")
-
-(defvar gnus-posting-styles nil
- "*Alist of styles to use when posting.")
-
-(defvar gnus-posting-style-alist
- '((organization . gnus-organization-file)
- (signature . gnus-signature-file)
- (from . gnus-user-from-line))
- "*Mapping from style parameters to Gnus variables.")
-
-(defvar gnus-user-login-name nil
- "*The login name of the user.
-Got from the function `user-login-name' if undefined.")
-
-(defvar gnus-user-full-name nil
- "*The full name of the user.
-Got from the NAME environment variable if undefined.")
-
-(defvar gnus-user-from-line nil
- "*Your full, complete e-mail address.
-Overrides the other Gnus variables if it is non-nil.
-
-Here are two example values of this variable:
-
- \"Lars Magne Ingebrigtsen <larsi@ifi.uio.no>\"
-
-and
-
- \"larsi@ifi.uio.no (Lars Magne Ingebrigtsen)\"
-
-The first version is recommended, but the name has to be quoted if it
-contains non-alphanumerical characters.")
-
-(defvar gnus-signature-file "~/.signature"
- "*Your signature file.
-If the variable is a string that doesn't correspond to a file, the
-string itself is inserted.")
-
-(defvar gnus-signature-function nil
- "*A function that should return a signature file name.
-The function will be called with the name of the newsgroup being
-posted to.
-If the function returns a string that doesn't correspond to a file, the
-string itself is inserted.
-If the function returns nil, the `gnus-signature-file' variable will
-be used instead.")
-
-(defvar gnus-forward-start-separator
- "------- Start of forwarded message -------\n"
- "*Delimiter inserted before forwarded messages.")
-
-(defvar gnus-forward-end-separator
- "------- End of forwarded message -------\n"
- "*Delimiter inserted after forwarded messages.")
-
-(defvar gnus-signature-before-forwarded-message t
- "*If non-nil, put the signature before any included forwarded message.")
-
-(defvar gnus-forward-included-headers
- "^From:\\|^Newsgroups:\\|^Subject:\\|^Date:\\|^Followup-To:\\|^Reply-To:\\|^Organization:\\|^Summary:\\|^Keywords:\\|^To:\\|^Cc:\\|^Posted-To:\\|^Mail-Copies-To:\\|^Apparently-To:\\|^Gnus-Warning:\\|^Resent-\\|^Message-ID:\\|^References:"
- "*Regexp matching headers to be included in forwarded messages.")
-
-(defvar gnus-required-headers
- '(From Date Newsgroups Subject Message-ID Organization Lines X-Newsreader)
- "*Headers to be generated or prompted for when posting an article.
-RFC977 and RFC1036 require From, Date, Newsgroups, Subject,
-Message-ID. Organization, Lines, In-Reply-To, Expires, and
-X-Newsreader are optional. If you want Gnus not to insert some
-header, remove it from this list.")
-
-(defvar gnus-required-mail-headers
- '(From Date To Subject (optional . In-Reply-To) Message-ID Organization Lines)
- "*Headers to be generated or prompted for when mailing a message.
-RFC822 required that From, Date, To, Subject and Message-ID be
-included. Organization, Lines and X-Mailer are optional.")
-
-(defvar gnus-deletable-headers '(Message-ID Date)
- "*Headers to be deleted if they already exists and were generated by Gnus previously.")
-
-(defvar gnus-removable-headers '(NNTP-Posting-Host Xref)
- "*Headers to be removed unconditionally before posting.")
-
-(defvar gnus-ignored-resent-headers "^Return-receipt"
- "*All headers that match this regexp will be deleted when resending a message.")
-
-(defvar gnus-article-expires 14
- "*Number of days before your article expires.
-This variable isn't used unless you have the `Expires' element in
-`gnus-required-headers'.")
-
-(defvar gnus-distribution-function nil
- "*Function that should return the Distribution header for outgoing articles.
-It will be called from the buffer where the outgoing article
-is being prepared with the group name as the only parameter.
-It should return a valid distribution.
-
-The function will only be called if you have the `Distribution' header in
-`gnus-required-headers'.")
-
-(defvar gnus-check-before-posting
- '(subject-cmsg multiple-headers sendsys message-id from
- long-lines control-chars size new-text
- redirected-followup signature approved sender
- empty empty-headers)
- "In non-nil, Gnus will attempt to run some checks on outgoing posts.
-If this variable is t, Gnus will check everything it can. If it is a
-list, then those elements in that list will be checked.")
-
-(defvar gnus-delete-supersedes-headers
- "^Path:\\|^Date\\|^NNTP-Posting-Host:\\|^Supersedes:\\|^Xref:\\|^Lines:"
- "*Header lines matching this regexp will be deleted before posting.
-It's best to delete old Path and Date headers before posting to avoid
-any confusion.")
-
-(defvar gnus-auto-mail-to-author nil
- "*If non-nil, mail the authors of articles a copy of your follow-ups.
-If this variable is `ask', the user will be prompted for whether to
-mail a copy. The string given by `gnus-mail-courtesy-message' will be
-inserted at the beginning of the mail copy.")
-
-;; Added by Ethan Bradford <ethanb@ptolemy.astro.washington.edu>.
-(defvar gnus-mail-courtesy-message
- "The following message is a courtesy copy of an article\nthat has been posted as well.\n\n"
- "*This is inserted at the start of a mailed copy of a posted message.
-If this variable is nil, no such courtesy message will be added.")
-
-(defvar gnus-mail-method 'sendmail
- "*Method to use for composing mail.
-There are three legal values: `sendmail' (which is the default), `mh',
-and `vm'.")
-
-(defvar gnus-mail-reply-method (function gnus-mail-reply-using-mail)
- "*Function to compose a reply.
-Three pre-made functions are `gnus-mail-reply-using-mail' (sendmail);
-`gnus-mail-reply-using-mhe' (MH-E); and `gnus-mail-reply-using-vm'.")
-
-(defvar gnus-mail-forward-method (function gnus-mail-forward-using-mail)
- "*Function to forward the current message to another user.
-Three pre-made functions are `gnus-mail-forward-using-mail' (sendmail);
-`gnus-mail-forward-using-mhe' (MH-E); and `gnus-mail-forward-using-vm'.")
-
-(defvar gnus-mail-other-window-method 'gnus-mail-other-window-using-mail
- "*Function to compose mail in the other window.
-Three pre-made functions are `gnus-mail-other-window-using-mail'
-(sendmail); `gnus-mail-other-window-using-mhe' (MH-E); and
-`gnus-mail-other-window-using-vm'.")
-
-(defvar gnus-inews-article-function 'gnus-inews-article
- "*Function to post an article.")
-
-(defvar gnus-bounced-headers-junk "^\\(Received\\):"
- "*Regexp that matches headers to be removed in resent bounced mail.")
-
(defvar gnus-sent-message-ids-file
(concat (file-name-as-directory gnus-article-save-directory)
"Sent-Message-IDs")
(defvar gnus-sent-message-ids-length 1000
"The number of sent Message-IDs to save.")
-(defvar gnus-inews-article-hook (list 'gnus-inews-do-fcc)
- "*A hook called before finally posting an article.
-The default hook (`gnus-inews-do-fcc') does FCC processing (ie. saves
-the article to a file).")
-
-(defvar gnus-inews-article-header-hook nil
- "*A hook called after inserting the headers in an article to be posted.
-The hook is called from the *post-news* buffer, narrowed to the
-headers.")
-
-(defvar gnus-mail-hook nil
- "*A hook called as the last thing after setting up a mail buffer.")
-
-(defvar gnus-message-sent-hook nil
- "*A hook run after an article has been sent (or attempted sent).")
-
;;; Internal variables.
-(defvar gnus-post-news-buffer "*Post Gnus*")
-(defvar gnus-default-post-news-buffer gnus-post-news-buffer)
-(defvar gnus-mail-buffer "*Mail Gnus*")
-(defvar gnus-default-mail-buffer gnus-mail-buffer)
+(defvar gnus-message-buffer "*Mail Gnus*")
(defvar gnus-article-copy nil)
-(defvar gnus-reply-subject nil)
-(defvar gnus-newsgroup-followup nil)
-(defvar gnus-add-to-address nil)
-(defvar gnus-in-reply-to nil)
(defvar gnus-last-posting-server nil)
(eval-and-compile
"p" gnus-summary-post-news
"f" gnus-summary-followup
"F" gnus-summary-followup-with-original
- "b" gnus-summary-followup-and-reply
- "B" gnus-summary-followup-and-reply-with-original
"c" gnus-summary-cancel-article
"s" gnus-summary-supersede-article
"r" gnus-summary-reply
;;; Internal functions.
-(defun gnus-number-base36 (num len)
- (if (if (< len 0) (<= num 0) (= len 0))
- ""
- (concat (gnus-number-base36 (/ num 36) (1- len))
- (char-to-string (aref "zyxwvutsrqponmlkjihgfedcba9876543210"
- (% num 36))))))
+(defvar gnus-article-reply nil)
+(defmacro gnus-setup-message (config &rest forms)
+ (let ((winconf (make-symbol "winconf"))
+ (buffer (make-symbol "buffer"))
+ (article (make-symbol "article")))
+ `(let ((,winconf (current-window-configuration))
+ (,buffer (current-buffer))
+ (,article (and gnus-article-reply (gnus-summary-article-number)))
+ message-header-setup-hook)
+ (add-hook 'message-header-setup-hook 'gnus-inews-insert-gcc)
+ (add-hook 'message-header-setup-hook 'gnus-inews-insert-archive-gcc)
+ ,@forms
+ (gnus-inews-add-send-actions ,winconf ,buffer ,article)
+ (setq gnus-message-buffer (current-buffer))
+ (gnus-configure-windows ,config t))))
+
+(defun gnus-inews-add-send-actions (winconf buffer article)
+ (make-local-hook 'message-sent-hook)
+ (add-hook 'message-sent-hook 'gnus-inews-do-gcc)
+ (setq message-post-method
+ `(lambda (arg)
+ (gnus-post-method arg ,gnus-newsgroup-name)))
+ (setq message-newsreader (setq message-mailer (gnus-extended-version)))
+ (let ((actions
+ `((set-window-configuration ,winconf)
+ ((lambda ()
+ (when (buffer-name ,buffer)
+ (set-buffer ,buffer)
+ ,(when article
+ `(gnus-summary-mark-article-as-replied ,article))))))))
+ (setq message-send-actions (append message-send-actions actions))))
+
+(put 'gnus-setup-message 'lisp-indent-function 1)
+(put 'gnus-setup-message 'lisp-indent-hook 1)
;;; Post news commands of Gnus group mode and summary mode
(defun gnus-group-mail ()
"Start composing a mail."
(interactive)
- (gnus-new-mail
- ;; We might want to prompt here.
- (when (and gnus-interactive-post
- (not gnus-expert-user))
- (read-string "To: ")))
- (gnus-configure-windows 'group-mail 'force))
+ (gnus-setup-message 'message
+ (message-mail)))
(defun gnus-group-post-news (&optional arg)
"Post an article.
also do this by calling this function from the bottom of the Group
buffer."
(interactive "P")
- (let ((gnus-newsgroup-name nil)
- (group (unless arg (gnus-group-group-name))))
- ;; We might want to prompt here.
- (when (and gnus-interactive-post
- (not gnus-expert-user))
- (setq gnus-newsgroup-name
- (setq group
- (completing-read "Group: " gnus-active-hashtb nil nil
- (cons (or group "") 0)))))
- (gnus-post-news 'post group nil gnus-article-buffer)
- (if (eq major-mode 'news-reply-mode)
- (gnus-configure-windows 'group-post t)
- (gnus-configure-windows 'group-mail t))))
+ (gnus-setup-message 'message
+ (let ((gnus-newsgroup-name nil)
+ (group (unless arg (gnus-group-group-name))))
+ ;; We might want to prompt here.
+ (when (and gnus-interactive-post
+ (not gnus-expert-user))
+ (setq gnus-newsgroup-name
+ (setq group
+ (completing-read "Group: " gnus-active-hashtb nil nil
+ (cons (or group "") 0)))))
+ (gnus-post-news 'post group))))
(defun gnus-summary-post-news ()
"Post an article."
(gnus-set-global-variables)
(gnus-post-news 'post gnus-newsgroup-name))
-(defun gnus-summary-followup (yank &optional yank-articles force-news)
+(defun gnus-summary-followup (yank &optional force-news)
"Compose a followup to an article.
If prefix argument YANK is non-nil, original article is yanked automatically."
- (interactive "P")
+ (interactive
+ (list (and current-prefix-arg
+ (gnus-summary-work-articles 1))))
(gnus-set-global-variables)
- (if yank-articles (gnus-summary-goto-subject (car yank-articles)))
+ (when yank
+ (gnus-summary-goto-subject (car yank)))
(save-window-excursion
(gnus-summary-select-article))
(let ((headers (gnus-summary-article-header (gnus-summary-article-number)))
(gnus-newsgroup-name gnus-newsgroup-name))
- ;; Check Followup-To: poster.
- (set-buffer gnus-article-buffer)
- (if (and gnus-use-followup-to
- (string-equal "poster" (gnus-fetch-field "followup-to"))
- (or (not (memq gnus-use-followup-to '(t ask)))
- (not (gnus-y-or-n-p
- "Do you want to ignore `Followup-To: poster'? "))))
- ;; Mail to the poster.
- (progn
- (set-buffer gnus-summary-buffer)
- (gnus-summary-reply yank))
- ;; Send a followup.
- (gnus-post-news nil gnus-newsgroup-name
- headers gnus-article-buffer
- (or yank-articles (not (not yank)))
- nil force-news))))
+ ;; Send a followup.
+ (gnus-post-news nil gnus-newsgroup-name
+ headers gnus-article-buffer
+ yank nil force-news)))
(defun gnus-summary-followup-with-original (n &optional force-news)
"Compose a followup to an article and include the original article."
(interactive "P")
- (gnus-summary-followup t (gnus-summary-work-articles n) force-news))
+ (gnus-summary-followup (gnus-summary-work-articles n) force-news))
-;; Suggested by Daniel Quinlan <quinlan@best.com>.
-(defun gnus-summary-followup-and-reply (yank &optional yank-articles)
- "Compose a followup and do an auto mail to author."
- (interactive "P")
- (gnus-set-global-variables)
- (let ((gnus-auto-mail-to-author 'force))
- (gnus-summary-followup yank yank-articles)))
-
-(defun gnus-summary-followup-and-reply-with-original (n)
- "Compose a followup, include the original, and do an auto mail to author."
- (interactive "P")
- (gnus-summary-followup-and-reply t (gnus-summary-work-articles n)))
+(defun gnus-inews-yank-articles (articles)
+ (let (beg article)
+ (while (setq article (pop articles))
+ (save-window-excursion
+ (set-buffer gnus-summary-buffer)
+ (gnus-summary-select-article nil nil nil article)
+ (gnus-summary-remove-process-mark article))
+ (gnus-copy-article-buffer)
+ (let ((message-reply-buffer gnus-article-copy)
+ (message-reply-headers gnus-current-headers))
+ (message-yank-original)
+ (setq beg (or beg (mark t))))
+ (when articles (insert "\n")))
+ (set-marker (mark-marker) (point))
+ (goto-char beg)))
(defun gnus-summary-cancel-article (n)
"Cancel an article you posted."
(while (setq article (pop articles))
(when (gnus-summary-select-article t nil nil article)
(when (gnus-eval-in-buffer-window
- gnus-original-article-buffer (gnus-cancel-news))
+ gnus-original-article-buffer (message-cancel-news))
(gnus-summary-mark-as-read article gnus-canceled-mark))
(gnus-article-hide-headers-if-wanted))
(gnus-summary-remove-process-mark article))))
header line with the old Message-ID."
(interactive)
(gnus-set-global-variables)
- (gnus-summary-select-article t)
- ;; Check whether the user owns the article that is to be superseded.
- (unless (string-equal
- (downcase (gnus-mail-strip-quoted-names
- (mail-header-from gnus-current-headers)))
- (downcase (gnus-mail-strip-quoted-names (gnus-inews-user-name))))
- (error "This article is not yours."))
- ;; Get a normal *Post News* buffer.
- (gnus-new-news gnus-newsgroup-name t)
- (erase-buffer)
- (insert-buffer-substring gnus-original-article-buffer)
- (nnheader-narrow-to-headers)
- ;; Remove unwanted headers.
- (when gnus-delete-supersedes-headers
- (nnheader-remove-header gnus-delete-supersedes-headers t))
- (goto-char (point-min))
- (if (not (re-search-forward "^Message-ID: " nil t))
- (error "No Message-ID in this article")
- (replace-match "Supersedes: " t t))
- (goto-char (point-max))
- (insert mail-header-separator)
- (widen)
- (forward-line 1))
+ (gnus-setup-message 'reply-yank
+ (gnus-summary-select-article t)
+ (set-buffer gnus-original-article-buffer)
+ (message-supersede)))
\f
-;;;###autoload
-(defalias 'sendnews 'gnus-post-news)
-
-;;;###autoload
-(defalias 'postnews 'gnus-post-news)
(defun gnus-copy-article-buffer (&optional article-buffer)
;; make a copy of the article buffer with all text properties removed
(widen)
(copy-to-buffer gnus-article-copy (point-min) (point-max))
(gnus-set-text-properties (point-min) (point-max)
- nil gnus-article-copy)))))
+ nil gnus-article-copy)))
+ gnus-article-copy))
(defun gnus-post-news (post &optional group header article-buffer yank subject
force-news)
- "Begin editing a new USENET news article to be posted.
-Type \\[describe-mode] in the buffer to get a list of commands."
- (interactive (list t))
- (let* ((group (or group gnus-newsgroup-name))
- (pgroup group)
- to-address to-group mailing-list to-list)
- (when group
- (setq to-address (gnus-group-get-parameter group 'to-address)
- to-group (gnus-group-get-parameter group 'to-group)
- to-list (gnus-group-get-parameter group 'to-list)
- mailing-list (when gnus-mailing-list-groups
- (string-match gnus-mailing-list-groups group))
- group (gnus-group-real-name group)))
- (if (or (and to-group
- (gnus-news-group-p to-group))
- force-news
- (and (gnus-news-group-p
- (or pgroup gnus-newsgroup-name)
- (if header (mail-header-number header) gnus-current-article))
- (not mailing-list)
- (not to-list)
- (not to-address)))
- ;; This is news.
- (if post
- (gnus-new-news (or to-group group))
- (gnus-news-followup yank (or to-group group)))
- ;; The is mail.
- (if post
- (progn
- (gnus-new-mail (or to-address to-list))
- ;; Arrange for mail groups that have no `to-address' to
- ;; get that when the user sends off the mail.
- (unless to-address
- (make-local-variable 'gnus-add-to-address)
- (setq gnus-add-to-address group)))
- (gnus-mail-reply yank to-address 'followup)))))
-
-(defun gnus-post-method (group query-method &optional silent)
- "Return the posting method based on GROUP and query-method.
+ (when article-buffer
+ (gnus-copy-article-buffer))
+ (let ((gnus-article-reply article-buffer))
+ (gnus-setup-message (cond (yank 'reply-yank)
+ (article-buffer 'reply)
+ (t 'message))
+ (let* ((group (or group gnus-newsgroup-name))
+ (pgroup group)
+ to-address to-group mailing-list to-list)
+ (when group
+ (setq to-address (gnus-group-get-parameter group 'to-address)
+ to-group (gnus-group-get-parameter group 'to-group)
+ to-list (gnus-group-get-parameter group 'to-list)
+ mailing-list (when gnus-mailing-list-groups
+ (string-match gnus-mailing-list-groups group))
+ group (gnus-group-real-name group)))
+ (if (or (and to-group
+ (gnus-news-group-p to-group))
+ force-news
+ (and (gnus-news-group-p
+ (or pgroup gnus-newsgroup-name)
+ (if header (mail-header-number header)
+ gnus-current-article))
+ (not mailing-list)
+ (not to-list)
+ (not to-address)))
+ ;; This is news.
+ (if post
+ (message-news (or to-group group))
+ (set-buffer gnus-article-copy)
+ (message-followup))
+ ;; The is mail.
+ (if post
+ (progn
+ (message-mail (or to-address to-list))
+ ;; Arrange for mail groups that have no `to-address' to
+ ;; get that when the user sends off the mail.
+ (push (list 'gnus-inews-add-to-address group)
+ message-send-actions))
+ (set-buffer gnus-article-copy)
+ (message-wide-reply to-address)))
+ (when yank
+ (gnus-inews-yank-articles yank))))))
+
+(defun gnus-post-method (arg group &optional silent)
+ "Return the posting method based on GROUP and ARG.
If SILENT, don't prompt the user."
- (let ((group-method (if (stringp group)
- (gnus-find-method-for-group group)
- group)))
+ (let ((group-method (gnus-find-method-for-group group)))
(cond
;; If the group-method is nil (which shouldn't happen) we use
;; the default method.
- ((null group-method)
- (or gnus-post-method gnus-select-method))
+ ((null arg)
+ (or gnus-post-method gnus-select-method message-post-method))
;; We want this group's method.
- ((and query-method (not (eq query-method 0)))
+ ((and arg (not (eq arg 0)))
group-method)
;; We query the user for a post method.
- ((or query-method
+ ((or arg
(and gnus-post-method
(listp (car gnus-post-method))))
(let* ((methods
(or (gnus-member-of-valid 'post group) ; Ordinary news group.
(and (gnus-member-of-valid 'post-mail group) ; Combined group.
(eq (gnus-request-type group article) 'news))))
-
-(defun gnus-inews-news (&optional use-group-method)
- "Send a news message.
-
-If given a non-zero prefix and the group is a foreign group, this
-function will attempt to use the foreign server to post the article.
-
-If given an zero prefix, the user will be prompted for a posting
-method to use."
- (interactive "P")
- (unless (gnus-alive-p)
- (error "Gnus is dead; you can't post anything."))
- (or gnus-current-select-method
- (setq gnus-current-select-method gnus-select-method))
- (let* ((case-fold-search nil)
- (reply gnus-article-reply)
- error post-result)
- (save-excursion
- (gnus-start-news-server) ;Use default server.
- (widen)
- (goto-char (point-min))
- (run-hooks 'news-inews-hook)
-
- ;; Send to server.
- (gnus-message 5 "Posting to USENET...")
- (setq post-result (funcall gnus-inews-article-function use-group-method))
- (cond
- ((eq post-result 'illegal)
- (setq error t)
- (ding))
- (post-result
- (gnus-message 5 "Posting to USENET...done")
- (set-buffer-modified-p nil)
- ;; We mark the article as replied.
- (when (gnus-buffer-exists-p (car-safe reply))
- (save-excursion
- (set-buffer gnus-summary-buffer)
- (gnus-summary-mark-article-as-replied (cdr reply)))))
- (t
- ;; We cannot signal an error.
- (setq error t)
- (ding)
- (gnus-message
- 1 "Article rejected: %s"
- (gnus-status-message
- (gnus-post-method gnus-newsgroup-name use-group-method t))))))
-
- (let ((conf gnus-prev-winconf))
- (unless error
- (bury-buffer)
- ;; Restore last window configuration.
- (and conf (set-window-configuration conf))))))
(defun gnus-inews-narrow-to-headers ()
(widen)
(point-max)))
(goto-char (point-min)))
-(defun gnus-inews-send-mail-copy ()
- ;; Mail the message if To, Bcc or Cc exists.
- (let* ((types '("to" "bcc" "cc"))
- (ty types)
- (buffer (current-buffer)))
- (save-restriction
- (widen)
- (gnus-inews-narrow-to-headers)
-
- (while ty
- (or (mail-fetch-field (car ty) nil t)
- (setq types (delete (car ty) types)))
- (setq ty (cdr ty)))
-
- (if (not types)
- ;; We do not want to send mail.
- ()
- (gnus-message 5 "Sending via mail...")
- (widen)
- (save-excursion
- ;; We copy the article over to a temp buffer since we are
- ;; going to modify it a little.
- (nnheader-set-temp-buffer " *Gnus-mailing*")
- (insert-buffer-substring buffer)
- ;; We remove Fcc, because we don't want the mailer to see
- ;; that header.
- (gnus-inews-narrow-to-headers)
- (nnheader-remove-header "fcc")
-
- ;; Insert the X-Courtesy-Message header.
- (and (or (member "to" types)
- (member "cc" types))
- (progn
- (goto-char (point-max))
- (insert "Posted-To: "
- (mail-fetch-field "newsgroups") "\n")))
-
- (widen)
-
- (if (and gnus-mail-courtesy-message
- (or (member "to" types)
- (member "cc" types)))
- ;; We only want to insert the courtesy mail message if
- ;; we use To or Cc; Bcc should not have one. Well, if
- ;; both Bcc and To are present, it will get one
- ;; anyway.
- (progn
- ;; Insert "courtesy" mail message.
- (goto-char (point-min))
- (re-search-forward
- (concat "^" (regexp-quote mail-header-separator) "$"))
- (forward-line 1)
- (insert gnus-mail-courtesy-message)))
-
- (gnus-mail-send t)
- (kill-buffer (current-buffer))
- (gnus-message 5 "Sending via mail...done"))))))
-
-(defun gnus-inews-remove-headers-after-mail ()
- (save-excursion
- (save-restriction
- (let ((case-fold-search t))
- (gnus-inews-narrow-to-headers)
- ;; Remove Bcc completely.
- (nnheader-remove-header "bcc")
- ;; We transform To and Cc headers to avoid re-mailing if the user
- ;; accidentally (or purposefully) leans on the `C-c C-c' keys
- ;; and the news server rejects the posting.
- (while (re-search-forward "^\\(to\\|[bcf]cc\\|cc\\):" nil t)
- (beginning-of-line)
- (insert "X-"))
- (widen)))))
-
-(defun gnus-inews-dex-headers ()
- "Remove \"X-\" prefixes from To and Cc headers."
- (save-excursion
- (save-restriction
- (let ((case-fold-search t))
- (nnheader-narrow-to-headers)
- (while (re-search-forward "^X-\\(to\\|[bcf]cc\\|cc\\):" nil t)
- (beginning-of-line)
- (delete-char 2))
- (widen)))))
-
-(defun gnus-inews-remove-empty-headers ()
- "Remove empty headers from news and mail.
-The buffer should be narrowed to the headers before this function is
-called."
- (save-excursion
- (goto-char (point-min))
- (while (re-search-forward "^[^ \t:]+:\\([ \t]*\n\\)+[^ \t]" nil t)
- (delete-region (match-beginning 0) (1- (match-end 0)))
- (beginning-of-line))))
-
-(defun gnus-inews-check-post ()
- "Check whether the post looks ok."
- (or
- (not gnus-check-before-posting)
- (and
- ;; We narrow to the headers and check them first.
- (save-excursion
- (save-restriction
- (gnus-inews-narrow-to-headers)
- (and
- ;; Check for commands in Subject.
- (or
- (gnus-check-before-posting 'subject-cmsg)
- (save-excursion
- (if (string-match "^cmsg " (mail-fetch-field "subject"))
- (gnus-y-or-n-p
- "The control code \"cmsg \" is in the subject. Really post? ")
- t)))
- ;; Check for multiple identical headers.
- (or (gnus-check-before-posting 'multiple-headers)
- (save-excursion
- (let (found)
- (while (and (not found)
- (re-search-forward "^[^ \t:]+: " nil t))
- (save-excursion
- (or (re-search-forward
- (concat "^" (setq found
- (buffer-substring
- (match-beginning 0)
- (- (match-end 0) 2))))
- nil t)
- (setq found nil))))
- (if found
- (gnus-y-or-n-p
- (format "Multiple %s headers. Really post? " found))
- t))))
- ;; Check for Version and Sendsys.
- (or (gnus-check-before-posting 'sendsys)
- (save-excursion
- (if (re-search-forward "^Sendsys:\\|^Version:" nil t)
- (gnus-y-or-n-p
- (format "The article contains a %s command. Really post? "
- (buffer-substring (match-beginning 0)
- (1- (match-end 0)))))
- t)))
- ;; Check for Approved.
- (or (gnus-check-before-posting 'approved)
- (save-excursion
- (if (re-search-forward "^Approved:" nil t)
- (gnus-y-or-n-p
- "The article contains an Approved header. Really post? ")
- t)))
- ;; Check whether a Followup-To has redirected the newsgroup.
- (or
- (gnus-check-before-posting 'redirected-followup)
- (not gnus-newsgroup-followup)
- (save-excursion
- (let ((followups (gnus-tokenize-header
- (mail-fetch-field "Newsgroups")))
- (newsgroups (gnus-tokenize-header
- (car gnus-newsgroup-followup))))
- (while (and followups
- (member (car followups) newsgroups))
- (setq followups (cdr followups)))
- (if (not followups)
- t
- (gnus-y-or-n-p
- "Followup redirected from original newsgroups. Really post? "
- )))))
- ;; Check the Message-ID header.
- (or (gnus-check-before-posting 'message-id)
- (save-excursion
- (let* ((case-fold-search t)
- (message-id (mail-fetch-field "message-id")))
- (or (not message-id)
- (and (string-match "@" message-id)
- (string-match "@[^\\.]*\\." message-id))
- (gnus-y-or-n-p
- (format
- "The Message-ID looks strange: \"%s\". Really post? "
- message-id))))))
- ;; Check whether any headers are empty.
- (or (gnus-check-before-posting 'empty-headers)
- (save-excursion
- (let ((post t))
- (goto-char (point-min))
- (while (and post (not (eobp)))
- (when (looking-at "\\([^ :]+\\):[ \t]\n[^ \t]")
- (setq post
- (gnus-y-or-n-p
- (format
- "The %s header is empty. Really post? "
- (match-string 1)))))
- (forward-line 1))
- post)))
- ;; Check the From header.
- (or
- (gnus-check-before-posting 'from)
- (save-excursion
- (let* ((case-fold-search t)
- (from (mail-fetch-field "from")))
- (cond
- ((not from)
- (gnus-y-or-n-p "There is no From line. Really post? "))
- ((not (string-match "@[^\\.]*\\." from))
- (gnus-y-or-n-p
- (format
- "The address looks strange: \"%s\". Really post? " from)))
- ((string-match "(.*).*(.*)" from)
- (gnus-y-or-n-p
- (format
- "The From header looks strange: \"%s\". Really post? "
- from)))
- ((string-match "<[^>]+> *$" from)
- (let ((name (substring from 0 (match-beginning 0))))
- (or
- (string-match "^ *\"[^\"]*\" *$" name)
- (not (string-match "[][.!()<>@,;:\\]" name))
- (gnus-y-or-n-p
- (format
- "The From header name has bogus characters. Really post? "
- from)))))
- (t t)))))
- )))
- ;; Check for long lines.
- (or (gnus-check-before-posting 'long-lines)
- (save-excursion
- (goto-char (point-min))
- (re-search-forward
- (concat "^" (regexp-quote mail-header-separator) "$"))
- (while (and
- (progn
- (end-of-line)
- (< (current-column) 80))
- (zerop (forward-line 1))))
- (or (bolp)
- (eobp)
- (gnus-y-or-n-p
- "You have lines longer than 79 characters. Really post? "))))
- ;; Check whether the article is empty.
- (or (gnus-check-before-posting 'empty)
- (save-excursion
- (goto-char (point-min))
- (re-search-forward
- (concat "^" (regexp-quote mail-header-separator) "$"))
- (forward-line 1)
- (or (re-search-forward "[^ \n\t]" nil t)
- (gnus-y-or-n-p "Empty article. Really post?"))))
- ;; Check for control characters.
- (or (gnus-check-before-posting 'control-chars)
- (save-excursion
- (if (re-search-forward "[\000-\007\013\015-\037\200-\237]" nil t)
- (gnus-y-or-n-p
- "The article contains control characters. Really post? ")
- t)))
- ;; Check excessive size.
- (or (gnus-check-before-posting 'size)
- (if (> (buffer-size) 60000)
- (gnus-y-or-n-p
- (format "The article is %d octets long. Really post? "
- (buffer-size)))
- t))
- ;; Use the (size . checksum) variable to see whether the
- ;; article is empty or has only quoted text.
- (or
- (gnus-check-before-posting 'new-text)
- (not gnus-article-check-size)
- (if (and (= (buffer-size) (car gnus-article-check-size))
- (= (gnus-article-checksum) (cdr gnus-article-check-size)))
- (gnus-y-or-n-p
- "It looks like there's no new text in your article. Really post? ")
- t))
- ;; Check the length of the signature.
- (or (gnus-check-before-posting 'signature)
- (progn
- (goto-char (point-max))
- (if (not (re-search-backward gnus-signature-separator nil t))
- t
- (if (> (count-lines (point) (point-max)) 5)
- (gnus-y-or-n-p
- (format
- "Your .sig is %d lines; it should be max 4. Really post? "
- (count-lines (point) (point-max))))
- t)))))))
+;;;
+;;; Check whether the message has been sent already.
+;;;
(defvar gnus-inews-sent-ids nil)
(current-buffer)))
nil)))))
-(defun gnus-tokenize-header (header &optional separator)
- "Split HEADER into a list of header elements.
-\",\" is used as the separator."
- (let* ((beg 0)
- (separator (or separator ","))
- (regexp
- (format "[ \t]*\\([^%s]+\\)?\\([%s]+\\|\\'\\)" separator separator))
- elems)
- (while (and (string-match regexp header beg)
- (< beg (length header)))
- (when (match-beginning 1)
- (push (match-string 1 header) elems))
- (setq beg (match-end 0)))
- (nreverse elems)))
-
(defun gnus-article-checksum ()
(let ((sum 0))
(save-excursion
(forward-char 1)))
sum))
-;; Returns non-nil if this type is not to be checked.
-(defun gnus-check-before-posting (type)
- (not
- (or (not gnus-check-before-posting)
- (if (listp gnus-check-before-posting)
- (memq type gnus-check-before-posting)
- t))))
-
-(defun gnus-cancel-news ()
- "Cancel an article you posted."
- (interactive)
- (if (or gnus-expert-user
- (gnus-yes-or-no-p "Do you really want to cancel this article? "))
- (let ((from nil)
- (newsgroups nil)
- (message-id nil)
- (distribution nil))
- (or (gnus-news-group-p gnus-newsgroup-name)
- (error "This backend does not support canceling"))
- (save-excursion
- ;; Get header info. from original article.
- (save-restriction
- (gnus-article-show-all-headers)
- (goto-char (point-min))
- (search-forward "\n\n" nil 'move)
- (narrow-to-region (point-min) (point))
- (setq from (mail-fetch-field "from"))
- (setq newsgroups (mail-fetch-field "newsgroups"))
- (setq message-id (mail-fetch-field "message-id"))
- (setq distribution (mail-fetch-field "distribution")))
- ;; Verify if the article is absolutely user's by comparing
- ;; user id with value of its From: field.
- (if (not
- (string-equal
- (downcase (gnus-mail-strip-quoted-names from))
- (downcase (gnus-mail-strip-quoted-names
- (gnus-inews-user-name)))))
- (progn
- (ding) (gnus-message 3 "This article is not yours.")
- nil)
- ;; Make control article.
- (set-buffer (get-buffer-create " *Gnus-canceling*"))
- (buffer-disable-undo (current-buffer))
- (erase-buffer)
- (insert "Newsgroups: " newsgroups "\n"
- "From: " (gnus-inews-user-name) "\n"
- "Subject: cancel " message-id "\n"
- "Control: cancel " message-id "\n"
- (if distribution
- (concat "Distribution: " distribution "\n")
- "")
- mail-header-separator "\n"
- "This is a cancel message from " from ".\n")
- ;; Send the control article to NNTP server.
- (gnus-message 5 "Canceling your article...")
- (prog1
- (if (funcall gnus-inews-article-function)
- (gnus-message 5 "Canceling your article...done")
- (progn
- (ding)
- (gnus-message 1 "Cancel failed; %s"
- (gnus-status-message gnus-newsgroup-name))
- nil)
- t)
- ;; Kill the article buffer.
- (kill-buffer (current-buffer))))))))
-
-(defun gnus-inews-remove-signature ()
- "Remove the signature from the text between point and mark.
-The text will also be indented the normal way.
-This function can be used in `mail-citation-hook', for instance."
- (save-excursion
- (let ((start (point))
- mark)
- (if (not (re-search-forward gnus-signature-separator (mark t) t))
- ;; No signature here, so we just indent the cited text.
- (mail-indent-citation)
- ;; Find the last non-empty line.
- (forward-line -1)
- (while (looking-at "[ \t]*$")
- (forward-line -1))
- (forward-line 1)
- (setq mark (set-marker (make-marker) (point)))
- (goto-char start)
- (mail-indent-citation)
- ;; Enable undoing the deletion.
- (undo-boundary)
- (delete-region mark (mark t))
- (set-marker mark nil)))))
-
\f
;; Dummy to avoid byte-compile warning.
(defvar nnspool-rejected-article-hook)
-(defun gnus-inews-article (&optional use-group-method)
- "Post an article in current buffer using NNTP protocol."
- (let ((artbuf (current-buffer))
- gcc result)
- (widen)
- (goto-char (point-max))
- ;; Require a newline at the end of the buffer since inews may
- ;; append a .signature.
- (or (= (preceding-char) ?\n)
- (insert ?\n))
- ;; Prepare article headers. All message body such as signature
- ;; must be inserted before Lines: field is prepared.
- (save-restriction
- (gnus-inews-narrow-to-headers)
- ;; Fix some headers.
- (gnus-inews-cleanup-headers)
- ;; Remove some headers.
- (gnus-inews-remove-headers)
- ;; Insert some headers.
- (gnus-inews-insert-headers)
- ;; Let the user do all of the above.
- (run-hooks 'gnus-inews-article-header-hook)
- ;; Copy the Gcc header, if any.
- (setq gcc (mail-fetch-field "gcc"))
- (widen))
- ;; Check whether the article is a good Net Citizen.
- (if (not (gnus-inews-check-post))
- ;; Aber nein!
- 'illegal
- ;; We fudge a hook for nnspool.
- (setq nnspool-rejected-article-hook
- `((lambda ()
- (condition-case ()
- (save-excursion
- (set-buffer ,(buffer-name))
- (gnus-associate-buffer-with-draft nil 'silent))
- (error
- (ding)
- (gnus-message
- 1 "Couldn't enter rejected article into draft group"))))))
-
- ;; Looks ok, so we do the nasty.
- (save-excursion
- ;; This hook may insert a signature.
- (save-excursion
- (goto-char (point-min))
- (let ((gnus-newsgroup-name (or (mail-fetch-field "newsgroups")
- gnus-newsgroup-name)))
- (run-hooks 'gnus-prepare-article-hook)))
- ;; Send off copies using mail, if that is wanted.
- (gnus-inews-send-mail-copy)
- ;; Remove more headers.
- (gnus-inews-remove-headers-after-mail)
- ;; Copy the article over to a temp buffer.
- (nnheader-set-temp-buffer " *Gnus-posting*")
- (insert-buffer-substring artbuf)
- ;; Remove the header separator.
- (goto-char (point-min))
- (re-search-forward
- (concat "^" (regexp-quote mail-header-separator) "$"))
- (replace-match "" t t)
- ;; Remove X- prefixes to headers.
- (gnus-inews-dex-headers)
- ;; Run final inews hooks. This hook may do FCC.
- ;; The article must be saved before being posted because
- ;; `gnus-request-post' modifies the buffer.
- (save-window-excursion
- (switch-to-buffer (current-buffer))
- (run-hooks 'gnus-inews-article-hook))
- ;; Copy the article over to some group, possibly.
- (and gcc (gnus-inews-do-gcc gcc))
- ;; Post the article.
- (setq result (gnus-request-post
- (gnus-post-method gnus-newsgroup-name use-group-method)))
- (kill-buffer (current-buffer)))
- (run-hooks 'gnus-message-sent-hook)
- ;; If the posting was unsuccessful (that it, it was rejected) we
- ;; put it into the draft group.
- (or result (gnus-associate-buffer-with-draft))
- result)))
-
-(defun gnus-inews-cleanup-headers ()
- ;; Remove empty lines in the header.
- (save-restriction
- (gnus-inews-narrow-to-headers)
- (while (re-search-forward "^[ \t]*\n" nil t)
- (replace-match "" t t)))
-
- ;; Correct newsgroups field: change sequence of spaces to comma and
- ;; eliminate spaces around commas. Eliminate imbedded line breaks.
- (goto-char (point-min))
- (when (re-search-forward "^Newsgroups: +" nil t)
- (save-restriction
- (narrow-to-region
- (point)
- (if (re-search-forward "^[^ \t]" nil t)
- (match-beginning 0)
- (forward-line 1)
- (point)))
- (goto-char (point-min))
- (while (re-search-forward "\n[ \t]+" nil t)
- (replace-match " " t t)) ;No line breaks (too confusing)
- (goto-char (point-min))
- (while (re-search-forward "[ \t\n]*,[ \t\n]*\\|[ \t]+" nil t)
- (replace-match "," t t))
- (goto-char (point-min))
- ;; Remove trailing commas.
- (when (re-search-forward ",+$" nil t)
- (replace-match "" t t))))
-
- ;; Added by Per Abrahamsen <abraham@iesd.auc.dk>.
- ;; Help save the the world!
- (unless gnus-expert-user
- (let ((newsgroups (mail-fetch-field "newsgroups"))
- (followup-to (mail-fetch-field "followup-to"))
- to)
- (when (and newsgroups (string-match "," newsgroups)
- (not followup-to)
- (not
- (zerop
- (length
- (setq to (completing-read
- "Followups to: (default all groups) "
- (mapcar (lambda (g) (list g))
- (cons "poster"
- (gnus-tokenize-header
- newsgroups)))))))))
- (goto-char (point-min))
- (insert "Followup-To: " to "\n"))))
-
- ;; Cleanup Followup-To.
- (goto-char (point-min))
- (when (search-forward-regexp "^Followup-To: +" nil t)
- (save-restriction
- (narrow-to-region
- (point)
- (if (re-search-forward "^[^ \t]" nil 'end)
- (match-beginning 0)
- (point-max)))
- (goto-char (point-min))
- ;; No line breaks (too confusing)
- (while (re-search-forward "\n[ \t]+" nil t )
- (replace-match " " t ))
- (goto-char (point-min))
- (while (re-search-forward "[ \t\n]*,[ \t\n]*\\|[ \t]+" nil t)
- (replace-match "," t t)))))
-
-(defun gnus-inews-remove-headers ()
- (let ((case-fold-search t)
- (headers gnus-removable-headers))
- ;; Remove toxic headers.
- (while headers
- (goto-char (point-min))
- (and (re-search-forward
- (concat "^" (downcase (format "%s" (car headers))))
- nil t)
- (delete-region (progn (beginning-of-line) (point))
- (progn (forward-line 1) (point))))
- (setq headers (cdr headers)))))
-
;;; Since the X-Newsreader/X-Mailer are ``vanity'' headers, they might
;;; as well include the Emacs version as well.
;;; The following function works with later GNU Emacs, and XEmacs.
(format " %d.%d" emacs-major-version emacs-minor-version)))
(t emacs-version))))
-(defun gnus-inews-insert-headers (&optional headers)
- "Prepare article headers.
-Headers already prepared in the buffer are not modified.
-Headers in `gnus-required-headers' will be generated."
- (let* ((Date (gnus-inews-date))
- (Message-ID (gnus-inews-message-id))
- (Organization (gnus-inews-organization))
- (From (gnus-inews-user-name))
- (Path (gnus-inews-path))
- (Subject nil)
- (Newsgroups nil)
- (In-Reply-To (gnus-inews-in-reply-to))
- (To nil)
- (Distribution (gnus-inews-distribution))
- (Lines (gnus-inews-lines))
- (X-Newsreader (gnus-extended-version))
- (X-Mailer X-Newsreader)
- (Expires (gnus-inews-expires))
- (headers (or headers gnus-required-headers))
- (case-fold-search t)
- header value elem)
- ;; First we remove any old generated headers.
- (let ((headers gnus-deletable-headers))
- (while headers
- (goto-char (point-min))
- (and (re-search-forward
- (concat "^" (symbol-name (car headers)) ": *") nil t)
- (get-text-property (1+ (match-beginning 0)) 'gnus-deletable)
- (gnus-delete-line))
- (setq headers (cdr headers))))
- ;; If there are References, and no "Re: ", then the thread has
- ;; changed name. See Son-of-1036.
- (if (and (mail-fetch-field "references")
- (get-buffer gnus-article-buffer))
- (let ((psubject (gnus-simplify-subject-re
- (mail-fetch-field "subject"))))
- (or (and psubject gnus-reply-subject
- (string= (gnus-simplify-subject-re gnus-reply-subject)
- psubject))
- (progn
- (string-match "@" Message-ID)
- (setq Message-ID
- (concat (substring Message-ID 0 (match-beginning 0))
- "_-_"
- (substring Message-ID (match-beginning 0))))))))
- ;; Go through all the required headers and see if they are in the
- ;; articles already. If they are not, or are empty, they are
- ;; inserted automatically - except for Subject, Newsgroups and
- ;; Distribution.
- (while headers
- (goto-char (point-min))
- (setq elem (pop headers))
- (if (consp elem)
- (setq header (car elem))
- (setq header elem))
- (when (or (not (re-search-forward
- (concat "^" (downcase (symbol-name header)) ":") nil t))
- (progn
- ;; The header was found. We insert a space after the
- ;; colon, if there is none.
- (if (/= (following-char) ? ) (insert " "))
- ;; Find out whether the header is empty...
- (looking-at "[ \t]*$")))
- ;; So we find out what value we should insert.
- (setq value
- (cond
- ((and (consp elem) (eq (car elem) 'optional))
- ;; This is an optional header. If the cdr of this
- ;; is something that is nil, then we do not insert
- ;; this header.
- (setq header (cdr elem))
- (or (and (fboundp (cdr elem)) (funcall (cdr elem)))
- (and (boundp (cdr elem)) (symbol-value (cdr elem)))))
- ((consp elem)
- ;; The element is a cons. Either the cdr is a
- ;; string to be inserted verbatim, or it is a
- ;; function, and we insert the value returned from
- ;; this function.
- (or (and (stringp (cdr elem)) (cdr elem))
- (and (fboundp (cdr elem)) (funcall (cdr elem)))))
- ((and (boundp header) (symbol-value header))
- ;; The element is a symbol. We insert the value
- ;; of this symbol, if any.
- (symbol-value header))
- (t
- ;; We couldn't generate a value for this header,
- ;; so we just ask the user.
- (read-from-minibuffer
- (format "Empty header for %s; enter value: " header)))))
- ;; Finally insert the header.
- (when (and value
- (not (equal value "")))
- (save-excursion
- (if (bolp)
- (progn
- ;; This header didn't exist, so we insert it.
- (goto-char (point-max))
- (insert (symbol-name header) ": " value "\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))
- ;; Add the deletable property to the headers that require it.
- (and (memq header gnus-deletable-headers)
- (progn (beginning-of-line) (looking-at "[^:]+: "))
- (add-text-properties
- (point) (match-end 0)
- '(gnus-deletable t face italic) (current-buffer)))))))
- ;; Insert new Sender if the From is strange.
- (let ((from (mail-fetch-field "from"))
- (sender (mail-fetch-field "sender"))
- (secure-sender (gnus-inews-real-user-address)))
- (when (and from
- (not (gnus-check-before-posting 'sender))
- (not (string=
- (downcase (cadr (gnus-extract-address-components from)))
- (downcase (gnus-inews-real-user-address))))
- (or (null sender)
- (not
- (string=
- (downcase
- (cadr (gnus-extract-address-components sender)))
- (downcase secure-sender)))))
- (goto-char (point-min))
- ;; Rename any old Sender headers to Original-Sender.
- (when (re-search-forward "^Sender:" nil t)
- (beginning-of-line)
- (insert "Original-")
- (beginning-of-line))
- (insert "Sender: " secure-sender "\n")))))
-
-(defun gnus-inews-insert-signature ()
- "Insert a signature file.
-If `gnus-signature-function' is bound and returns a string, this
-string is used instead of the variable `gnus-signature-file'.
-In either case, if the string is a file name, this file is
-inserted. If the string is not a file name, the string itself is
-inserted.
-
-If you never want any signature inserted, set both of these variables to
-nil."
- (save-excursion
- (let ((signature
- (or (and gnus-signature-function
- (funcall gnus-signature-function gnus-newsgroup-name))
- gnus-signature-file)))
- (if (and signature
- (or (file-exists-p signature)
- (string-match " " signature)
- (not (string-match
- "^/[^/]+/" (expand-file-name signature)))))
- (progn
- (goto-char (point-max))
- (if (and mail-signature (search-backward "\n-- \n" nil t))
- ()
- ;; Delete any previous signatures.
- (if (search-backward "\n-- \n" nil t)
- (delete-region (point) (point-max)))
- (or (eolp) (insert "\n"))
- (insert "-- \n")
- (if (file-exists-p signature)
- (insert-file-contents signature)
- (insert signature))
- (goto-char (point-max))
- (or (bolp) (insert "\n"))))))))
-
;; Written by "Mr. Per Persson" <pp@solace.mh.se>.
(defun gnus-inews-insert-mime-headers ()
(goto-char (point-min))
(or (mail-position-on-field "Content-Transfer-Encoding")
(insert "7bit")))))))
-(defun gnus-inews-do-fcc ()
- "Process Fcc headers in the current buffer.
-Unless the first character of the field is `|', the article is saved
-to the specified file using the function specified by the variable
-gnus-author-copy-saver. The default function rmail-output saves in
-Unix mailbox format.
-
-If the first character is `|', the contents of the article is sent to
-a program specified by the rest of the value."
- (let ((case-fold-search t) ;Should ignore case.
- list file)
- (save-excursion
- (save-restriction
- (nnheader-narrow-to-headers)
- (while (setq file (mail-fetch-field "fcc"))
- (push file list)
- (nnheader-remove-header "fcc" nil t))
- ;; Process FCC operations.
- (widen)
- (while list
- (setq file (pop list))
- (if (string-match "^[ \t]*|[ \t]*\\(.*\\)[ \t]*$" file)
- ;; Pipe the article to the program in question.
- (call-process-region (point-min) (point-max) shell-file-name
- nil nil nil "-c" (match-string 1 file))
- ;; Save the article.
- (setq file (expand-file-name file))
- (gnus-make-directory (file-name-directory file))
- (if (and gnus-author-copy-saver
- (not (eq gnus-author-copy-saver 'rmail-output)))
- (funcall gnus-author-copy-saver file)
- (if (and (file-readable-p file) (mail-file-babyl-p file))
- (gnus-output-to-rmail file)
- (let ((mail-use-rfc822 t))
- (rmail-output file 1 t t))))))))))
-
-(defun gnus-inews-path ()
- "Return uucp path."
- (let ((login-name (gnus-inews-login-name)))
- (cond ((null gnus-use-generic-path)
- (concat (nth 1 gnus-select-method) "!" login-name))
- ((stringp gnus-use-generic-path)
- ;; Support GENERICPATH. Suggested by vixie@decwrl.dec.com.
- (concat gnus-use-generic-path "!" login-name))
- (t login-name))))
-
-(defun gnus-inews-user-name ()
- "Return user's network address as \"NAME@DOMAIN (FULL-NAME)\"."
- (let ((full-name (gnus-inews-full-name))
- (address (if (or gnus-user-login-name gnus-use-generic-from
- gnus-local-domain (getenv "DOMAINNAME"))
- (concat (gnus-inews-login-name) "@"
- (gnus-inews-domain-name gnus-use-generic-from))
- user-mail-address)))
- (or gnus-user-from-line
- (concat address
- ;; User's full name.
- (cond ((string-equal full-name "&") ;Unix hack.
- (concat " (" (user-login-name) ")"))
- ((string-match "[^ ]+@[^ ]+ +(.*)" address)
- "")
- (t
- (concat " (" full-name ")")))))))
-
-(defun gnus-inews-real-user-address ()
- "Return the \"real\" user address.
-This function tries to ignore all user modifications, and
-give as trustworthy answer as possible."
- (concat (user-login-name) "@" (system-name)))
-
-(defun gnus-inews-login-name ()
- "Return login name."
- (or gnus-user-login-name (getenv "LOGNAME") (user-login-name)))
-
-(defun gnus-inews-full-name ()
- "Return full user name."
- (or gnus-user-full-name (getenv "NAME") (user-full-name)))
-
-(defun gnus-inews-domain-name (&optional genericfrom)
- "Return user's domain name.
-If optional argument GENERICFROM is a string, use it as the domain
-name; if it is non-nil, strip off local host name from the domain name.
-If the function `system-name' returns full internet name and the
-domain is undefined, the domain name is got from it."
- (if (or genericfrom gnus-local-domain (getenv "DOMAINNAME"))
- (let* ((system-name (system-name))
- (domain
- (or (if (stringp genericfrom) genericfrom)
- (getenv "DOMAINNAME")
- (and (boundp 'mail-host-address)
- mail-host-address)
- gnus-local-domain
- ;; Function `system-name' may return full internet name.
- ;; Suggested by Mike DeCorte <mrd@sun.soe.clarkson.edu>.
- (if (string-match "\\.." system-name)
- ;; Some machines return "name.", and that's not
- ;; very nice.
- (substring system-name (1- (match-end 0))))
- (read-string "Domain name (no host): ")))
- (host (or (if (string-match "\\." system-name)
- (substring system-name 0 (match-beginning 0)))
- system-name)))
- (if (string-equal "." (substring domain 0 1))
- (setq domain (substring domain 1)))
- ;; Support GENERICFROM as same as standard Bnews system.
- ;; Suggested by ohm@kaba.junet and vixie@decwrl.dec.com.
- (cond ((null genericfrom)
- (concat host "." domain))
- ;;((stringp genericfrom) genericfrom)
- (t domain)))
- (if (string-match "\\." (system-name))
- (system-name)
- (if (string-match "@\\([^ ]+\\)\\($\\| \\)" user-mail-address)
- (substring user-mail-address
- (match-beginning 1) (match-end 1))
- "bogus-domain"))))
-
-(defun gnus-inews-full-address ()
- (let ((domain (gnus-inews-domain-name))
- (system (system-name))
- (case-fold-search t))
- (if (string-match "\\." system) system
- (if (string-match (concat "^" (regexp-quote system)) domain) domain
- (concat system "." domain)))))
-
-(defun gnus-inews-expires ()
- "Return an Expires header based on `gnus-article-expires'."
- (let ((current (current-time))
- (future (* 1.0 gnus-article-expires 60 60 24)))
- ;; Add the future to current.
- (setcar current (+ (car current) (round (/ future (expt 2 16)))))
- (setcar (cdr current) (+ (nth 1 current) (% (round future) (expt 2 16))))
- ;; Return the date in the future in UT.
- (timezone-make-date-arpa-standard
- (current-time-string current) (current-time-zone) '(0 "UT"))))
-
-(defun gnus-inews-distribution ()
- "Return the current Distribution header, if any."
- (when (and gnus-distribution-function
- (fboundp gnus-distribution-function))
- (funcall gnus-distribution-function
- (or gnus-newsgroup-name
- (save-excursion (mail-fetch-field "newsgroups"))
- ""))))
-
-(defun gnus-inews-message-id ()
- "Generate unique Message-ID for user."
- ;; Message-ID should not contain a slash and should be terminated by
- ;; a number. I don't know the reason why it is so.
- (concat "<" (gnus-inews-unique-id) "@" (gnus-inews-full-address) ">"))
-
-(defvar gnus-unique-id-char nil)
-
-;; If you ever change this function, make sure the new version
-;; cannot generate IDs that the old version could.
-;; You might for example insert a "." somewhere (not next to another dot
-;; or string boundary), or modify the newsreader name to "Ding".
-(defun gnus-inews-unique-id ()
- ;; Don't use microseconds from (current-time), they may be unsupported.
- ;; Instead we use this randomly inited counter.
- (setq gnus-unique-id-char
- (% (1+ (or gnus-unique-id-char (logand (random t) (1- (lsh 1 20)))))
- ;; (current-time) returns 16-bit ints,
- ;; and 2^16*25 just fits into 4 digits i base 36.
- (* 25 25)))
- (let ((tm (if (fboundp 'current-time)
- (current-time) '(12191 46742 287898))))
- (concat
- (if (memq system-type '(ms-dos emx vax-vms))
- (let ((user (downcase (gnus-inews-login-name))))
- (while (string-match "[^a-z0-9_]" user)
- (aset user (match-beginning 0) ?_))
- user)
- (gnus-number-base36 (user-uid) -1))
- (gnus-number-base36 (+ (car tm) (lsh (% gnus-unique-id-char 25) 16)) 4)
- (gnus-number-base36 (+ (nth 1 tm) (lsh (/ gnus-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.
- ".fsf")))
-
-(defun gnus-inews-date ()
- "Current time string."
- (let ((now (current-time)))
- (timezone-make-date-arpa-standard
- (current-time-string now) (current-time-zone now))))
-
-(defun gnus-inews-organization ()
- "Return user's organization.
-The ORGANIZATION environment variable is used if defined.
-If not, the variable `gnus-local-organization' is used instead.
-If it is a function, the function will be called with the current
-newsgroup name as the argument.
-If this is a file name, the contents of this file will be used as the
-organization."
- (let* ((organization
- (or (getenv "ORGANIZATION")
- (if gnus-local-organization
- (if (gnus-functionp gnus-local-organization)
- (funcall gnus-local-organization gnus-newsgroup-name)
- gnus-local-organization))
- gnus-organization-file
- "~/.organization")))
- (and (stringp organization)
- (> (length organization) 0)
- (or (file-exists-p organization)
- (string-match " " organization)
- (not (string-match "^/usr/lib/\\|^~/" organization)))
- (save-excursion
- (gnus-set-work-buffer)
- (if (file-exists-p organization)
- (insert-file-contents organization)
- (insert organization))
- (goto-char (point-min))
- (while (re-search-forward " *\n *" nil t)
- (replace-match " " t t))
- (buffer-substring (point-min) (point-max))))))
-
-(defun gnus-inews-lines ()
- "Count the number of lines and return numeric string."
- (save-excursion
- (save-restriction
- (widen)
- (goto-char (point-min))
- (re-search-forward
- (concat "^" (regexp-quote mail-header-separator) "$"))
- (forward-line 1)
- (int-to-string (count-lines (point) (point-max))))))
-
-(defun gnus-inews-in-reply-to ()
- "Return the In-Reply-To header for this message."
- gnus-in-reply-to)
-
\f
;;;
;;; Gnus Mail Functions
;;; Mail reply commands of Gnus summary mode
-(defun gnus-summary-reply (yank &optional yank-articles)
+(defun gnus-summary-reply (&optional yank)
"Reply mail to news author.
-If prefix argument YANK is non-nil, original article is yanked automatically.
-Customize the variable gnus-mail-reply-method to use another mailer."
- (interactive "P")
+If prefix argument YANK is non-nil, original article is yanked automatically."
+ (interactive
+ (list (and current-prefix-arg
+ (gnus-summary-work-articles 1))))
;; Bug fix by jbw@bigbird.bu.edu (Joe Wells)
;; Stripping headers should be specified with mail-yank-ignored-headers.
(gnus-set-global-variables)
- (if yank-articles (gnus-summary-goto-subject (car yank-articles)))
- (gnus-summary-select-article)
- (bury-buffer gnus-article-buffer)
- (gnus-mail-reply (or yank-articles (not (not yank)))))
+ (when yank
+ (gnus-summary-goto-subject (car yank)))
+ (let ((gnus-article-reply t))
+ (gnus-setup-message (if yank 'reply-yank 'reply)
+ (gnus-summary-select-article)
+ (set-buffer (gnus-copy-article-buffer))
+ (message-reply)
+ (when yank
+ (gnus-inews-yank-articles yank)))))
(defun gnus-summary-reply-with-original (n)
"Reply mail to news author with original article.
Customize the variable gnus-mail-reply-method to use another mailer."
(interactive "P")
- (gnus-summary-reply t (gnus-summary-work-articles n)))
+ (gnus-summary-reply (gnus-summary-work-articles n)))
-(defun gnus-summary-mail-forward (post)
- "Forward the current message to another user.
-Customize the variable gnus-mail-forward-method to use another mailer."
+(defun gnus-summary-mail-forward (&optional post)
+ "Forward the current message to another user."
(interactive "P")
(gnus-set-global-variables)
- (gnus-summary-select-article)
- (gnus-copy-article-buffer)
- (if post
- (gnus-forward-using-post gnus-original-article-buffer)
- (gnus-mail-forward gnus-original-article-buffer)))
+ (gnus-setup-message 'forward
+ (gnus-summary-select-article)
+ (set-buffer gnus-original-article-buffer)
+ (message-forward post)))
(defun gnus-summary-resend-message (address)
"Resend the current article to ADDRESS."
(interactive "sResend message to: ")
(gnus-summary-select-article)
(save-excursion
- (let (beg)
- ;; We first set up a normal mail buffer.
- (nnheader-set-temp-buffer " *Gnus resend*")
- ;; This code from sendmail.el
- (insert "To: ")
- (let ((fill-prefix "\t")
- (address-start (point)))
- (insert address "\n")
- (fill-region-as-paragraph address-start (point-max)))
- (insert mail-header-separator "\n")
- ;; Insert our usual headers.
- (gnus-inews-narrow-to-headers)
- (gnus-inews-insert-headers '(From Date To))
- (goto-char (point-min))
- ;; Rename them all to "Resent-*".
- (while (re-search-forward "^[A-Za-z]" nil t)
- (forward-char -1)
- (insert "Resent-"))
- (widen)
- (forward-line)
- (delete-region (point) (point-max))
- (setq beg (point))
- ;; Insert the message to be resent.
- (insert-buffer-substring gnus-original-article-buffer)
- (goto-char (point-min))
- (search-forward "\n\n")
- (forward-char -1)
- (save-restriction
- (narrow-to-region beg (point))
- (nnheader-remove-header gnus-ignored-resent-headers t)
- (goto-char (point-max)))
- (insert mail-header-separator)
- ;; Rename all old ("Also-")Resent headers.
- (while (re-search-backward "^\\(Also-\\)?Resent-" beg t)
- (beginning-of-line)
- (insert "Also-"))
- ;; Send it.
- (mail-send)
- (kill-buffer (current-buffer)))))
+ (set-buffer gnus-original-article-buffer)
+ (message-resend address)))
(defun gnus-summary-post-forward ()
"Forward the current article to a newsgroup."
"Really send a nastygram to the author of the current article? "))
(let ((group gnus-newsgroup-name))
(gnus-summary-reply-with-original n)
- (set-buffer gnus-mail-buffer)
+ (set-buffer gnus-message-buffer)
(insert (format gnus-nastygram-message group))
- (gnus-mail-send-and-exit))))
+ (message-send-and-exit))))
(defun gnus-summary-mail-other-window ()
- "Compose mail in other window.
-Customize the variable `gnus-mail-other-window-method' to use another
-mailer."
+ "Compose mail in other window."
(interactive)
(gnus-set-global-variables)
- (gnus-new-mail
- ;; We might want to prompt here.
- (when (and gnus-interactive-post
- (not gnus-expert-user))
- (read-string "To: ")))
- (gnus-configure-windows 'summary-mail 'force))
-
-(defun gnus-new-mail (&optional to)
- (let (subject)
- (when (and gnus-interactive-post
- (not gnus-expert-user))
- (setq subject (read-string "Subject: ")))
- (pop-to-buffer gnus-default-mail-buffer)
- (erase-buffer)
- (gnus-mail-setup 'new to subject)
- (gnus-inews-insert-gcc)
- (gnus-inews-insert-archive-gcc)
- (run-hooks 'gnus-mail-hook)))
-
-(defun gnus-new-empty-mail ()
- "Create a new, virtually empty mail mode buffer."
- (pop-to-buffer gnus-default-mail-buffer)
- (gnus-mail-setup 'new "" ""))
-
-(defun gnus-mail-reply (&optional yank to-address followup)
- (save-excursion
- (set-buffer gnus-summary-buffer)
- (let ((group gnus-newsgroup-name)
- (cur (cons (current-buffer) (cdr gnus-article-current)))
- (winconf (current-window-configuration))
- from subject date reply-to message-of to cc
- references message-id sender follow-to sendto elt new-cc new-to
- mct mctdo gnus-warning)
- (set-buffer (get-buffer-create gnus-default-mail-buffer))
- (mail-mode)
- (if (and (buffer-modified-p)
- (> (buffer-size) 0)
- (not (gnus-y-or-n-p
- "Unsent message being composed; erase it? ")))
- ()
- (erase-buffer)
- (save-excursion
- (gnus-copy-article-buffer)
- (save-restriction
- (set-buffer gnus-article-copy)
- (nnheader-narrow-to-headers)
- (if (not followup)
- ;; This is a regular reply.
- (if (gnus-functionp gnus-reply-to-function)
- (setq follow-to (funcall gnus-reply-to-function group)))
- ;; This is a followup.
- (if (gnus-functionp gnus-followup-to-function)
- (save-excursion
- (setq follow-to
- (funcall gnus-followup-to-function group)))))
- (setq from (mail-fetch-field "from"))
- (setq date (or (mail-fetch-field "date")
- (mail-header-date gnus-current-headers)))
- (setq message-of (gnus-message-of from date))
- (setq sender (mail-fetch-field "sender"))
- (setq subject (or (mail-fetch-field "subject") "none"))
- ;; Remove any (buggy) Re:'s that are present and make a
- ;; proper one.
- (and (string-match "^[ \t]*[Re][Ee]:[ \t]*" subject)
- (setq subject (substring subject (match-end 0))))
- (setq subject (concat "Re: " subject))
- (setq to (mail-fetch-field "to"))
- (setq cc (mail-fetch-field "cc"))
- (setq mct (mail-fetch-field "mail-copies-to"))
- (setq reply-to
- (unless (gnus-group-get-parameter group 'broken-reply-to)
- (mail-fetch-field "reply-to")))
- (setq references (mail-fetch-field "references"))
- (setq message-id (mail-fetch-field "message-id"))
- (when (and (setq gnus-warning (mail-fetch-field "gnus-warning"))
- (string-match "<[^>]+>" gnus-warning))
- (setq message-id (match-string 0 gnus-warning)))
-
- (setq mctdo (and mct (not (equal mct "never"))))
- (when (and mct (string= (downcase mct) "always"))
- (setq mct (or reply-to from)))
-
- (if (not (and followup (not to-address)))
- (setq new-to (or reply-to from)
- new-cc
- (if (and mctdo
- (not (string=
- (gnus-mail-strip-quoted-names mct)
- (gnus-mail-strip-quoted-names
- (or to-address
- (if (and follow-to
- (not (stringp follow-to)))
- sendto
- (or follow-to new-to
- sender "")))))))
- mct))
- (let (ccalist)
- (save-excursion
- (gnus-set-work-buffer)
- (unless (equal mct "never")
- (insert (or reply-to from "")))
- (insert
- (if (bolp) "" ", ") (or to "")
- (if (or (not mct) (not mctdo)) ""
- (concat (if (bolp) "" ", ") mct))
- (if cc (concat (if (bolp) "" ", ") cc) ""))
- ;; Remove addresses that match `rmail-dont-reply-to-names'.
- (insert (prog1 (rmail-dont-reply-to (buffer-string))
- (erase-buffer)))
- (goto-char (point-min))
- (setq ccalist
- (mapcar
- (lambda (addr)
- (cons (gnus-mail-strip-quoted-names addr) addr))
- (nreverse (gnus-mail-parse-comma-list))))
- (let ((s ccalist))
- (while s
- (setq ccalist (delq (assoc (car (pop s)) s) ccalist)))))
- (setq new-to (cdr (pop ccalist)))
- (setq new-cc
- (mapconcat
- (lambda (addr) (cdr addr))
- ccalist ", "))))
- (widen)))
-
- (setq news-reply-yank-from (or from "(nobody)"))
- (setq news-reply-yank-message-id
- (or message-id "(unknown Message-ID)"))
-
- ;; Gather the "to" addresses out of the follow-to list and remove
- ;; them as we go.
- (if (and follow-to (listp follow-to))
- (while (setq elt (assoc "To" follow-to))
- (setq sendto (concat sendto (and sendto ", ") (cdr elt)))
- (setq follow-to (delq elt follow-to))))
-
- (gnus-mail-setup
- (if followup 'followup 'reply)
- (or to-address
- (if (and follow-to (not (stringp follow-to))) sendto
- (or follow-to new-to sender "")))
- subject message-of
- (if (zerop (length new-cc)) nil new-cc)
- gnus-article-copy)
-
- (make-local-variable 'gnus-article-reply)
- (setq gnus-article-reply cur)
- (make-local-variable 'gnus-prev-winconf)
- (setq gnus-prev-winconf winconf)
- (make-local-variable 'gnus-reply-subject)
- (setq gnus-reply-subject subject)
- (make-local-variable 'gnus-in-reply-to)
- (setq gnus-in-reply-to message-of)
-
- (auto-save-mode auto-save-default)
- (gnus-inews-insert-gcc)
- (gnus-inews-insert-archive-gcc group)
-
- (when (and follow-to (listp follow-to))
- (let (beg)
- (gnus-inews-narrow-to-headers)
- (re-search-forward "^To:" nil t)
- (beginning-of-line)
- (forward-line 1)
- (setq beg (point))
- ;; Insert the rest of the Follow-To headers.
- (while follow-to
- (goto-char (point-min))
- (if (not (re-search-forward
- (concat "^" (caar follow-to) ":") nil t))
- (progn
- (goto-char beg)
- (insert (caar follow-to) ": " (cdar follow-to) "\n"))
- (if (eolp)
- (insert " ")
- (skip-chars-forward " ")
- (unless (eolp)
- (end-of-line)
- (insert ", ")))
- (insert (cdar follow-to)))
- (setq follow-to (cdr follow-to)))
- (widen)))
- (nnheader-insert-references references message-id)
-
- ;; Now the headers should be ok, so we do the yanking.
- (goto-char (point-min))
- (re-search-forward
- (concat "^" (regexp-quote mail-header-separator) "$"))
- (forward-line 1)
- (if (not yank)
- (gnus-configure-windows 'reply 'force)
- (let ((last (point))
- end)
- (if (not (listp yank))
- (progn
- ;; Just a single article being yanked.
- (save-excursion
- (mail-yank-original nil))
- (or mail-yank-hooks mail-citation-hook
- (run-hooks 'news-reply-header-hook)))
- (while yank
- (save-window-excursion
- (set-buffer gnus-summary-buffer)
- (gnus-summary-select-article nil nil nil (car yank))
- (gnus-summary-remove-process-mark (car yank)))
- (save-excursion
- (setq end (point))
- (gnus-copy-article-buffer)
- (mail-yank-original nil)
- (save-restriction
- (narrow-to-region (point-min) (point))
- (goto-char (mark t))
- (let ((news-reply-yank-from
- (save-excursion
- (set-buffer gnus-article-buffer)
- (or (mail-fetch-field "from") "(nobody)")))
- (news-reply-yank-message-id
- (save-excursion
- (set-buffer gnus-article-buffer)
- (or (mail-fetch-field "message-id")
- "(unknown Message-ID)"))))
- (or mail-yank-hooks mail-citation-hook
- (run-hooks 'news-reply-header-hook))
- (setq end (point-max)))))
- (goto-char end)
- (setq yank (cdr yank))))
- (goto-char last))
- (forward-line 2)
- (gnus-configure-windows 'reply-yank 'force))
- (run-hooks 'gnus-mail-hook)
- ;; Mark this buffer as unchanged.
- (set-buffer-modified-p nil)))))
+ (message-mail))
(defun gnus-mail-parse-comma-list ()
(let (accumulated
(skip-chars-forward ", "))
accumulated))
-(defun gnus-new-news (&optional group inhibit-prompt)
- "Set up a *Post Gnus* buffer that points to GROUP.
-If INHIBIT-PROMPT, never prompt for a Subject."
- (let ((winconf (current-window-configuration))
- subject)
- (when (and gnus-interactive-post
- (not inhibit-prompt)
- (not gnus-expert-user))
- (setq subject (read-string "Subject: ")))
- (pop-to-buffer gnus-default-post-news-buffer)
- (erase-buffer)
- (news-reply-mode)
-
- ;; Let posting styles be configured.
- (gnus-configure-posting-styles)
- (news-setup nil subject nil (and group (gnus-group-real-name group)) nil)
- ;; Associate this buffer with the draft group.
- (gnus-enter-buffer-into-draft)
- (goto-char (point-min))
-
- (unless (re-search-forward
- (concat "^" (regexp-quote mail-header-separator) "$") nil t)
- (goto-char (point-max)))
- (insert "\n\n")
-
- (gnus-inews-insert-bfcc)
- (gnus-inews-insert-gcc)
- (gnus-inews-insert-archive-gcc group)
- (gnus-inews-insert-signature)
- (and gnus-post-prepare-function
- (gnus-functionp gnus-post-prepare-function)
- (funcall gnus-post-prepare-function group))
- (run-hooks 'gnus-post-prepare-hook)
- (gnus-inews-set-point)
- (make-local-variable 'gnus-prev-winconf)
- (setq gnus-prev-winconf winconf)
- (setq gnus-post-news-buffer (current-buffer))
- (gnus-inews-modify-mail-mode-map)
- (local-set-key "\C-c\C-c" 'gnus-inews-news)))
-
-(defun gnus-news-followup (&optional yank group)
- (save-excursion
- (set-buffer gnus-summary-buffer)
- (if (not (or (not gnus-novice-user)
- gnus-expert-user
- (gnus-y-or-n-p
- "Are you sure you want to post to all of USENET? ")))
- ()
- (let ((group (or group gnus-newsgroup-name))
- (cur (cons (current-buffer) (cdr gnus-article-current)))
- (winconf (current-window-configuration))
- from subject date message-of
- references message-id follow-to sendto elt
- followup-to distribution newsgroups gnus-warning)
- (set-buffer (get-buffer-create gnus-default-post-news-buffer))
- (news-reply-mode)
- (setq gnus-post-news-buffer (current-buffer))
- ;; Associate this buffer with the draft group.
- (gnus-enter-buffer-into-draft)
- (if (and (buffer-modified-p)
- (> (buffer-size) 0)
- (not (gnus-y-or-n-p
- "Unsent message being composed; erase it? ")))
- ()
- (erase-buffer)
- (save-excursion
- (gnus-copy-article-buffer)
- (save-restriction
- (set-buffer gnus-article-copy)
- (nnheader-narrow-to-headers)
- (if (gnus-functionp gnus-followup-to-function)
- (save-excursion
- (setq follow-to
- (funcall gnus-followup-to-function group))))
- (setq from (mail-fetch-field "from"))
- (setq date (or (mail-fetch-field "date")
- (mail-header-date gnus-current-headers)))
- (setq message-of (gnus-message-of from date))
- (setq subject (or (mail-fetch-field "subject") "none"))
- ;; Remove any (buggy) Re:'s that are present and make a
- ;; proper one.
- (and (string-match "^[ \t]*[Re][Ee]:[ \t]*" subject)
- (setq subject (substring subject (match-end 0))))
- (setq subject (concat "Re: " subject))
- (setq references (mail-fetch-field "references"))
- (setq message-id (mail-fetch-field "message-id"))
- (when (and (setq gnus-warning (mail-fetch-field "gnus-warning"))
- (string-match "<[^>]+>" gnus-warning))
- (setq message-id (match-string 0 gnus-warning)))
- (setq followup-to (mail-fetch-field "followup-to"))
- (setq newsgroups (mail-fetch-field "newsgroups"))
- (setq distribution (mail-fetch-field "distribution"))
- ;; Remove bogus distribution.
- (and (stringp distribution)
- (string-match "world" distribution)
- (setq distribution nil))
- (widen)))
-
- (setq news-reply-yank-from (or from "(nobody)"))
- (setq news-reply-yank-message-id
- (or message-id "(unknown Message-ID)"))
-
- ;; Gather the "to" addresses out of the follow-to list and remove
- ;; them as we go.
- (if (and follow-to (listp follow-to))
- (while (setq elt (assoc "Newsgroups" follow-to))
- (setq sendto (concat sendto (and sendto ", ") (cdr elt)))
- (setq follow-to (delq elt follow-to))))
-
- ;; Let posting styles be configured.
- (gnus-configure-posting-styles)
-
- (news-setup
- nil subject nil
- (or sendto
- (if (equal followup-to "poster")
- (or newsgroups group "")
- (and followup-to
- gnus-use-followup-to
- (or (not (eq gnus-use-followup-to 'ask))
- (equal followup-to newsgroups)
- (gnus-y-or-n-p
- (format "Use Followup-To %s? " followup-to)))
- followup-to))
- newsgroups group "")
- gnus-article-copy)
-
- (make-local-variable 'gnus-article-reply)
- (setq gnus-article-reply cur)
- (make-local-variable 'gnus-prev-winconf)
- (setq gnus-prev-winconf winconf)
- (make-local-variable 'gnus-reply-subject)
- (setq gnus-reply-subject (mail-header-subject gnus-current-headers))
- (make-local-variable 'gnus-in-reply-to)
- (setq gnus-in-reply-to message-of)
- (when (and followup-to newsgroups)
- (make-local-variable 'gnus-newsgroup-followup)
- (setq gnus-newsgroup-followup
- (cons newsgroups followup-to)))
-
- (gnus-inews-insert-signature)
-
- (and gnus-post-prepare-function
- (gnus-functionp gnus-post-prepare-function)
- (funcall gnus-post-prepare-function group))
- (run-hooks 'gnus-post-prepare-hook)
-
- (auto-save-mode auto-save-default)
- (gnus-inews-modify-mail-mode-map)
- (local-set-key "\C-c\C-c" 'gnus-inews-news)
-
- (if (and follow-to (listp follow-to))
- (progn
- (goto-char (point-min))
- (and (re-search-forward "^Newsgroups:" nil t)
- (forward-line 1))
- (while follow-to
- (insert (caar follow-to) ": " (cdar follow-to) "\n")
- (setq follow-to (cdr follow-to)))))
-
- ;; If a distribution existed, we use it.
- (if distribution
- (progn
- (mail-position-on-field "Distribution")
- (insert distribution)))
-
- (nnheader-insert-references references message-id)
-
- ;; Handle `gnus-auto-mail-to-author'.
- ;; Suggested by Daniel Quinlan <quinlan@best.com>.
- ;; Revised to respect Reply-To by Ulrik Dickow <dickow@nbi.dk>.
- (let ((to (if (if (eq gnus-auto-mail-to-author 'ask)
- (y-or-n-p "Also send mail to author? ")
- gnus-auto-mail-to-author)
- (or (save-excursion
- (set-buffer gnus-article-copy)
- (unless (gnus-group-get-parameter
- group 'broken-reply-to)
- (gnus-fetch-field "reply-to")))
- from)))
- (x-mail (save-excursion
- (set-buffer gnus-article-copy)
- (gnus-fetch-field "x-mail-copy-to"))))
- ;; Deny sending copy if there's a negative X-Mail-Copy-To
- ;; header.
- (if x-mail
- (if (and (string= x-mail "never")
- (not (eq gnus-auto-mail-to-author 'force)))
- (setq to nil)
- (setq to x-mail)))
- ;; Insert a To or Cc header.
- (if to
- (if (mail-fetch-field "To")
- (progn
- (beginning-of-line)
- (insert "Cc: " to "\n"))
- (mail-position-on-field "To")
- (insert to))))
-
- (gnus-inews-insert-bfcc)
- (gnus-inews-insert-gcc)
- (gnus-inews-insert-archive-gcc group)
-
- ;; Now the headers should be ok, so we do the yanking.
- (goto-char (point-min))
- (re-search-forward
- (concat "^" (regexp-quote mail-header-separator) "$"))
- (forward-line 1)
- (if (not yank)
- (progn
- (gnus-configure-windows 'followup 'force)
- (insert "\n\n")
- (forward-line -2))
- (let ((last (point))
- end)
- (if (not (listp yank))
- (progn
- (save-excursion
- (mail-yank-original nil))
- (or mail-yank-hooks mail-citation-hook
- (run-hooks 'news-reply-header-hook)))
- (while yank
- (save-window-excursion
- (set-buffer gnus-summary-buffer)
- (gnus-summary-select-article nil nil nil (car yank))
- (gnus-summary-remove-process-mark (car yank)))
- (save-excursion
- (gnus-copy-article-buffer)
- (mail-yank-original nil)
- (setq end (set-marker (make-marker) (point))))
- (or mail-yank-hooks mail-citation-hook
- (run-hooks 'news-reply-header-hook))
- (goto-char end)
- (set-marker end nil)
- (setq yank (cdr yank))))
- (goto-char last))
- (gnus-configure-windows 'followup-yank 'force))
-
- (make-local-variable 'gnus-article-check-size)
- (setq gnus-article-check-size
- (cons (buffer-size) (gnus-article-checksum)))
- (gnus-inews-set-point))))))
-
-(defun gnus-message-of (from date)
- "Take a FROM and a DATE and return an IN-REPLY-TO."
- (when from
- (let ((stop-pos
- (string-match " *at \\| *@ \\| *(\\| *<" from)))
- (concat (if stop-pos (substring from 0 stop-pos) from)
- "'s message of "
- (if (or (not date) (string= date ""))
- "(unknown date)" date)))))
-
(defun gnus-mail-yank-original ()
(interactive)
(save-excursion
(or mail-yank-hooks mail-citation-hook
(run-hooks 'news-reply-header-hook)))
-(defun gnus-mail-send-and-exit (&optional dont-send)
- "Send the current mail and return to Gnus."
- (interactive)
- (let* ((reply gnus-article-reply)
- (winconf gnus-prev-winconf)
- (address-group gnus-add-to-address)
- (to-address (and address-group
- (mail-fetch-field "to"))))
- (setq gnus-add-to-address nil)
- (let ((buffer-file-name nil))
- (or dont-send (gnus-mail-send)))
- (bury-buffer)
- (when (gnus-alive-p)
+(defun gnus-inews-add-to-address (group)
+ (let ((to-address (mail-fetch-field "to")))
+ (when (and to-address
+ (gnus-alive-p))
;; This mail group doesn't have a `to-list', so we add one
;; here. Magic!
- (when to-address
- (gnus-group-add-parameter address-group (cons 'to-list to-address)))
- (when (and (gnus-buffer-exists-p (car reply))
- (cdr reply))
- (save-excursion
- (set-buffer (car reply))
- (gnus-summary-mark-article-as-replied (cdr reply))))
- (and winconf (set-window-configuration winconf)))))
-
-(defun gnus-kill-message-buffer ()
- "Kill the current buffer after dissociating it from the draft group."
- (interactive)
- (when (gnus-y-or-n-p "Dissociate and kill the current buffer? ")
- (gnus-dissociate-buffer-from-draft)
- (let ((winconf gnus-prev-winconf))
- (kill-buffer (current-buffer))
- (when winconf
- (set-window-configuration winconf)))))
+ (gnus-group-add-parameter group (cons 'to-list to-address)))))
(defun gnus-put-message ()
"Put the current message in some group and return to Gnus."
(widen)
(gnus-inews-narrow-to-headers)
(let (gnus-deletable-headers)
- (if (eq major-mode 'mail-mode)
- (gnus-inews-insert-headers gnus-required-mail-headers)
- (gnus-inews-insert-headers)))
+ (if (message-news-p)
+ (message-generate-headers message-required-news-headers)
+ (message-generate-headers message-required-mail-headers)))
(goto-char (point-max))
(insert "Gcc: " group "\n")
(widen)))
(cdr reply)))))
(and winconf (set-window-configuration winconf))))))
-(defun gnus-forward-make-subject (buffer)
- (save-excursion
- (set-buffer buffer)
- (concat "[" (if (memq 'mail (assoc (symbol-name
- (car (gnus-find-method-for-group
- gnus-newsgroup-name)))
- gnus-valid-select-methods))
- (gnus-fetch-field "From")
- gnus-newsgroup-name)
- "] " (or (gnus-fetch-field "Subject") ""))))
-
-(defun gnus-forward-insert-buffer (buffer)
- (save-excursion
- (save-restriction
- ;; Put point where we want it before inserting the forwarded
- ;; message.
- (if gnus-signature-before-forwarded-message
- (goto-char (point-max))
- (goto-char (point-min))
- (re-search-forward
- (concat "^" (regexp-quote mail-header-separator) "$"))
- (forward-line 1))
- ;; Narrow to the area we are to insert.
- (narrow-to-region (point) (point))
- ;; Insert the separators and the forwarded buffer.
- (insert gnus-forward-start-separator)
- (insert-buffer-substring buffer)
- (goto-char (point-max))
- (insert gnus-forward-end-separator)
- (gnus-set-text-properties (point-min) (point-max) nil)
- ;; Remove all unwanted headers.
- (goto-char (point-min))
- (forward-line 1)
- (save-restriction
- (narrow-to-region (point) (if (search-forward "\n\n" nil t)
- (1- (point))
- (point)))
- (goto-char (point-min))
- (let ((case-fold-search t)
- delete)
- (while (re-search-forward "^[^ \t]*:" nil t)
- (beginning-of-line)
- (when delete (delete-region delete (point)))
- (if (looking-at gnus-forward-included-headers)
- (setq delete nil)
- (setq delete (point)))
- (forward-line 1)))))))
-
-(defun gnus-mail-forward (&optional buffer)
- "Forward the current message to another user using mail."
- (let* ((forward-buffer (or buffer (current-buffer)))
- (winconf (current-window-configuration))
- (subject (gnus-forward-make-subject forward-buffer)))
- (set-buffer (get-buffer-create gnus-default-mail-buffer))
- (if (and (buffer-modified-p)
- (> (buffer-size) 0)
- (not (gnus-y-or-n-p
- "Unsent message being composed; erase it? ")))
- ()
- (erase-buffer)
- (gnus-mail-setup 'forward nil subject)
- (make-local-variable 'gnus-prev-winconf)
- (setq gnus-prev-winconf winconf)
- (gnus-forward-insert-buffer forward-buffer)
- (goto-char (point-min))
- (re-search-forward "^To: ?" nil t)
- (gnus-configure-windows 'mail-forward 'force)
- ;; You have a chance to arrange the message.
- (run-hooks 'gnus-mail-forward-hook)
- (run-hooks 'gnus-mail-hook))))
-
-(defun gnus-forward-using-post (&optional buffer)
- (save-excursion
- (let* ((forward-buffer (or buffer (current-buffer)))
- (subject (gnus-forward-make-subject forward-buffer))
- (gnus-newsgroup-name nil))
- (gnus-post-news 'post nil nil nil nil subject)
- (save-excursion
- (gnus-forward-insert-buffer forward-buffer)
- ;; You have a chance to arrange the message.
- (run-hooks 'gnus-mail-forward-hook)))))
-
-(defun gnus-mail-other-window-using-mail ()
- "Compose mail other window using mail."
- (let ((winconf (current-window-configuration)))
- (mail-other-window nil nil nil nil nil (get-buffer gnus-article-buffer))
- (gnus-inews-modify-mail-mode-map)
- (make-local-variable 'gnus-prev-winconf)
- (setq gnus-prev-winconf winconf)
- (run-hooks 'gnus-mail-hook)
- (gnus-configure-windows 'summary-mail 'force)))
-
(defun gnus-article-mail (yank)
"Send a reply to the address near point.
If YANK is non-nil, include the original article."
(auto-save-mode auto-save-default)
(make-local-variable 'gnus-prev-winconf)
(setq gnus-prev-winconf winconf)
- (gnus-inews-modify-mail-mode-map)
(local-set-key "\C-c\C-c" 'gnus-bug-mail-send-and-exit)
(goto-char (point-min))
(re-search-forward (concat "^" (regexp-quote mail-header-separator) "$"))
(let ((cur (current-buffer)))
(and (get-buffer "*Gnus Help Bug*")
(kill-buffer "*Gnus Help Bug*"))
- (gnus-mail-send-and-exit)
+ (message-send-and-exit)
(when (buffer-name cur)
(kill-buffer cur))))
;;; Treatment of rejected articles.
;;; Bounced mail.
-(defvar mail-unsent-separator)
-
-(defun gnus-summary-resend-bounced-mail (fetch)
+(defun gnus-summary-resend-bounced-mail (&optional fetch)
"Re-mail the current message.
This only makes sense if the current message is a bounce message than
contains some mail you have written which has been bounced back to
If FETCH, try to fetch the article that this is a reply to, if indeed
this is a reply."
(interactive "P")
- (require 'rmail)
(gnus-summary-select-article t)
- ;; Create a mail buffer.
- (gnus-new-empty-mail)
- (erase-buffer)
- (insert-buffer-substring gnus-original-article-buffer)
- (goto-char (point-min))
- (or (and (re-search-forward mail-unsent-separator nil t)
- (forward-line 1))
- (and (search-forward "\n\n" nil t)
- (re-search-forward "^Return-Path:.*\n" nil t)))
- ;; We remove everything before the bounced mail.
- (delete-region
- (point-min)
- (if (re-search-forward "[^ \t]*:" nil t)
- (match-beginning 0)
- (point)))
- (let (references)
- (save-excursion
- (save-restriction
- (nnheader-narrow-to-headers)
- (nnheader-remove-header gnus-bounced-headers-junk t)
- (setq references (mail-fetch-field "references"))
- (goto-char (point-max))
- (insert mail-header-separator)))
- ;; If there are references, we fetch the article we answered to.
- (and fetch
- references
- (string-match "\\(<[^]+>\\)[ \t]*$" references)
- (gnus-summary-refer-article
- (substring references (match-beginning 1) (match-end 1)))
- (progn
- (gnus-summary-show-all-headers)
- (gnus-configure-windows 'compose-bounce))))
- (goto-char (point-min)))
-
-;;; Sending mail.
+ (set-buffer gnus-original-article-buffer)
+ (gnus-setup-message 'compose-bounce
+ (let* ((references (mail-fetch-field "references"))
+ (parent (and references (gnus-parent-id references))))
+ (message-bounce)
+ ;; If there are references, we fetch the article we answered to.
+ (and fetch parent
+ (gnus-summary-refer-article parent)
+ (gnus-summary-show-all-headers)))))
-(defun gnus-mail-send (&optional no-generated-headers)
- "Send the current buffer as mail.
-Headers will be generated before sending."
- (interactive)
- (unless no-generated-headers
- (save-excursion
- (save-restriction
- (widen)
- (gnus-inews-narrow-to-headers)
- (gnus-inews-insert-headers gnus-required-mail-headers)
- (gnus-inews-remove-empty-headers))))
- (widen)
- (when (not (gnus-inews-reject-message))
- ;; Remove the header separator.
- (goto-char (point-min))
- (and (re-search-forward
- (concat "^" (regexp-quote mail-header-separator) "$") nil t)
- (replace-match "" t t))
- ;; Run final inews hooks. This hook may do FCC.
- (run-hooks 'gnus-inews-article-hook)
- (gnus-inews-do-gcc)
- (nnheader-narrow-to-headers)
- (nnheader-remove-header "^[gf]cc:" t)
- (widen)
- (goto-char (point-min))
- (search-forward "\n\n")
- (forward-char -1)
- (insert mail-header-separator)
- (mail-send)
- (run-hooks 'gnus-message-sent-hook)))
-
-(defun gnus-inews-modify-mail-mode-map ()
- (use-local-map (copy-keymap (current-local-map)))
- (gnus-local-set-keys
- "\C-c\C-c" gnus-mail-send-and-exit
- "\C-c\M-\C-p" gnus-put-message
- "\C-c\C-q" gnus-kill-message-buffer
- "\C-c\M-d" gnus-dissociate-buffer-from-draft
- "\C-c\C-d" gnus-associate-buffer-with-draft))
-
-(defun gnus-mail-setup (type &optional to subject in-reply-to cc
- replybuffer actions)
- ;; Let posting styles be configured.
- (gnus-configure-posting-styles)
- (funcall
- (cond
- ((or
- (eq gnus-mail-method 'mh)
- (and (or (eq type 'reply) (eq type 'followup))
- (eq gnus-mail-reply-method 'gnus-mail-reply-using-mhe))
- (and (eq type 'forward)
- (eq gnus-mail-forward-method 'gnus-mail-forward-using-mhe))
- (and (eq type 'new)
- (eq gnus-mail-other-window-method
- 'gnus-mail-other-window-using-mhe)))
- 'gnus-mh-mail-setup)
- ((or
- (eq gnus-mail-method 'vm)
- (and (or (eq type 'reply) (eq type 'followup))
- (eq gnus-mail-reply-method 'gnus-mail-reply-using-vm))
- (and (eq type 'forward)
- (eq gnus-mail-forward-method 'gnus-mail-forward-using-vm))
- (and (eq type 'new)
- (eq gnus-mail-other-window-method
- 'gnus-mail-other-window-using-vm)))
- 'gnus-vm-mail-setup)
- ((or
- (eq gnus-mail-method 'sendmail)
- (and (or (eq type 'reply) (eq type 'followup))
- (eq gnus-mail-reply-method 'gnus-mail-reply-using-mail))
- (and (eq type 'forward)
- (eq gnus-mail-forward-method 'gnus-mail-forward-using-mail))
- (and (eq type 'new)
- (eq gnus-mail-other-window-method
- 'gnus-mail-other-window-using-mail)))
- 'gnus-sendmail-mail-setup)
- (t
- (cond ((or (eq type 'reply) (eq type 'followup))
- gnus-mail-reply-method)
- ((eq type 'forward)
- gnus-mail-forward-method)
- ((eq type 'new)
- gnus-mail-other-window-method))))
- to subject in-reply-to cc replybuffer actions)
- (setq gnus-mail-buffer (current-buffer))
- ;; Associate this mail buffer with the draft group.
- (gnus-enter-buffer-into-draft))
-
-(defun gnus-sendmail-mail-setup (to subject in-reply-to cc replybuffer actions)
- (mail-mode)
- (mail-setup to subject nil cc replybuffer actions)
- (gnus-inews-set-point)
- (gnus-inews-modify-mail-mode-map))
-
;;; Gcc handling.
;; Do Gcc handling, which copied the message over to some group.
(cur (current-buffer))
groups group method)
(when gcc
- (nnheader-remove-header "gcc")
+ (message-remove-header "gcc")
(widen)
- (setq groups (gnus-tokenize-header gcc " ,"))
+ (setq groups (message-tokenize-header gcc " ,"))
;; Copy the article over to some group(s).
(while (setq group (pop groups))
(gnus-check-server
(sit-for 2))
(kill-buffer (current-buffer)))))))))
-(defun gnus-inews-insert-bfcc ()
- "Insert Bcc and Fcc headers."
- (save-excursion
- ;; Handle author copy using BCC field.
- (when (and gnus-mail-self-blind
- (not (mail-fetch-field "bcc")))
- (mail-position-on-field "Bcc")
- (insert (if (stringp gnus-mail-self-blind)
- gnus-mail-self-blind
- (user-login-name))))
- ;; Handle author copy using FCC field.
- (when gnus-author-copy
- (mail-position-on-field "Fcc")
- (insert gnus-author-copy))))
-
(defun gnus-inews-insert-gcc ()
"Insert Gcc headers based on `gnus-outgoing-message-group'."
(save-excursion
(insert " "))
(insert "\n"))))))
-;;; Handling rejected (and postponed) news.
-
-(defun gnus-draft-group ()
- "Return the name of the draft group."
- (gnus-group-prefixed-name
- (file-name-nondirectory (directory-file-name gnus-draft-group-directory))
- (list 'nndraft gnus-draft-group-directory)))
-
-(defun gnus-make-draft-group ()
- "Make the draft group or die trying."
- (let* ((method `(nndraft "private"
- (nndraft-directory
- ,gnus-draft-group-directory)))
- (group (gnus-draft-group)))
- (or (gnus-gethash group gnus-newsrc-hashtb)
- (gnus-group-make-group (gnus-group-real-name group) method)
- (error "Can't create the draft group"))
- (gnus-check-server method)
- group))
-
-(defun gnus-associate-buffer-with-draft (&optional generate silent)
- "Enter the current buffer into the draft group."
- (interactive)
- (when (gnus-request-accept-article (gnus-make-draft-group) t)
- (unless silent
- ;; This function does the proper marking of articles.
- (gnus-mail-send-and-exit 'dont-send))
- (set-buffer-modified-p nil)))
-
-(defun gnus-enter-buffer-into-draft ()
- (when gnus-use-draft
- (save-excursion
- ;; Make sure the draft group exists.
- (gnus-make-draft-group)
- ;; Associate the buffer with the draft group.
- (let ((article (gnus-request-associate-buffer (gnus-draft-group))))
- ;; Arrange for deletion of the draft after successful sending.
- (make-local-variable 'gnus-message-sent-hook)
- (setq gnus-message-sent-hook
- (list
- `(lambda ()
- (let ((gnus-verbose-backends nil))
- (gnus-request-expire-articles
- (quote ,(list article))
- ,(gnus-draft-group) t)))))))))
-
-(defun gnus-dissociate-buffer-from-draft ()
- "Disable auto-saving and association to the draft group of the current buffer."
- (interactive)
- (run-hooks 'gnus-message-sent-hook)
- (setq buffer-file-name nil)
- (setq buffer-auto-save-file-name nil))
-
(defun gnus-summary-send-draft ()
"Enter a mail/post buffer to edit and send the draft."
(interactive)
(gnus-set-global-variables)
- (unless (equal gnus-newsgroup-name (gnus-draft-group))
- (error "This function can only be used in the draft buffer"))
(let (buf)
(if (not (setq buf (gnus-request-restore-buffer
(gnus-summary-article-number) gnus-newsgroup-name)))
(error "Couldn't restore the article")
(switch-to-buffer buf)
- (gnus-inews-modify-mail-mode-map)
(when (eq major-mode 'news-reply-mode)
(local-set-key "\C-c\C-c" 'gnus-inews-news))
- (gnus-enter-buffer-into-draft)
;; Insert the separator.
(goto-char (point-min))
(search-forward "\n\n")
(gnus-configure-windows 'draft t)
(goto-char (point))))))
-(defun gnus-configure-posting-styles ()
- "Configure posting styles according to `gnus-posting-styles'."
- (let ((styles gnus-posting-styles)
- (gnus-newsgroup-name (or gnus-newsgroup-name ""))
- style match variable attribute value value-value)
- ;; Go through all styles and look for matches.
- (while styles
- (setq style (pop styles)
- match (pop style))
- (when (cond ((stringp match)
- ;; Regexp string match on the group name.
- (string-match match gnus-newsgroup-name))
- ((or (symbolp match)
- (gnus-functionp match))
- (cond ((gnus-functionp match)
- ;; Function to be called.
- (funcall match))
- ((boundp match)
- ;; Variable to be checked.
- (symbol-value match))))
- ((listp match)
- ;; This is a form to be evaled.
- (eval match)))
- ;; We have a match, so we set the variables.
- (while style
- (setq attribute (pop style)
- value (cdr attribute))
- ;; We find the variable that is to be modified.
- (if (and (not (stringp (car attribute)))
- (not (setq variable (cdr (assq (car attribute)
- gnus-posting-style-alist)))))
- (message "Couldn't find attribute %s" (car attribute))
- ;; We set the variable.
- (setq value-value
- (cond ((stringp value)
- value)
- ((or (symbolp value)
- (gnus-functionp value))
- (cond ((gnus-functionp value)
- (funcall value))
- ((boundp value)
- (symbol-value value))))
- ((listp value)
- (eval value))))
- (if variable
- (progn
- ;; This is an ordinary variable.
- (make-local-variable variable)
- (set variable value-value))
- ;; This is a header to be added to the headers when
- ;; posting.
- (when value-value
- (make-local-variable gnus-required-headers)
- (make-local-variable gnus-required-mail-headers)
- (push (cons (car attribute) value-value)
- gnus-required-headers)
- (push (cons (car attribute) value-value)
- gnus-required-mail-headers)))))))))
-
-(defun gnus-inews-set-point ()
- "Move point to where the user probably wants to find it."
- (gnus-inews-narrow-to-headers)
- (cond
- ((re-search-forward "^[^:]+:[ \t]*$" nil t)
- (search-backward ":" )
- (widen)
- (forward-char 2))
- (t
- (goto-char (point-max))
- (widen)
- (forward-line 1)
- (unless (looking-at "$")
- (forward-line 2)))
- (sit-for 0)))
-
(gnus-add-shutdown 'gnus-inews-close 'gnus)
(defun gnus-inews-close ()
--- /dev/null
+;;; message.el --- composing mail and news messages
+;; Copyright (C) 1996 Free Software Foundation, Inc.
+
+;; Author: Lars Magne Ingebrigtsen <larsi@ifi.uio.no>
+;; Keywords: mail, news
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2, or (at your option)
+;; any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs; see the file COPYING. If not, write to the
+;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+;; Boston, MA 02111-1307, USA.
+
+;;; Commentary:
+
+;; This mode provides mail-sending facilities from within Emacs. It
+;; consists mainly of large chunks of code from the sendmail.el,
+;; gnus-msg.el and rnewspost.el files.
+
+;;; Code:
+
+(eval-when-compile
+ (require 'cl))
+(require 'mail-header)
+
+(defvar message-fcc-handler-function 'rmail-output
+ "*A function called to save outgoing articles.
+This function will be called with the same of the file to store the
+article in. The default function is `rmail-output' which saves in Unix
+mailbox format.")
+
+(defvar message-courtesy-message
+ "The following message is a courtesy copy of an article\nthat has been posted as well.\n\n"
+ "*This is inserted at the start of a mailed copy of a posted message.
+If this variable is nil, no such courtesy message will be added.")
+
+(defvar message-ignored-bounced-headers "^\\(Received\\):"
+ "*Regexp that matches headers to be removed in resent bounced mail.")
+
+(defvar message-from-style 'angles
+ "*Specifies how \"From\" headers look.
+
+If `nil', they contain just the return address like:
+ king@grassland.com
+If `parens', they look like:
+ king@grassland.com (Elvis Parsley)
+If `angles', they look like:
+ Elvis Parsley <king@grassland.com>")
+
+(defvar message-syntax-checks
+ '(subject-cmsg multiple-headers sendsys message-id from
+ long-lines control-chars size new-text
+ redirected-followup signature approved sender
+ empty empty-headers)
+ "In non-nil, message will attempt to run some checks on outgoing posts.
+If this variable is t, message will check everything it can. If it is
+a list, then those elements in that list will be checked.")
+
+(defvar message-required-news-headers
+ '(From Date Newsgroups Subject Message-ID Organization Lines
+ (optional . X-Newsreader))
+ "*Headers to be generated or prompted for when posting an article.
+RFC977 and RFC1036 require From, Date, Newsgroups, Subject,
+Message-ID. Organization, Lines, In-Reply-To, Expires, and
+X-Newsreader are optional. If don't you want message to insert some
+header, remove it from this list.")
+
+(defvar message-required-mail-headers
+ '(From Date To Subject (optional . In-Reply-To) Message-ID Lines
+ (optional . X-Mailer))
+ "*Headers to be generated or prompted for when mailing a message.
+RFC822 required that From, Date, To, Subject and Message-ID be
+included. Organization, Lines and X-Mailer are optional.")
+
+(defvar message-deletable-headers '(Message-ID Date)
+ "*Headers to be deleted if they already exists and were generated by message previously.")
+
+(defvar message-ignored-news-headers
+ "^NNTP-Posting-Host:\\|^Xref:\\|^Bcc:\\|^Gcc:"
+ "*Regexp of headers to be removed unconditionally before posting.")
+
+(defvar message-ignored-supersedes-headers
+ "^Path:\\|^Date\\|^NNTP-Posting-Host:\\|^Xref:\\|^Lines:\\|^Received:\\|^X-From-Line:\\|Return-Path:"
+ "*Header lines matching this regexp will be deleted before posting.
+It's best to delete old Path and Date headers before posting to avoid
+any confusion.")
+
+(defvar message-signature-separator "^-- *$"
+ "Regexp matching signature separator.")
+
+(defvar message-interactive nil
+ "Non-nil means when sending a message wait for and display errors.
+nil means let mailer mail back a message to report errors.")
+
+(defvar gnus-local-organization)
+(defvar message-user-organization
+ (if (boundp 'gnus-local-organization)
+ gnus-local-organization t)
+ "*String to be used as an Organization header.
+If t, use `message-user-organization-file'.")
+
+(defvar message-user-organization-file "/usr/lib/news/organization"
+ "*Local news organization file.")
+
+(defvar message-autosave-directory "~/Mail/drafts/"
+ "*Directory where message autosaves buffers.
+If nil, message won't autosave.")
+
+(defvar message-forward-start-separator
+ "------- Start of forwarded message -------\n"
+ "*Delimiter inserted before forwarded messages.")
+
+(defvar message-forward-end-separator
+ "------- End of forwarded message -------\n"
+ "*Delimiter inserted after forwarded messages.")
+
+(defvar message-signature-before-forwarded-message t
+ "*If non-nil, put the signature before any included forwarded message.")
+
+(defvar message-included-forward-headers
+ "^From:\\|^Newsgroups:\\|^Subject:\\|^Date:\\|^Followup-To:\\|^Reply-To:\\|^Organization:\\|^Summary:\\|^Keywords:\\|^To:\\|^Cc:\\|^Posted-To:\\|^Mail-Copies-To:\\|^Apparently-To:\\|^Gnus-Warning:\\|^Resent-\\|^Message-ID:\\|^References:"
+ "*Regexp matching headers to be included in forwarded messages.")
+
+(defvar message-ignored-resent-headers "^Return-receipt"
+ "*All headers that match this regexp will be deleted when resending a message.")
+
+;;;###autoload
+(defvar message-ignored-cited-headers ":"
+ "Delete these headers from the messages you yank.")
+
+;; Useful to set in site-init.el
+;;;###autoload
+(defvar message-send-mail-function 'message-send-mail
+ "Function to call to send the current buffer as mail.
+The headers should be delimited by a line whose contents match the
+variable `message-header-separator'.")
+
+(defvar message-send-news-function 'message-send-news
+ "Function to call to send the current buffer as news.
+The headers should be delimited by a line whose contents match the
+variable `message-header-separator'.")
+
+(defvar message-reply-to-function nil
+ "Function that should return a list of headers.")
+
+(defvar message-wide-reply-to-function nil
+ "Function that should return a list of headers.")
+
+(defvar message-followup-to-function nil
+ "Function that should return a list of headers.")
+
+(defvar message-use-followup-to 'ask
+ "*Specifies what to do with Followup-To header.
+If nil, ignore the header. If it is t, use its value, but ignore
+\"poster\". If it is the symbol `ask', query the user whether to
+ignore the \"poster\" value. If it is the symbol `use', always use
+the value.")
+
+(defvar message-post-method
+ (cond ((boundp 'gnus-post-method)
+ gnus-post-method)
+ ((boundp 'gnus-select-method)
+ gnus-select-method)
+ (t '(nnspool "")))
+ "Method used to post news.")
+
+(defvar message-generate-headers-first nil
+ "*If non-nil, generate all possible headers before composing.")
+
+;;;###autoload
+(defvar message-header-separator "--text follows this line--"
+ "*Line used to separate headers from text in messages being composed.")
+
+;;;###autoload
+(defvar message-alias-file nil
+ "*If non-nil, the name of a file to use instead of `/usr/lib/aliases'.
+This file defines aliases to be expanded by the mailer; this is a different
+feature from that of defining aliases in `.mailrc' to be expanded in Emacs.
+This variable has no effect unless your system uses sendmail as its mailer.")
+
+;;;###autoload
+(defvar message-personal-alias-file "~/.mailrc"
+ "*If non-nil, the name of the user's personal mail alias file.
+This file typically should be in same format as the `.mailrc' file used by
+the `Mail' or `mailx' program.
+This file need not actually exist.")
+
+(defvar message-setup-hook nil
+ "Normal hook, run each time a new outgoing message is initialized.
+The function `message-setup' runs this hook.")
+
+(defvar message-header-setup-hook nil
+ "Hook called narrowed to the headers when setting up a message buffer.")
+
+(defvar message-citation-line-function 'message-insert-citation-line
+ "*Function called to insert the \"Whomever writes:\" line.")
+
+(defvar message-aliases t
+ "Alist of mail address aliases.
+If t, initialized from your mail aliases file.
+\(The file's name is normally `~/.mailrc', but your MAILRC environment
+variable can override that name.)
+The alias definitions in the file have this form:
+ alias ALIAS MEANING")
+
+(defvar message-alias-modtime nil
+ "The modification time of your mail alias file when it was last examined.")
+
+(defvar message-yank-prefix "> "
+ "*Prefix inserted on the lines of yanked messages.
+nil means use indentation.")
+
+(defvar message-indentation-spaces 3
+ "*Number of spaces to insert at the beginning of each cited line.
+Used by `message-yank-original' via `message-yank-cite'.")
+
+(defvar message-indent-citation-function 'message-indent-citation
+ "*Function for modifying a citation just inserted in the mail buffer.
+This can also be a list of functions. Each function can find the
+citation between (point) and (mark t). And each function should leave
+point and mark around the citation text as modified.")
+
+(defvar message-abbrevs-loaded nil)
+
+(autoload 'build-mail-aliases "mailalias"
+ "Read mail aliases from user's personal aliases file and set `mail-aliases'."
+ nil)
+
+(autoload 'expand-mail-aliases "mailalias"
+ "Expand all mail aliases in suitable header fields found between BEG and END.
+Suitable header fields are `To', `Cc' and `Bcc' and their `Resent-' variants.
+Optional second arg EXCLUDE may be a regular expression defining text to be
+removed from alias expansions."
+ nil)
+
+(defvar message-signature t
+ "*String to be inserted at the and the the message buffer.
+If t, the `message-signature-file' file will be inserted instead.
+If a function, the result from the function will be used instead.
+If a form, the result from the form will be used instead.")
+
+(defvar message-signature-file "~/.signature"
+ "*File containing the text inserted at end of mail buffer.")
+
+(defvar message-distribution-function nil
+ "*Function called to return a Distribution header.")
+
+(defvar message-expires 14
+ "*Number of days before your article expires.")
+
+(defvar message-user-path nil
+ "If nil, use the NNTP server name in the Path header.
+If stringp, use this; if non-nil, use no host name (user name only).")
+
+(defvar message-generic-domain nil
+ "If nil, the full host name will be the system name prepended to the domain name.
+If this is a string, the full host name will be this string.
+If this is non-nil, non-string, the domain name will be used as the
+full host name.")
+
+(defvar message-reply-buffer nil)
+(defvar message-reply-headers nil)
+(defvar message-newsreader nil)
+(defvar message-mailer nil)
+(defvar message-sent-message-via nil)
+(defvar message-send-actions nil
+ "A list of actions to be performed upon successful sending of a message.")
+
+(defvar message-default-headers nil
+ "*A string containing header lines to be inserted in outgoing messages.
+It is inserted before you edit the message, so you can edit or delete
+these lines.")
+
+(defvar message-default-mail-headers nil
+ "*A string of header lines to be inserted in outgoing mails.")
+
+(defvar message-default-news-headers nil
+ "*A string of header lines to be inserted in outgoing news articles.")
+
+;; Note: could use /usr/ucb/mail instead of sendmail;
+;; options -t, and -v if not interactive.
+(defvar message-mailer-swallows-blank-line
+ (if (and (string-match "sparc-sun-sunos\\(\\'\\|[^5]\\)"
+ system-configuration)
+ (file-readable-p "/etc/sendmail.cf")
+ (let ((buffer (get-buffer-create " *temp*")))
+ (unwind-protect
+ (save-excursion
+ (set-buffer buffer)
+ (insert-file-contents "/etc/sendmail.cf")
+ (goto-char (point-min))
+ (let ((case-fold-search nil))
+ (re-search-forward "^OR\\>" nil t)))
+ (kill-buffer buffer))))
+ ;; According to RFC822, "The field-name must be composed of printable
+ ;; ASCII characters (i.e. characters that have decimal values between
+ ;; 33 and 126, except colon)", i.e. any chars except ctl chars,
+ ;; space, or colon.
+ '(looking-at "[ \t]\\|[][!\"#$%&'()*+,-./0-9;<=>?@A-Z\\\\^_`a-z{|}~]+:"))
+ "Set this non-nil if the system's mailer runs the header and body together.
+\(This problem exists on Sunos 4 when sendmail is run in remote mode.)
+The value should be an expression to test whether the problem will
+actually occur.")
+
+(defvar message-mode-syntax-table
+ (let ((table (copy-syntax-table text-mode-syntax-table)))
+ (modify-syntax-entry ?% ". " table)
+ table)
+ "Syntax table used while in message mode.")
+
+(defvar message-font-lock-keywords
+ (let* ((cite-prefix "A-Za-z") (cite-suffix (concat cite-prefix "0-9_.@-")))
+ (list '("^To:" . font-lock-function-name-face)
+ '("^B?CC:\\|^Reply-To:" . font-lock-keyword-face)
+ '("^\\(Subject:\\)[ \t]*\\(.+\\)?"
+ (1 font-lock-comment-face) (2 font-lock-type-face nil t))
+ (list (concat "^\\(" (regexp-quote message-header-separator) "\\)$")
+ 1 'font-lock-comment-face)
+ (cons (concat "^[ \t]*"
+ "\\([" cite-prefix "]+[" cite-suffix "]*\\)?"
+ "[>|}].*")
+ 'font-lock-reference-face)
+ '("^\\(X-[A-Za-z0-9-]+\\|In-reply-to\\):.*"
+ . font-lock-string-face)))
+ "Additional expressions to highlight in Mail mode.")
+
+(defvar message-send-hook nil
+ "Hook run before sending messages.")
+
+(defvar message-sent-hook nil
+ "Hook run after sending messages.")
+
+(defvar message-header-format-alist
+ `((Newsgroups)
+ (To . message-fill-header)
+ (Cc . message-fill-header)
+ (Subject)
+ (In-Reply-To)
+ (Fcc)
+ (Bcc)
+ (Date)
+ (Organization)
+ (Distribution)
+ (Lines)
+ (Expires)
+ (Message-ID)
+ (References . message-fill-header)
+ (X-Mailer)
+ (X-Newsreader))
+ "Alist used for formatting headers.")
+
+\f
+
+;;;
+;;; Utility functions.
+;;;
+
+(defun message-point-at-bol ()
+ "Return point at the beginning of the line."
+ (let ((p (point)))
+ (beginning-of-line)
+ (prog1
+ (point)
+ (goto-char p))))
+
+(defun message-point-at-eol ()
+ "Return point at the end of the line."
+ (let ((p (point)))
+ (end-of-line)
+ (prog1
+ (point)
+ (goto-char p))))
+
+;; Delete the current line (and the next N lines.);
+(defmacro message-delete-line (&optional n)
+ `(delete-region (progn (beginning-of-line) (point))
+ (progn (forward-line ,(or n 1)) (point))))
+
+(defun message-tokenize-header (header &optional separator)
+ "Split HEADER into a list of header elements.
+\",\" is used as the separator."
+ (let* ((beg 0)
+ (separator (or separator ","))
+ (regexp
+ (format "[ \t]*\\([^%s]+\\)?\\([%s]+\\|\\'\\)" separator separator))
+ elems)
+ (while (and (string-match regexp header beg)
+ (< beg (length header)))
+ (when (match-beginning 1)
+ (push (match-string 1 header) elems))
+ (setq beg (match-end 0)))
+ (nreverse elems)))
+
+(defun message-fetch-reply-field (header)
+ "Fetch FIELD from the message we're replying to."
+ (when (and message-reply-buffer
+ (buffer-name message-reply-buffer))
+ (save-excursion
+ (set-buffer message-reply-buffer)
+ (mail-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)
+ (buffer-disable-undo (current-buffer))))
+
+(defun message-functionp (form)
+ "Return non-nil if FORM is funcallable."
+ (or (and (symbolp form) (fboundp form))
+ (and (listp form) (eq (car form) 'lambda))))
+
+(defun message-strip-subject-re (subject)
+ "Remove \"Re:\" from subject lines."
+ (if (string-match "^[Rr][Ee]: *" subject)
+ (substring subject (match-end 0))
+ subject))
+
+(defun message-remove-header (header &optional is-regexp first)
+ "Remove HEADER in the narrowed buffer.
+If REGEXP, HEADER is a regular expression.
+If FIRST, only remove the first instance of the header.
+Return the number of headers removed."
+ (goto-char (point-min))
+ (let ((regexp (if is-regexp header (concat "^" header ":")))
+ (number 0)
+ (case-fold-search t)
+ last)
+ (while (and (re-search-forward regexp nil t)
+ (not last))
+ (incf number)
+ (when first
+ (setq last t))
+ (delete-region
+ (message-point-at-bol)
+ ;; There might be a continuation header, so we have to search
+ ;; until we find a new non-continuation line.
+ (if (re-search-forward "^[^ \t]" nil t)
+ (goto-char (match-beginning 0))
+ (point-max))))
+ number))
+
+(defun message-narrow-to-headers ()
+ "Narrow the buffer to the head of the message."
+ (widen)
+ (narrow-to-region
+ (goto-char (point-min))
+ (if (re-search-forward
+ (concat "^" (regexp-quote message-header-separator) "\n") nil t)
+ (match-beginning 0)
+ (point-max)))
+ (goto-char (point-min)))
+
+(defun message-narrow-to-head ()
+ "Narrow the buffer to the head of the message."
+ (widen)
+ (narrow-to-region
+ (goto-char (point-min))
+ (if (search-forward "\n\n" nil 1)
+ (1- (point))
+ (point-max)))
+ (goto-char (point-min)))
+
+(defun message-news-p ()
+ "Say whether the current buffer contains a news message."
+ (mail-fetch-field "newsgroups"))
+
+(defun message-mail-p ()
+ "Say whether the current buffer contains a mail message."
+ (or (mail-fetch-field "to")
+ (mail-fetch-field "cc")
+ (mail-fetch-field "bcc")))
+
+\f
+
+;;;
+;;; Message mode
+;;;
+
+;;; Set up keymap.
+
+(defvar message-mode-map nil)
+
+(unless message-mode-map
+ (setq message-mode-map (nconc (make-sparse-keymap) text-mode-map))
+ (define-key message-mode-map "\C-c?" 'describe-mode)
+
+ (define-key message-mode-map "\C-c\C-f\C-t" 'message-goto-to)
+ (define-key message-mode-map "\C-c\C-f\C-b" 'message-goto-bcc)
+ (define-key message-mode-map "\C-c\C-f\C-f" 'message-goto-fcc)
+ (define-key message-mode-map "\C-c\C-f\C-c" 'message-goto-cc)
+ (define-key message-mode-map "\C-c\C-f\C-s" 'message-goto-subject)
+ (define-key message-mode-map "\C-c\C-f\C-r" 'message-goto-reply-to)
+ (define-key message-mode-map "\C-c\C-f\C-n" 'message-goto-newsgroups)
+ (define-key message-mode-map "\C-c\C-f\C-d" 'message-goto-distribution)
+ (define-key message-mode-map "\C-c\C-f\C-o" 'message-goto-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-b" 'message-goto-body)
+ (define-key message-mode-map "\C-c\C-s" 'message-goto-signature)
+
+ (define-key message-mode-map "\C-c\C-t" 'message-insert-to)
+ (define-key message-mode-map "\C-c\C-n" 'message-insert-newsgroups)
+
+ (define-key message-mode-map "\C-c\C-y" 'message-yank-original)
+ (define-key message-mode-map "\C-c\C-q" 'message-fill-yanked-message)
+ (define-key message-mode-map "\C-c\C-w" 'message-insert-signature)
+ (define-key message-mode-map "\C-c\C-r" 'message-caesar-buffer-body)
+
+ (define-key message-mode-map "\C-c\C-c" 'message-send-and-exit)
+ (define-key message-mode-map "\C-c\C-s" 'message-send))
+
+(easy-menu-define
+ message-menu message-mode-map ""
+ '("Mail"
+ ["Fill Citation" message-fill-yanked-message t]))
+
+;;;###autoload
+(defun message-mode ()
+ "Major mode for editing mail to be sent.
+Like Text Mode but with these additional commands:
+C-c C-s message-send (send the message) C-c C-c message-send-and-exit
+C-c C-f move to a header field (and create it if there isn't):
+ C-c C-f C-t move to To: C-c C-f C-s move to Subject:
+ C-c C-f C-c move to CC: C-c C-f C-b move to BCC:
+ C-c C-f C-f move to FCC:
+C-c C-t message-text (move to beginning of message text).
+C-c C-w message-signature (insert `message-signature-file' file).
+C-c C-y message-yank-original (insert current message, in Rmail).
+C-c C-q message-fill-yanked-message (fill what was yanked).
+C-c C-v message-sent-via (add a Sent-via field for each To or CC)."
+ (interactive)
+ (kill-all-local-variables)
+ (make-local-variable 'message-reply-buffer)
+ (setq message-reply-buffer nil)
+ (make-local-variable 'message-send-actions)
+ (set-syntax-table message-mode-syntax-table)
+ (use-local-map message-mode-map)
+ (setq local-abbrev-table text-mode-abbrev-table)
+ (setq major-mode 'message-mode)
+ (setq mode-name "Message")
+ (setq buffer-offer-save t)
+ (make-local-variable 'font-lock-defaults)
+ (setq font-lock-defaults '(message-font-lock-keywords t))
+ (make-local-variable 'paragraph-separate)
+ (make-local-variable 'paragraph-start)
+ (setq paragraph-start (concat (regexp-quote message-header-separator)
+ "$\\|[ \t]*[-_][-_][-_]+$\\|"
+ paragraph-start))
+ (setq paragraph-separate (concat (regexp-quote message-header-separator)
+ "$\\|[ \t]*[-_][-_][-_]+$\\|"
+ paragraph-separate))
+ (make-local-variable 'message-reply-headers)
+ (make-local-variable 'message-newsreader)
+ (make-local-variable 'message-mailer)
+ (make-local-variable 'message-post-method)
+ (make-local-variable 'message-sent-message-via)
+ (run-hooks 'text-mode-hook 'message-mode-hook))
+
+\f
+
+;;;
+;;; Message mode commands
+;;;
+
+;;; Movement commands
+
+(defun message-goto-to ()
+ "Move point to the To header."
+ (interactive)
+ (message-position-on-field "To"))
+
+(defun message-goto-subject ()
+ "Move point to the Subject header."
+ (interactive)
+ (message-position-on-field "Subject"))
+
+(defun message-goto-cc ()
+ "Move point to the Cc header."
+ (interactive)
+ (message-position-on-field "Cc" "To"))
+
+(defun message-goto-bcc ()
+ "Move point to the Bcc header."
+ (interactive)
+ (message-position-on-field "Bcc" "Cc" "To"))
+
+(defun message-goto-fcc ()
+ "Move point to the Followup-To header."
+ (interactive)
+ (message-position-on-field "Fcc" "To" "Newsgroups"))
+
+(defun message-goto-reply-to ()
+ "Move point to the Reply-To header."
+ (interactive)
+ (message-position-on-field "Reply-To" "Subject"))
+
+(defun message-goto-newsgroups ()
+ "Move point to the Newsgroups header."
+ (interactive)
+ (message-position-on-field "Newsgroups"))
+
+(defun message-goto-distribution ()
+ "Move point to the Distribution header."
+ (interactive)
+ (message-position-on-field "Distribution"))
+
+(defun message-goto-followup-to ()
+ "Move point to the Followup-To header."
+ (interactive)
+ (message-position-on-field "Followup-To" "Newsgroups"))
+
+(defun message-goto-keywords ()
+ "Move point to the Keywords header."
+ (interactive)
+ (message-position-on-field "Keywords" "Subject"))
+
+(defun message-goto-summary ()
+ "Move point to the Summary header."
+ (interactive)
+ (message-position-on-field "Summary" "Subject"))
+
+(defun message-goto-body ()
+ "Move point to the beginning of the message body."
+ (interactive)
+ (goto-char (point-min))
+ (search-forward (concat "\n" message-header-separator "\n") nil t))
+
+\f
+
+(defun message-insert-to ()
+ "Insert a To header that points to the author of the message being replied to."
+ (interactive)
+ (message-position-on-field "To")
+ (insert (or (message-fetch-reply-field "reply-to")
+ (message-fetch-reply-field "from") "")))
+
+(defun message-insert-newsgroups ()
+ "Insert the Newsgroups header from the article being replied to."
+ (interactive)
+ (message-position-on-field "newsgroups")
+ (insert (or (message-fetch-reply-field "newsgroups") "")))
+
+\f
+
+;;; Various commands
+
+(defun message-insert-signature ()
+ "Insert a signature."
+ (interactive)
+ (let* ((signature
+ (cond ((message-functionp message-signature)
+ (funcall message-signature))
+ ((listp message-signature)
+ (eval message-signature))
+ (t message-signature)))
+ (signature
+ (cond ((stringp signature)
+ signature)
+ ((and (eq t signature)
+ message-signature-file
+ (file-exists-p message-signature-file))
+ signature))))
+ (when signature
+ ;; Remove blank lines at the end of the message.
+ (goto-char (point-max))
+ (skip-chars-backward " \t\n")
+ (end-of-line)
+ (delete-region (point) (point-max))
+ ;; Insert the signature.
+ (insert "\n\n-- \n")
+ (if (eq signature t)
+ (insert-file-contents message-signature-file)
+ (insert signature))
+ (goto-char (point-max))
+ (or (bolp) (insert "\n")))))
+
+(defvar message-caesar-translation-table nil)
+
+(defun message-caesar-region (b e &optional n)
+ "Caesar rotation of region by N, default 13, for decrypting netnews."
+ (interactive
+ (list
+ (min (point) (or (mark t) (point)))
+ (max (point) (or (mark t) (point)))
+ (when current-prefix-arg
+ (prefix-numeric-value current-prefix-arg))))
+
+ (setq n (if (numberp n) (mod n 26) 13)) ;canonize N
+ (unless (or (zerop n) ; no action needed for a rot of 0
+ (= b e)) ; no region to rotate
+ ;; We build the table, if necessary.
+ (when (or (not message-caesar-translation-table)
+ (/= (aref message-caesar-translation-table ?a) (+ ?a n)))
+ (let ((i -1)
+ (table (make-string 256 0)))
+ (while (< (incf i) 256)
+ (aset table i i))
+ (setq table
+ (concat
+ (substring table 0 ?A)
+ (substring table (+ ?A n) (+ ?A n (- 26 n)))
+ (substring table ?A (+ ?A n))
+ (substring table (+ ?A 26) ?a)
+ (substring table (+ ?a n) (+ ?a n (- 26 n)))
+ (substring table ?a (+ ?a n))
+ (substring table (+ ?a 26) 255)))
+ (setq message-caesar-translation-table table)))
+ ;; Then we translate the region. Do it this way to retain
+ ;; text properties.
+ (while (< b e)
+ (subst-char-in-region
+ b (1+ b) (char-after b)
+ (aref message-caesar-translation-table (char-after b)))
+ (incf b))))
+
+(defun message-caesar-buffer-body (&optional rotnum)
+ "Caesar rotates all letters in the current buffer by 13 places.
+Used to encode/decode possibly offensive messages (commonly in net.jokes).
+With prefix arg, specifies the number of places to rotate each letter forward.
+Mail and USENET news headers are not rotated."
+ (interactive (if current-prefix-arg
+ (list (prefix-numeric-value current-prefix-arg))
+ (list nil)))
+ (save-excursion
+ (save-restriction
+ (when (message-goto-body)
+ (narrow-to-region (point) (point-max)))
+ (message-caesar-region (point-min) (point-max) rotnum))))
+
+(defun message-fill-yanked-message (&optional justifyp)
+ "Fill the paragraphs of a message yanked into this one.
+Numeric argument means justify as well."
+ (interactive "P")
+ (save-excursion
+ (goto-char (point-min))
+ (search-forward (concat "\n" message-header-separator "\n") nil t)
+ (fill-individual-paragraphs (point)
+ (point-max)
+ justifyp
+ t)))
+
+(defun message-indent-citation ()
+ "Modify text just inserted from a message to be cited.
+The inserted text should be the region.
+When this function returns, the region is again around the modified text.
+
+Normally, indent each nonblank line `message-indentation-spaces' spaces.
+However, if `message-yank-prefix' is non-nil, insert that prefix on each line."
+ (let ((start (point)))
+ ;; Remove unwanted headers.
+ (when message-ignored-cited-headers
+ (save-restriction
+ (narrow-to-region
+ (goto-char start)
+ (if (search-forward "\n\n" nil t)
+ (1- (point))
+ (point)))
+ (message-remove-header message-ignored-cited-headers t)))
+ ;; Do the indentation.
+ (if (null message-yank-prefix)
+ (indent-rigidly start (mark t) message-indentation-spaces)
+ (save-excursion
+ (goto-char start)
+ (while (< (point) (mark t))
+ (insert message-yank-prefix)
+ (forward-line 1)))
+ (goto-char start))))
+
+(defun message-yank-original (&optional arg)
+ "Insert the message being replied to, if any (in rmail).
+Puts point before the text and mark after.
+Normally indents each nonblank line ARG spaces (default 3). However,
+if `message-yank-prefix' is non-nil, insert that prefix on each line.
+
+Just \\[universal-argument] as argument means don't indent, insert no
+prefix, and don't delete any headers."
+ (interactive "P")
+ (when message-reply-buffer
+ (let ((start (point))
+ (functions
+ (when message-indent-citation-function
+ (if (listp message-indent-citation-function)
+ message-indent-citation-function
+ (list message-indent-citation-function)))))
+ ;; If the original message is in another window in the same frame,
+ ;; delete that window to save screen space.
+ ;; t means don't alter other frames.
+ (delete-windows-on message-reply-buffer t)
+ (insert-buffer message-reply-buffer)
+ (unless (consp arg)
+ (goto-char start)
+ (let ((message-indentation-spaces
+ (if arg (prefix-numeric-value arg)
+ message-indentation-spaces)))
+ (while functions
+ (funcall (pop functions)))))
+ (when message-citation-line-function
+ (unless (bolp)
+ (insert "\n"))
+ (funcall message-citation-line-function))
+ ;; This is like exchange-point-and-mark, but doesn't activate the mark.
+ ;; It is cleaner to avoid activation, even though the command
+ ;; loop would deactivate the mark because we inserted text.
+ (goto-char (prog1 (mark t)
+ (set-marker (mark-marker) (point) (current-buffer))))
+ (unless (bolp)
+ (insert ?\n)))))
+
+(defun message-insert-citation-line ()
+ "Function that inserts a simple citation line."
+ (when message-reply-headers
+ (insert (mail-header-from message-reply-headers) " writes:\n\n")))
+
+(defun message-position-on-field (header &rest afters)
+ (let ((case-fold-search t))
+ (save-restriction
+ (narrow-to-region
+ (goto-char (point-min))
+ (progn
+ (re-search-forward
+ (concat "^" (regexp-quote message-header-separator) "$"))
+ (match-beginning 0)))
+ (goto-char (point-min))
+ (if (re-search-forward (concat "^" (regexp-quote header) ":") nil t)
+ (progn
+ (re-search-forward "^[^ \t]" nil 'move)
+ (beginning-of-line)
+ (skip-chars-backward "\n")
+ t)
+ (while (and afters
+ (not (re-search-forward
+ (concat "^" (regexp-quote (car afters)) ":")
+ nil t)))
+ (pop afters))
+ (when afters
+ (re-search-forward "^[^ \t]" nil 'move)
+ (beginning-of-line))
+ (insert header ": \n")
+ (forward-char -1)
+ nil))))
+
+(defun message-remove-signature ()
+ "Remove the signature from the text between point and mark.
+The text will also be indented the normal way.
+This function can be used in `message-citation-hook', for instance."
+ (save-excursion
+ (let ((start (point))
+ mark)
+ (if (not (re-search-forward message-signature-separator (mark t) t))
+ ;; No signature here, so we just indent the cited text.
+ (message-indent-citation)
+ ;; Find the last non-empty line.
+ (forward-line -1)
+ (while (looking-at "[ \t]*$")
+ (forward-line -1))
+ (forward-line 1)
+ (setq mark (set-marker (make-marker) (point)))
+ (goto-char start)
+ (message-indent-citation)
+ ;; Enable undoing the deletion.
+ (undo-boundary)
+ (delete-region mark (mark t))
+ (set-marker mark nil)))))
+
+\f
+
+;;;
+;;; Sending messages
+;;;
+
+(defun message-send-and-exit (&optional arg)
+ "Send message like `message-send', then, if no errors, exit from mail buffer.
+Prefix arg means don't delete this window."
+ (interactive "P")
+ (message-send)
+ ;(message-bury arg)
+ )
+
+(defun message-dont-send (&optional arg)
+ "Don't send the message you have been editing.
+Prefix arg means don't delete this window."
+ (interactive "P")
+ (message-bury arg))
+
+(defun message-bury (arg)
+ "Bury this mail buffer."
+ (let ((newbuf (other-buffer (current-buffer))))
+ (bury-buffer (current-buffer))
+ (if (and (fboundp 'frame-parameters)
+ (cdr (assq 'dedicated (frame-parameters)))
+ (not (null (delq (selected-frame) (visible-frame-list)))))
+ (delete-frame (selected-frame))
+ (switch-to-buffer newbuf))))
+
+(defun message-send (&optional arg)
+ "Send the message in the current buffer.
+If `message-interactive' is non-nil, wait for success indication
+or error messages, and inform user.
+Otherwise any failure is reported in a message back to
+the user from the mailer."
+ (interactive "P")
+ (when (if buffer-file-name
+ (y-or-n-p (format "Send buffer contents as %s message? "
+ (if (message-mail-p)
+ (if (message-news-p) "main and news" "news")
+ "news")))
+ (or (buffer-modified-p)
+ (y-or-n-p "Message already sent; resend? ")))
+ ;; Make it possible to undo the coming changes.
+ (undo-boundary)
+ (run-hooks 'message-send-hook)
+ (message "Sending...")
+ (when (and (or (not (message-news-p))
+ (and (or (not (memq 'news message-sent-message-via))
+ (y-or-n-p
+ "Already sent message via news; resend? "))
+ (funcall message-send-news-function arg)))
+ (or (not (message-mail-p))
+ (and (or (not (memq 'mail message-sent-message-via))
+ (y-or-n-p
+ "Already sent message via mail; resend? "))
+ (funcall message-send-mail-function arg))))
+ (message-do-fcc)
+ (run-hooks 'message-sent-hook)
+ (message "Sending...done")
+ ;; If buffer has no file, mark it as unmodified and delete autosave.
+ (unless buffer-file-name
+ (set-buffer-modified-p nil)
+ (delete-auto-save-file-if-necessary t))
+ ;; Now perform actions on successful sending.
+ (let ((actions message-send-actions))
+ (while actions
+ (condition-case nil
+ (apply (caar actions) (cdar actions))
+ (error))
+ (pop actions))))))
+
+(defun message-send-mail (&optional arg)
+ (require 'mail-utils)
+ (let ((errbuf (if message-interactive
+ (generate-new-buffer " sendmail errors")
+ 0))
+ (tembuf (generate-new-buffer " message temp"))
+ (case-fold-search nil)
+ (news (message-news-p))
+ (resend-to-addresses (mail-fetch-field "resent-to"))
+ delimline
+ (mailbuf (current-buffer)))
+ (save-restriction
+ (message-narrow-to-headers)
+ ;; Remove some headers.
+ (message-remove-header message-ignored-news-headers t)
+ ;; Insert some headers.
+ (message-generate-headers message-required-mail-headers)
+ ;; Let the user do all of the above.
+ (run-hooks 'message-header-hook))
+ (unwind-protect
+ (save-excursion
+ (set-buffer tembuf)
+ (erase-buffer)
+ (insert-buffer-substring mailbuf)
+ (goto-char (point-max))
+ ;; require one newline at the end.
+ (or (= (preceding-char) ?\n)
+ (insert ?\n))
+ (when (and news
+ (or (mail-fetch-field "cc")
+ (mail-fetch-field "to")))
+ (message-insert-courtesy-copy))
+ (let ((case-fold-search t))
+ ;; Change header-delimiter to be what sendmail expects.
+ (goto-char (point-min))
+ (re-search-forward
+ (concat "^" (regexp-quote message-header-separator) "\n"))
+ (replace-match "\n")
+ (backward-char 1)
+ (setq delimline (point-marker))
+ (sendmail-synch-aliases)
+ (when message-aliases
+ (expand-mail-aliases (point-min) delimline))
+ ;; Insert an extra newline if we need it to work around
+ ;; Sun's bug that swallows newlines.
+ (goto-char (1+ delimline))
+ (when (eval message-mailer-swallows-blank-line)
+ (newline))
+ (when message-interactive
+ (save-excursion
+ (set-buffer errbuf)
+ (erase-buffer))))
+ (let ((default-directory "/"))
+ (apply 'call-process-region
+ (append (list (point-min) (point-max)
+ (if (boundp 'sendmail-program)
+ sendmail-program
+ "/usr/lib/sendmail")
+ nil errbuf nil "-oi")
+ ;; Always specify who from,
+ ;; since some systems have broken sendmails.
+ (list "-f" (user-login-name))
+ (and message-alias-file
+ (list (concat "-oA" message-alias-file)))
+ ;; These mean "report errors by mail"
+ ;; and "deliver in background".
+ (if (null message-interactive) '("-oem" "-odb"))
+ ;; Get the addresses from the message
+ ;; unless this is a resend.
+ ;; We must not do that for a resend
+ ;; because we would find the original addresses.
+ ;; For a resend, include the specific addresses.
+ (or resend-to-addresses
+ '("-t")))))
+ (when message-interactive
+ (save-excursion
+ (set-buffer errbuf)
+ (goto-char (point-min))
+ (while (re-search-forward "\n\n* *" nil t)
+ (replace-match "; "))
+ (if (not (zerop (buffer-size)))
+ (error "Sending...failed to %s"
+ (buffer-substring (point-min) (point-max)))))))
+ (kill-buffer tembuf)
+ (when (bufferp errbuf)
+ (kill-buffer errbuf)))
+ (push 'mail message-sent-message-via)))
+
+(defun message-send-news (&optional arg)
+ (let ((tembuf (generate-new-buffer " *message temp*"))
+ (case-fold-search nil)
+ (method (if (message-functionp message-post-method)
+ (funcall message-post-method arg)
+ message-post-method))
+ (messbuf (current-buffer)))
+ (save-restriction
+ (message-narrow-to-headers)
+ ;; Remove some headers.
+ (message-remove-header message-ignored-news-headers t)
+ ;; Insert some headers.
+ (message-generate-headers message-required-news-headers)
+ ;; Let the user do all of the above.
+ (run-hooks 'message-header-hook))
+ ;; Insert the proper mail headers.
+ (unwind-protect
+ (save-excursion
+ (set-buffer tembuf)
+ (buffer-disable-undo (current-buffer))
+ (erase-buffer)
+ (insert-buffer-substring messbuf)
+ (goto-char (point-max))
+ ;; require one newline at the end.
+ (or (= (preceding-char) ?\n)
+ (insert ?\n))
+ (let ((case-fold-search t))
+ ;; Remove the delimeter.
+ (goto-char (point-min))
+ (re-search-forward
+ (concat "^" (regexp-quote message-header-separator) "\n"))
+ (replace-match "\n")
+ (backward-char 1))
+ (require (car method))
+ (funcall (intern (format "%s-open-server" (car method)))
+ (cadr method) (cddr method))
+ (funcall (intern (format "%s-request-post"
+ (car method)))))
+ (kill-buffer tembuf))
+ (push 'news message-sent-message-via)))
+
+;;;
+;;; Header generation & syntax checking.
+;;;
+
+(defun message-check-news-syntax ()
+ "Check the syntax of the message."
+ (or
+ (not message-syntax-checks)
+ (and
+ ;; We narrow to the headers and check them first.
+ (save-excursion
+ (save-restriction
+ (message-narrow-to-headers)
+ (and
+ ;; Check for commands in Subject.
+ (or
+ (message-check-element 'subject-cmsg)
+ (save-excursion
+ (if (string-match "^cmsg " (mail-fetch-field "subject"))
+ (y-or-n-p
+ "The control code \"cmsg \" is in the subject. Really post? ")
+ t)))
+ ;; Check for multiple identical headers.
+ (or (message-check-element 'multiple-headers)
+ (save-excursion
+ (let (found)
+ (while (and (not found)
+ (re-search-forward "^[^ \t:]+: " nil t))
+ (save-excursion
+ (or (re-search-forward
+ (concat "^" (setq found
+ (buffer-substring
+ (match-beginning 0)
+ (- (match-end 0) 2))))
+ nil t)
+ (setq found nil))))
+ (if found
+ (y-or-n-p
+ (format "Multiple %s headers. Really post? " found))
+ t))))
+ ;; Check for Version and Sendsys.
+ (or (message-check-element 'sendsys)
+ (save-excursion
+ (if (re-search-forward "^Sendsys:\\|^Version:" nil t)
+ (y-or-n-p
+ (format "The article contains a %s command. Really post? "
+ (buffer-substring (match-beginning 0)
+ (1- (match-end 0)))))
+ t)))
+ ;; See whether we can shorten Followup-To.
+ (or (message-check-element 'shorten-followup-to)
+ (let ((newsgroups (mail-fetch-field "newsgroups"))
+ (followup-to (mail-fetch-field "followup-to"))
+ to)
+ (when (and newsgroups (string-match "," newsgroups)
+ (not followup-to)
+ (not
+ (zerop
+ (length
+ (setq to (completing-read
+ "Followups to: (default all groups) "
+ (mapcar (lambda (g) (list g))
+ (cons "poster"
+ (message-tokenize-header
+ newsgroups)))))))))
+ (goto-char (point-min))
+ (insert "Followup-To: " to "\n"))))
+
+ ;; Check for Approved.
+ (or (message-check-element 'approved)
+ (save-excursion
+ (if (re-search-forward "^Approved:" nil t)
+ (y-or-n-p
+ "The article contains an Approved header. Really post? ")
+ t))))))
+ ;; Check for long lines.
+ (or (message-check-element 'long-lines)
+ (save-excursion
+ (goto-char (point-min))
+ (re-search-forward
+ (concat "^" (regexp-quote mail-header-separator) "$"))
+ (while (and
+ (progn
+ (end-of-line)
+ (< (current-column) 80))
+ (zerop (forward-line 1))))
+ (or (bolp)
+ (eobp)
+ (y-or-n-p
+ "You have lines longer than 79 characters. Really post? "))))
+ ;; Check whether the article is empty.
+ (or (message-check-element 'empty)
+ (save-excursion
+ (goto-char (point-min))
+ (re-search-forward
+ (concat "^" (regexp-quote mail-header-separator) "$"))
+ (forward-line 1)
+ (or (re-search-forward "[^ \n\t]" nil t)
+ (y-or-n-p "Empty article. Really post?"))))
+ ;; Check for control characters.
+ (or (message-check-element 'control-chars)
+ (save-excursion
+ (if (re-search-forward "[\000-\007\013\015-\037\200-\237]" nil t)
+ (y-or-n-p
+ "The article contains control characters. Really post? ")
+ t)))
+ ;; Check excessive size.
+ (or (message-check-element 'size)
+ (if (> (buffer-size) 60000)
+ (y-or-n-p
+ (format "The article is %d octets long. Really post? "
+ (buffer-size)))
+ t))
+ ;; Check the length of the signature.
+ (or (message-check-element 'signature)
+ (progn
+ (goto-char (point-max))
+ (if (not (re-search-backward "^-- $" nil t))
+ t
+ (if (> (count-lines (point) (point-max)) 5)
+ (y-or-n-p
+ (format
+ "Your .sig is %d lines; it should be max 4. Really post? "
+ (count-lines (point) (point-max))))
+ t)))))))
+
+;; Returns non-nil if this type is not to be checked.
+(defun message-check-element (type)
+ (not
+ (or (not message-syntax-checks)
+ (if (listp message-syntax-checks)
+ (memq type message-syntax-checks)
+ t))))
+
+(defun message-do-fcc ()
+ "Process Fcc headers in the current buffer."
+ (let ((case-fold-search t)
+ list file)
+ (save-excursion
+ (save-restriction
+ (nnheader-narrow-to-headers)
+ (while (setq file (mail-fetch-field "fcc"))
+ (push file list)
+ (message-remove-header "fcc" nil t))
+ ;; Process FCC operations.
+ (widen)
+ (while list
+ (setq file (pop list))
+ (if (string-match "^[ \t]*|[ \t]*\\(.*\\)[ \t]*$" file)
+ ;; Pipe the article to the program in question.
+ (call-process-region (point-min) (point-max) shell-file-name
+ nil nil nil "-c" (match-string 1 file))
+ ;; Save the article.
+ (setq file (expand-file-name file))
+ (unless (file-exists-p (file-name-directory file))
+ (make-directory (file-name-directory file) t))
+ (if (and message-fcc-handler-function
+ (not (eq message-fcc-handler-function 'rmail-output)))
+ (funcall message-fcc-handler-function file)
+ (if (and (file-readable-p file) (mail-file-babyl-p file))
+ (rmail-output file 1)
+ (let ((mail-use-rfc822 t))
+ (rmail-output file 1 t t))))))))))
+
+(defun message-cleanup-headers ()
+ "Do various automatic cleanups of the headers."
+ ;; Remove empty lines in the header.
+ (save-restriction
+ (message-narrow-to-headers)
+ (while (re-search-forward "^[ \t]*\n" nil t)
+ (replace-match "" t t)))
+
+ ;; Correct Newsgroups and Followup-To headers: change sequence of
+ ;; spaces to comma and eliminate spaces around commas. Eliminate
+ ;; imbedded line breaks.
+ (goto-char (point-min))
+ (while (re-search-forward "^\\(Newsgroups\\|Followup-To\\): +" nil t)
+ (save-restriction
+ (narrow-to-region
+ (point)
+ (if (re-search-forward "^[^ \t]" nil t)
+ (match-beginning 0)
+ (forward-line 1)
+ (point)))
+ (goto-char (point-min))
+ (while (re-search-forward "\n[ \t]+" nil t)
+ (replace-match " " t t)) ;No line breaks (too confusing)
+ (goto-char (point-min))
+ (while (re-search-forward "[ \t\n]*,[ \t\n]*\\|[ \t]+" nil t)
+ (replace-match "," t t))
+ (goto-char (point-min))
+ ;; Remove trailing commas.
+ (when (re-search-forward ",+$" nil t)
+ (replace-match "" t t)))))
+
+(defun message-make-date ()
+ "Make a valid data header."
+ (let ((now (current-time)))
+ (timezone-make-date-arpa-standard
+ (current-time-string now) (current-time-zone now))))
+
+(defun message-make-message-id ()
+ "Make a unique Message-ID."
+ (concat "<" (message-unique-id) "@" (message-make-fqdm) ">"))
+
+(defvar message-unique-id-char nil)
+
+;; If you ever change this function, make sure the new version
+;; cannot generate IDs that the old version could.
+;; You might for example insert a "." somewhere (not next to another dot
+;; or string boundary), or modify the "fsf" string.
+(defun message-unique-id ()
+ ;; Don't use microseconds from (current-time), they may be unsupported.
+ ;; Instead we use this randomly inited counter.
+ (setq message-unique-id-char
+ (% (1+ (or message-unique-id-char (logand (random t) (1- (lsh 1 20)))))
+ ;; (current-time) returns 16-bit ints,
+ ;; and 2^16*25 just fits into 4 digits i base 36.
+ (* 25 25)))
+ (let ((tm (current-time)))
+ (concat
+ (if (memq system-type '(ms-dos emx vax-vms))
+ (let ((user (downcase (user-login-name))))
+ (while (string-match "[^a-z0-9_]" user)
+ (aset user (match-beginning 0) ?_))
+ user)
+ (message-number-base36 (user-uid) -1))
+ (message-number-base36 (+ (car tm)
+ (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.
+ ".fsf")))
+
+(defun message-number-base36 (num len)
+ (if (if (< len 0) (<= num 0) (= len 0))
+ ""
+ (concat (message-number-base36 (/ num 36) (1- len))
+ (char-to-string (aref "zyxwvutsrqponmlkjihgfedcba9876543210"
+ (% num 36))))))
+
+(defun message-make-organization ()
+ "Make an Organization header."
+ (let* ((organization
+ (or (getenv "ORGANIZATION")
+ (when message-user-organization
+ (if (message-functionp message-user-organization)
+ (funcall message-user-organization)
+ message-user-organization)))))
+ (save-excursion
+ (message-set-work-buffer)
+ (cond ((stringp message-user-organization)
+ (insert message-user-organization))
+ ((and (eq t message-user-organization)
+ message-user-organization-file
+ (file-exists-p message-user-organization-file))
+ (insert-file-contents message-user-organization-file)))
+ (goto-char (point-min))
+ (when (re-search-forward "[ \t\n]*" nil t)
+ (replace-match "" t t))
+ (unless (zerop (buffer-size))
+ (buffer-string)))))
+
+(defun message-make-lines ()
+ "Count the number of lines and return numeric string."
+ (save-excursion
+ (save-restriction
+ (widen)
+ (goto-char (point-min))
+ (re-search-forward
+ (concat "^" (regexp-quote message-header-separator) "$"))
+ (forward-line 1)
+ (int-to-string (count-lines (point) (point-max))))))
+
+(defun message-make-in-reply-to ()
+ "Return the In-Reply-To header for this message."
+ (when message-reply-headers
+ (let ((from (mail-header-from message-reply-headers))
+ (date (mail-header-date message-reply-headers)))
+ (when from
+ (let ((stop-pos
+ (string-match " *at \\| *@ \\| *(\\| *<" from)))
+ (concat (if stop-pos (substring from 0 stop-pos) from)
+ "'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)
+ (funcall message-distribution-function))
+ (t orig-distribution))))
+
+(defun message-make-expires ()
+ "Return an Expires header based on `message-expires'."
+ (let ((current (current-time))
+ (future (* 1.0 message-expires 60 60 24)))
+ ;; Add the future to current.
+ (setcar current (+ (car current) (round (/ future (expt 2 16)))))
+ (setcar (cdr current) (+ (nth 1 current) (% (round future) (expt 2 16))))
+ ;; Return the date in the future in UT.
+ (timezone-make-date-arpa-standard
+ (current-time-string current) (current-time-zone current) '(0 "UT"))))
+
+(defun message-make-path ()
+ "Return uucp path."
+ (let ((login-name (user-login-name)))
+ (cond ((null message-user-path)
+ (concat (system-name) "!" login-name))
+ ((stringp message-user-path)
+ ;; Support GENERICPATH. Suggested by vixie@decwrl.dec.com.
+ (concat message-user-path "!" login-name))
+ (t login-name))))
+
+(defun message-make-from ()
+ "Make a From header."
+ (let* ((login (message-make-address))
+ (fullname (user-full-name)))
+ (when (string= fullname "&")
+ (setq fullname (user-login-name)))
+ (save-excursion
+ (message-set-work-buffer)
+ (cond
+ ((eq message-from-style 'angles)
+ (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 ">"))
+ ((eq message-from-style 'parens)
+ (insert login " (")
+ (let ((fullname-start (point)))
+ (insert fullname)
+ (goto-char fullname-start)
+ ;; RFC 822 says \ and nonmatching parentheses
+ ;; must be escaped in comments.
+ ;; Escape every instance of ()\ ...
+ (while (re-search-forward "[()\\]" nil 1)
+ (replace-match "\\\\\\&" t))
+ ;; ... then undo escaping of matching parentheses,
+ ;; including matching nested parentheses.
+ (goto-char fullname-start)
+ (while (re-search-forward
+ "\\(\\=\\|[^\\]\\(\\\\\\\\\\)*\\)\\\\(\\(\\([^\\]\\|\\\\\\\\\\)*\\)\\\\)"
+ nil 1)
+ (replace-match "\\1(\\3)" t)
+ (goto-char fullname-start)))
+ (insert ")"))
+ ((null message-from-style)
+ (insert login "\n")))
+ (buffer-string))))
+
+(defun message-make-sender ()
+ "Return the \"real\" user address.
+This function tries to ignore all user modifications, and
+give as trustworthy answer as possible."
+ (concat (user-login-name) "@" (system-name)))
+
+(defun message-make-address ()
+ "Make the address of the user."
+ (concat (user-login-name) "@" (message-make-domain)))
+
+(defun message-make-fqdm ()
+ "Return user's fully qualified domain name."
+ (let ((system-name (system-name)))
+ (if (string-match "[^.]\\.[^.]" system-name)
+ ;; `system-name' returned the right result.
+ system-name
+ ;; We try `user-mail-address' as a backup.
+ (if (string-match "@\\([^ ]+\\)\\($\\| \\)" user-mail-address)
+ (match-string 1 user-mail-address)
+ (concat system-name ".i-have-a-misconfigured-system-so-shoot-me")))))
+
+(defun message-make-host-name ()
+ "Return the name of the host."
+ (let ((fqdm (message-make-fqdm)))
+ (string-match "^[^.]+\\." fqdm)
+ (substring fqdm 0 (1- (match-end 0)))))
+
+(defun message-make-domain ()
+ "Return the domain name."
+ (let ((fqdm (message-make-fqdm)))
+ (if message-generic-domain
+ (progn
+ (string-match "^[^.]+\\." fqdm)
+ (substring fqdm (match-end 0)))
+ fqdm)))
+
+(defun message-generate-headers (headers)
+ "Prepare article HEADERS.
+Headers already prepared in the buffer are not modified."
+ (save-restriction
+ (message-narrow-to-headers)
+ (let* ((Date (message-make-date))
+ (Message-ID (message-make-message-id))
+ (Organization (message-make-organization))
+ (From (message-make-from))
+ (Path (message-make-path))
+ (Subject nil)
+ (Newsgroups nil)
+ (In-Reply-To (message-make-in-reply-to))
+ (To nil)
+ (Distribution (message-make-distribution))
+ (Lines (message-make-lines))
+ (X-Newsreader message-newsreader)
+ (X-Mailer message-mailer)
+ (Expires (message-make-expires))
+ (case-fold-search t)
+ header value elem)
+ ;; First we remove any old generated headers.
+ (let ((headers message-deletable-headers))
+ (while headers
+ (goto-char (point-min))
+ (and (re-search-forward
+ (concat "^" (symbol-name (car headers)) ": *") nil t)
+ (get-text-property (1+ (match-beginning 0)) 'message-deletable)
+ (message-delete-line))
+ (pop headers)))
+ ;; If there are References, and the subject has changed, then
+ ;; we have to change the Message-ID. See Son-of-1036.
+ (when (and message-reply-headers
+ (mail-fetch-field "references"))
+ (let ((psubject (mail-fetch-field "subject")))
+ (and psubject (mail-header-subject message-reply-headers)
+ (string= (message-strip-subject-re
+ (mail-header-subject message-reply-headers))
+ (message-strip-subject-re
+ psubject))
+ (progn
+ (string-match "@" Message-ID)
+ (setq Message-ID
+ (concat (substring Message-ID 0 (match-beginning 0))
+ "_-_"
+ (substring Message-ID (match-beginning 0))))))))
+ ;; Go through all the required headers and see if they are in the
+ ;; articles already. If they are not, or are empty, they are
+ ;; inserted automatically - except for Subject, Newsgroups and
+ ;; Distribution.
+ (while headers
+ (goto-char (point-min))
+ (setq elem (pop headers))
+ (if (consp elem)
+ (setq header (car elem))
+ (setq header elem))
+ (when (or (not (re-search-forward
+ (concat "^" (downcase (symbol-name header)) ":") nil t))
+ (progn
+ ;; The header was found. We insert a space after the
+ ;; colon, if there is none.
+ (if (/= (following-char) ? ) (insert " ") (forward-char 1))
+ ;; Find out whether the header is empty...
+ (looking-at "[ \t]*$")))
+ ;; So we find out what value we should insert.
+ (setq value
+ (cond
+ ((and (consp elem) (eq (car elem) 'optional))
+ ;; This is an optional header. If the cdr of this
+ ;; is something that is nil, then we do not insert
+ ;; this header.
+ (setq header (cdr elem))
+ (or (and (fboundp (cdr elem)) (funcall (cdr elem)))
+ (and (boundp (cdr elem)) (symbol-value (cdr elem)))))
+ ((consp elem)
+ ;; The element is a cons. Either the cdr is a
+ ;; string to be inserted verbatim, or it is a
+ ;; function, and we insert the value returned from
+ ;; this function.
+ (or (and (stringp (cdr elem)) (cdr elem))
+ (and (fboundp (cdr elem)) (funcall (cdr elem)))))
+ ((and (boundp header) (symbol-value header))
+ ;; The element is a symbol. We insert the value
+ ;; of this symbol, if any.
+ (symbol-value header))
+ (t
+ ;; We couldn't generate a value for this header,
+ ;; so we just ask the user.
+ (read-from-minibuffer
+ (format "Empty header for %s; enter value: " header)))))
+ ;; Finally insert the header.
+ (when (and value
+ (not (equal value "")))
+ (save-excursion
+ (if (bolp)
+ (progn
+ ;; This header didn't exist, so we insert it.
+ (goto-char (point-max))
+ (insert (symbol-name header) ": " value "\n")
+ (forward-line -1))
+ ;; The value of this header was empty, so we clear
+ ;; totally and insert the new value.
+ (delete-region (point) (message-point-at-eol))
+ (insert value))
+ ;; Add the deletable property to the headers that require it.
+ (and (memq header message-deletable-headers)
+ (progn (beginning-of-line) (looking-at "[^:]+: "))
+ (add-text-properties
+ (point) (match-end 0)
+ '(message-deletable t face italic) (current-buffer)))))))
+ ;; Insert new Sender if the From is strange.
+ (let ((from (mail-fetch-field "from"))
+ (sender (mail-fetch-field "sender"))
+ (secure-sender (message-make-sender)))
+ (when (and from
+ (not (message-check-element 'sender))
+ (not (string=
+ (downcase (cadr (mail-extract-address-components from)))
+ (downcase secure-sender)))
+ (or (null sender)
+ (not
+ (string=
+ (downcase
+ (cadr (mail-extract-address-components sender)))
+ (downcase secure-sender)))))
+ (goto-char (point-min))
+ ;; Rename any old Sender headers to Original-Sender.
+ (when (re-search-forward "^Sender:" nil t)
+ (beginning-of-line)
+ (insert "Original-")
+ (beginning-of-line))
+ (insert "Sender: " secure-sender "\n"))))))
+
+(defun message-insert-courtesy-copy ()
+ "Insert a courtesy message in mail copies of combined messages."
+ (save-excursion
+ (save-restriction
+ (message-narrow-to-headers)
+ (let ((newsgroups (mail-fetch-field "newsgroups")))
+ (goto-char (point-max))
+ (insert "Posted-To: " newsgroups "\n")))
+ (forward-line 1)
+ (insert message-courtesy-message)))
+
+;;;
+;;; Setting up a message buffer
+;;;
+
+(defun message-fill-header (header value)
+ (let ((begin (point))
+ (fill-column 78)
+ (fill-prefix "\t"))
+ (insert (capitalize (symbol-name header))
+ ": "
+ (if (consp value) (car value) value)
+ "\n")
+ (fill-region-as-paragraph begin (1- (point)))))
+
+(defun sendmail-synch-aliases ()
+ (let ((modtime (nth 5 (file-attributes message-personal-alias-file))))
+ (or (equal message-alias-modtime modtime)
+ (setq message-alias-modtime modtime
+ message-aliases t))))
+
+(defun message-position-point ()
+ "Move point to where the user probably wants to find it."
+ (message-narrow-to-headers)
+ (cond
+ ((re-search-forward "^[^:]+:[ \t]*$" nil t)
+ (search-backward ":" )
+ (widen)
+ (forward-char 1)
+ (if (= (following-char) ? )
+ (forward-char 1)
+ (insert " ")))
+ (t
+ (goto-char (point-max))
+ (widen)
+ (forward-line 1)
+ (unless (looking-at "$")
+ (forward-line 2)))
+ (sit-for 0)))
+
+(defun message-pop-to-buffer (name)
+ "Pop to buffer NAME, and warn if it already exists and is modified."
+ (let ((buffer (get-buffer name)))
+ (if (and buffer
+ (buffer-name buffer))
+ (progn
+ (set-buffer (pop-to-buffer buffer))
+ (when (and (buffer-modified-p)
+ (not (y-or-n-p
+ "Message already being composed; erase? ")))
+ (error "Message being composed")))
+ (set-buffer (pop-to-buffer name)))
+ (erase-buffer)
+ (message-mode)))
+
+(defun message-setup (headers &optional replybuffer actions)
+ (sendmail-synch-aliases)
+ (when (eq message-aliases t)
+ (setq message-aliases nil)
+ (when (file-exists-p message-personal-alias-file)
+ (build-mail-aliases)))
+ (setq message-send-actions actions)
+ (setq message-reply-buffer replybuffer)
+ (goto-char (point-min))
+ ;; Insert all the headers.
+ (mail-header-format
+ (let ((h headers)
+ (alist message-header-format-alist))
+ (while h
+ (unless (assq (caar h) message-header-format-alist)
+ (push (list (caar h)) alist))
+ (pop h))
+ alist)
+ headers)
+ (when message-default-headers
+ (insert message-default-headers))
+ (when (and (message-news-p)
+ message-default-news-headers)
+ (when message-generate-headers-first
+ (message-generate-headers message-required-news-headers))
+ (insert message-default-news-headers))
+ (when (and (message-mail-p)
+ message-default-mail-headers)
+ (when message-generate-headers-first
+ (message-generate-headers message-required-mail-headers))
+ (insert message-default-mail-headers))
+ (forward-line -1)
+ (insert message-header-separator "\n")
+ (message-insert-signature)
+ (message-set-auto-save-file-name)
+ (save-restriction
+ (message-narrow-to-headers)
+ (run-hooks 'message-header-setup-hook))
+ (set-buffer-modified-p nil)
+ (run-hooks 'message-setup-hook)
+ (message-position-point))
+
+(defun message-set-auto-save-file-name ()
+ "Associate the message buffer with a file in the drafts directory."
+ (when message-autosave-directory
+ (unless (file-exists-p message-autosave-directory)
+ (make-directory message-autosave-directory t))
+ (let ((name (make-temp-name
+ (concat (file-name-as-directory message-autosave-directory)
+ "msg."))))
+ (setq buffer-auto-save-file-name
+ (save-excursion
+ (prog1
+ (progn
+ (set-buffer (get-buffer-create " *draft tmp*"))
+ (setq buffer-file-name name)
+ (make-auto-save-file-name))
+ (kill-buffer (current-buffer)))))
+ (clear-visited-file-modtime))))
+
+\f
+
+;;;
+;;; Commands for interfacing with message
+;;;
+
+;;;###autoload
+(defun message-mail (&optional to subject)
+ "Start editing a mail message to be sent."
+ (interactive)
+ (message-pop-to-buffer "*mail message*")
+ (message-setup `((To . ,(or to "")) (Subject . ,(or subject "")))))
+
+;;;###autoload
+(defun message-news (&optional newsgroups subject)
+ "Start editing a news article to be sent."
+ (interactive)
+ (message-pop-to-buffer "*news message*")
+ (message-setup `((Newsgroups . ,(or newsgroups ""))
+ (Subject . ,(or subject "")))))
+
+;;;###autoload
+(defun message-reply (&optional to-address wide)
+ "Start editing a reply to the article in the current buffer."
+ (interactive)
+ (let ((cur (current-buffer))
+ from subject date reply-to message-of to cc
+ references message-id sender follow-to sendto elt new-cc new-to
+ mct never-mct gnus-warning)
+ (save-restriction
+ (narrow-to-region
+ (goto-char (point-min))
+ (if (search-forward "\n\n" nil t)
+ (1- (point))
+ (point-max)))
+ ;; Allow customizations to have their say.
+ (if (not wide)
+ ;; This is a regular reply.
+ (if (message-functionp message-reply-to-function)
+ (setq follow-to (funcall message-reply-to-function)))
+ ;; This is a followup.
+ (if (gnus-functionp message-wide-reply-to-function)
+ (save-excursion
+ (setq follow-to
+ (funcall message-wide-reply-to-function)))))
+ ;; Find all relevant headers we need.
+ (setq from (mail-fetch-field "from")
+ date (mail-fetch-field "date")
+ sender (mail-fetch-field "sender")
+ subject (or (mail-fetch-field "subject") "none")
+ to (mail-fetch-field "to")
+ cc (mail-fetch-field "cc")
+ mct (mail-fetch-field "mail-copies-to")
+ reply-to (mail-fetch-field "reply-to")
+ references (mail-fetch-field "references")
+ message-id (mail-fetch-field "message-id"))
+ ;; Remove any (buggy) Re:'s that are present and make a
+ ;; proper one.
+ (when (string-match "^[ \t]*[Re][Ee]:[ \t]*" subject)
+ (setq subject (substring subject (match-end 0))))
+ (setq subject (concat "Re: " subject))
+
+ (when (and (setq gnus-warning (mail-fetch-field "gnus-warning"))
+ (string-match "<[^>]+>" gnus-warning))
+ (setq message-id (match-string 0 gnus-warning)))
+
+ ;; Handle special values of Mail-Copies-To.
+ (when mct
+ (cond ((equal (downcase mct) "never")
+ (setq never-mct t)
+ (setq mct nil))
+ ((equal (downcase mct) "always")
+ (setq mct (or reply-to from)))))
+
+ (unless follow-to
+ (if (or (not wide)
+ to-address)
+ (setq follow-to (list (cons 'To (or to-address reply-to from))))
+ (let (ccalist)
+ (save-excursion
+ (message-set-work-buffer)
+ (unless never-mct
+ (insert (or reply-to from "")))
+ (insert
+ (if (bolp) "" ", ") (or to "")
+ (if mct (concat (if (bolp) "" ", ") mct) "")
+ (if cc (concat (if (bolp) "" ", ") cc) ""))
+ ;; Remove addresses that match `rmail-dont-reply-to-names'.
+ (insert (prog1 (rmail-dont-reply-to (buffer-string))
+ (erase-buffer)))
+ (goto-char (point-min))
+ (setq ccalist
+ (mapcar
+ (lambda (addr)
+ (cons (mail-strip-quoted-names addr) addr))
+ (nreverse (mail-parse-comma-list))))
+ (let ((s ccalist))
+ (while s
+ (setq ccalist (delq (assoc (car (pop s)) s) ccalist)))))
+ (setq follow-to (list (cons 'To (cdr (pop ccalist)))))
+ (when ccalist
+ (push (cons 'Cc
+ (mapconcat (lambda (addr) (cdr addr)) ccalist ", "))
+ follow-to)))))
+ (widen))
+
+ (message-pop-to-buffer "*mail message*")
+
+ (setq message-reply-headers
+ (vector 0 subject from date message-id references 0 0 ""))
+
+ (message-setup
+ `((Subject . ,subject)
+ ,@follow-to
+ (References . ,(concat (or references "") (and references " ")
+ (or message-id ""))))
+ cur)))
+
+;;;###autoload
+(defun message-wide-reply (&optional to-address)
+ (interactive)
+ (message-reply to-address t))
+
+;;;###autoload
+(defun message-followup ()
+ (interactive)
+ (let ((cur (current-buffer))
+ from subject date message-of reply-to mct
+ references message-id follow-to sendto elt
+ followup-to distribution newsgroups gnus-warning)
+ (save-restriction
+ (narrow-to-region
+ (goto-char (point-min))
+ (if (search-forward "\n\n" nil t)
+ (1- (point))
+ (point-max)))
+ (when (message-functionp message-followup-to-function)
+ (setq follow-to
+ (funcall message-followup-to-function)))
+ (setq from (mail-fetch-field "from")
+ date (mail-fetch-field "date")
+ subject (or (mail-fetch-field "subject") "none")
+ references (mail-fetch-field "references")
+ message-id (mail-fetch-field "message-id")
+ followup-to (mail-fetch-field "followup-to")
+ newsgroups (mail-fetch-field "newsgroups")
+ reply-to (mail-fetch-field "reply-to")
+ distribution (mail-fetch-field "distribution")
+ mct (mail-fetch-field "mail-copies-to"))
+ (when (and (setq gnus-warning (mail-fetch-field "gnus-warning"))
+ (string-match "<[^>]+>" gnus-warning))
+ (setq message-id (match-string 0 gnus-warning)))
+ ;; Remove bogus distribution.
+ (and (stringp distribution)
+ (string-match "world" distribution)
+ (setq distribution nil))
+ ;; Remove any (buggy) Re:'s that are present and make a
+ ;; proper one.
+ (when (string-match "^[ \t]*[Re][Ee]:[ \t]*" subject)
+ (setq subject (substring subject (match-end 0))))
+ (setq subject (concat "Re: " subject))
+ (widen))
+
+ (message-pop-to-buffer "*news message*")
+
+ (message-setup
+ `((Subject . ,subject)
+ ,@(cond
+ (follow-to follow-to)
+ ((and followup-to message-use-followup-to)
+ (list
+ (cond
+ ((equal (downcase followup-to) "poster")
+ (if (or (eq message-use-followup-to 'use)
+ (y-or-n-p "Use Followup-To \"poster\"? "))
+ (cons 'To (or reply-to from ""))
+ (cons 'Newsgroups newsgroups)))
+ (t
+ (if (or (equal followup-to newsgroups)
+ (not (eq message-use-followup-to 'ask))
+ (y-or-n-p (format "Use Followup-To %s? " followup-to)))
+ (cons 'Newsgroups followup-to)
+ (cons 'Newsgroups newsgroups))))))
+ (t
+ `((Newsgroups . ,newsgroups))))
+ ,@(and distribution (list (cons 'Distribution distribution)))
+ (References . ,(concat (or references "") (and references " ")
+ (or message-id "")))
+ ,@(when (and mct
+ (not (equal (downcase mct) "never")))
+ (list (cons 'Cc (if (equal (downcase mct) "always")
+ (or reply-to from "")
+ mct)))))
+ cur)))
+
+;;;###autoload
+(defun message-cancel-news ()
+ "Cancel an article you posted."
+ (interactive)
+ (unless (message-news-p)
+ (error "This is not a news article; canceling is impossible"))
+ (when (yes-or-no-p "Do you really want to cancel this article? "))
+ (let (from newsgroups message-id distribution buf)
+ (save-excursion
+ ;; Get header info. from original article.
+ (save-restriction
+ (message-narrow-to-head)
+ (setq from (mail-fetch-field "from")
+ newsgroups (mail-fetch-field "newsgroups")
+ message-id (mail-fetch-field "message-id")
+ distribution (mail-fetch-field "distribution")))
+ ;; Make sure that this article was written by the user.
+ (unless (string-equal
+ (downcase (mail-strip-quoted-names from))
+ (downcase (message-make-address)))
+ (error "This article is not yours"))
+ ;; Make control message.
+ (setq buf (set-buffer (get-buffer-create " *message cancel*")))
+ (buffer-disable-undo (current-buffer))
+ (erase-buffer)
+ (insert "Newsgroups: " newsgroups "\n"
+ "From: " (message-make-from) "\n"
+ "Subject: cmsg cancel " message-id "\n"
+ "Control: cancel " message-id "\n"
+ (if distribution
+ (concat "Distribution: " distribution "\n")
+ "")
+ message-header-separator "\n"
+ "This is a cancel message from " from ".\n")
+ (message "Canceling your article...")
+ (funcall message-send-news-function)
+ (message "Canceling your article...done")
+ (kill-buffer buf))))
+
+;;;###autoload
+(defun message-supersede ()
+ "Start composing a message to supersede the current 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)))
+ ;; Check whether the user owns the article that is to be superseded.
+ (unless (string-equal
+ (downcase (mail-strip-quoted-names (mail-fetch-field "from")))
+ (downcase (mail-strip-quoted-names (message-make-address))))
+ (error "This article is not yours"))
+ ;; Get a normal message buffer.
+ (message-pop-to-buffer "*supersede message*")
+ (insert-buffer-substring cur)
+ (message-narrow-to-head)
+ ;; Remove unwanted headers.
+ (when message-ignored-supersedes-headers
+ (message-remove-header message-ignored-supersedes-headers t))
+ (goto-char (point-min))
+ (if (not (re-search-forward "^Message-ID: " nil t))
+ (error "No Message-ID in this article")
+ (replace-match "Supersedes: " t t))
+ (goto-char (point-max))
+ (insert message-header-separator)
+ (widen)
+ (forward-line 1)))
+
+;;;###autoload
+(defun message-recover ()
+ "Reread contents of current buffer from its last auto-save file."
+ (interactive)
+ (let ((file-name (make-auto-save-file-name)))
+ (cond ((save-window-excursion
+ (if (not (eq system-type 'vax-vms))
+ (with-output-to-temp-buffer "*Directory*"
+ (buffer-disable-undo standard-output)
+ (let ((default-directory "/"))
+ (call-process
+ "ls" nil standard-output nil "-l" file-name))))
+ (yes-or-no-p (format "Recover auto save file %s? " file-name)))
+ (let ((buffer-read-only nil))
+ (erase-buffer)
+ (insert-file-contents file-name nil)))
+ (t (error "message-recover cancelled")))))
+
+;;; Forwarding messages.
+
+(defun message-make-forward-subject ()
+ "Return a Subject header suitable for the message in the current buffer."
+ (concat "[" (mail-fetch-field (if (message-news-p) "newsgroups" "from"))
+ "] " (or (mail-fetch-field "Subject") "")))
+
+;;;###autoload
+(defun message-forward (&optional news)
+ (interactive "P")
+ (let ((cur (current-buffer))
+ (subject (message-make-forward-subject)))
+ (if news (message-news nil subject) (message-mail nil subject))
+ ;; Put point where we want it before inserting the forwarded
+ ;; message.
+ (if message-signature-before-forwarded-message
+ (goto-char (point-max))
+ (message-goto-body))
+ ;; Narrow to the area we are to insert.
+ (narrow-to-region (point) (point))
+ ;; Insert the separators and the forwarded buffer.
+ (insert message-forward-start-separator)
+ (insert-buffer-substring cur)
+ (goto-char (point-max))
+ (insert message-forward-end-separator)
+ (set-text-properties (point-min) (point-max) nil)
+ ;; Remove all unwanted headers.
+ (goto-char (point-min))
+ (forward-line 1)
+ (narrow-to-region (point) (if (search-forward "\n\n" nil t)
+ (1- (point))
+ (point)))
+ (goto-char (point-min))
+ (message-remove-header message-included-forward-headers t)
+ (widen)
+ (message-position-point)))
+
+;;;###autoload
+(defun message-resend (address)
+ "Resend the current article to ADDRESS."
+ (interactive "sResend message to: ")
+ (save-excursion
+ (let ((cur (current-buffer))
+ beg)
+ ;; We first set up a normal mail buffer.
+ (message-set-work-buffer)
+ (message-setup `((To . ,address)))
+ ;; Insert our usual headers.
+ (message-narrow-to-headers)
+ (message-generate-headers '(From Date To))
+ (goto-char (point-min))
+ ;; Rename them all to "Resent-*".
+ (while (re-search-forward "^[A-Za-z]" nil t)
+ (forward-char -1)
+ (insert "Resent-"))
+ (widen)
+ (forward-line)
+ (delete-region (point) (point-max))
+ (setq beg (point))
+ ;; Insert the message to be resent.
+ (insert-buffer-substring cur)
+ (goto-char (point-min))
+ (search-forward "\n\n")
+ (forward-char -1)
+ (save-restriction
+ (narrow-to-region beg (point))
+ (message-remove-header message-ignored-resent-headers t)
+ (goto-char (point-max)))
+ (insert mail-header-separator)
+ ;; Rename all old ("Also-")Resent headers.
+ (while (re-search-backward "^\\(Also-\\)?Resent-" beg t)
+ (beginning-of-line)
+ (insert "Also-"))
+ ;; Send it.
+ (funcall message-send-mail-function))))
+
+;;;###autoload
+(defun message-bounce ()
+ "Re-mail the current message.
+This only makes sense if the current message is a bounce message than
+contains some mail you have written which has been bounced back to
+you."
+ (interactive "P")
+ (let ((cur (current-buffer)))
+ (message-pop-to-buffer "*mail message*")
+ (insert-buffer-substring cur)
+ (goto-char (point-min))
+ (or (and (re-search-forward mail-unsent-separator nil t)
+ (forward-line 1))
+ (and (search-forward "\n\n" nil t)
+ (re-search-forward "^Return-Path:.*\n" nil t)))
+ ;; We remove everything before the bounced mail.
+ (delete-region
+ (point-min)
+ (if (re-search-forward "[^ \t]*:" nil t)
+ (match-beginning 0)
+ (point)))
+ (save-restriction
+ (message-narrow-to-head)
+ (message-remove-header message-ignored-bounced-headers t)
+ (goto-char (point-max))
+ (insert mail-header-separator))
+ (message-position-point)))
+
+(provide 'message)
+
+;;; message.el ends here
projects / gnus / commitdiff