(eval-when-compile
(require 'cl)
- (defvar gnus-list-identifiers)) ; gnus-sum is required where necessary
+ (defvar gnus-list-identifiers)) ; gnus-sum is required where necessary
(require 'mailheader)
(require 'nnheader)
;; This is apparently necessary even though things are autoloaded:
(require 'mail-abbrevs))
(require 'mail-parse)
(require 'mml)
+(require 'rfc822)
(defgroup message '((user-mail-address custom-variable)
(user-full-name custom-variable))
`new-text', `quoting-style', `redirected-followup', `signature',
`approved', `sender', `empty', `empty-headers', `message-id', `from',
`subject', `shorten-followup-to', `existing-newsgroups',
-`buffer-file-name', `unchanged', `newsgroups'."
+`buffer-file-name', `unchanged', `newsgroups', `reply-to'."
:group 'message-news
:type '(repeat sexp)) ; Fixme: improve this
'(From Subject Date (optional . In-Reply-To) Message-ID Lines
(optional . User-Agent))
"*Headers to be generated or prompted for when mailing a message.
-RFC822 required that From, Date, To, Subject and Message-ID be
+It is recommended that From, Date, To, Subject and Message-ID be
included. Organization, Lines and User-Agent are optional."
:group 'message-mail
:group 'message-headers
:type 'regexp)
(defcustom message-cite-prefix-regexp
- ;; ?-, ?_ or ?. MUST NOT be in syntax entry w.
- "\\([ \t]*\\(\\w\\|[-_.]\\)+>+\\|[ \t]*[]>»|:}+]\\)+"
+ (if (string-match "[[:digit:]]" "1") ;; support POSIX?
+ "\\([ \t]*[-_.[:word:]]+>+\\|[ \t]*[]>»|:}+]\\)+"
+ ;; ?-, ?_ or ?. MUST NOT be in syntax entry w.
+ "\\([ \t]*\\(\\w\\|[-_.]\\)+>+\\|[ \t]*[]>»|:}+]\\)+")
"*Regexp matching the longest possible citation prefix on a line."
:group 'message-insertion
:type 'regexp)
query before using the \"poster\" value. If it is the symbol `ask',
always query the user whether to use the value. If it is the symbol
`use', always use the value."
+ :group 'message-interface
+ :type '(choice (const :tag "ignore" nil)
+ (const :tag "use & query" t)
+ (const use)
+ (const ask)))
+
+(defcustom message-use-mail-followup-to 'use
+ "*Specifies what to do with Mail-Followup-To header.
+If nil, always ignore the header. If it is the symbol `ask', always
+query the user whether to use the value. If it is the symbol `use',
+always use the value."
:group 'message-interface
:type '(choice (const :tag "ignore" nil)
(const use)
;;;###autoload
(defcustom message-citation-line-function 'message-insert-citation-line
- "*Function called to insert the \"Whomever writes:\" line."
+ "*Function called to insert the \"Whomever writes:\" line.
+
+Note that Gnus provides a feature where the reader can click on
+`writes:' to hide the cited text. If you change this line too much,
+people who read your message will have to change their Gnus
+configuration. See the variable `gnus-cite-attribution-suffix'."
:type 'function
:group 'message-insertion)
;;;###autoload
(defcustom message-yank-prefix "> "
"*Prefix inserted on the lines of yanked messages.
-Fix `message-cite-prefix-regexp' if it is set to an abnormal value."
+Fix `message-cite-prefix-regexp' if it is set to an abnormal value.
+See also `message-yank-cited-prefix'."
+ :type 'string
+ :group 'message-insertion)
+
+(defcustom message-yank-cited-prefix ">"
+ "*Prefix inserted on cited or empty lines of yanked messages.
+Fix `message-cite-prefix-regexp' if it is set to an abnormal value.
+See also `message-yank-prefix'."
:type 'string
:group 'message-insertion)
(defcustom message-dont-reply-to-names
(and (boundp 'rmail-dont-reply-to-names) rmail-dont-reply-to-names)
- "*A regexp specifying names to prune when doing wide replies.
-A value of nil means exclude your own name only."
+ "*A regexp specifying addresses to prune when doing wide replies.
+A value of nil means exclude your own user name only."
:version "21.1"
:group 'message
:type '(choice (const :tag "Yourself" nil)
table)
"Syntax table used while in Message mode.")
-(defvar message-mode-abbrev-table text-mode-abbrev-table
- "Abbrev table used in Message mode buffers.
-Defaults to `text-mode-abbrev-table'.")
-
(defface message-header-to-face
'((((class color)
(background dark))
:version "21.1"
:group 'message)
+(defcustom message-wide-reply-confirm-recipients nil
+ "Whether to confirm a wide reply to multiple email recipients.
+If this variable is nil, don't ask whether to reply to all recipients.
+If this variable is non-nil, pose the question \"Reply to all
+recipients?\" before a wide reply to multiple recipients. If the user
+answers yes, reply to all recipients as usual. If the user answers
+no, only reply back to the author."
+ :group 'message-headers
+ :type 'boolean)
+
;;; Internal variables.
(defvar message-sending-message "Sending...")
(defvar message-options nil
"Some saved answers when sending message.")
+(defvar message-send-mail-real-function nil
+ "Internal send mail function.")
+
+(defvar message-bogus-system-names "^localhost\\."
+ "The regexp of bogus system names.")
+
(eval-and-compile
(autoload 'message-setup-toolbar "messagexmas")
(autoload 'mh-new-draft-name "mh-comp")
(autoload 'gnus-open-server "gnus-int")
(autoload 'gnus-request-post "gnus-int")
(autoload 'gnus-alive-p "gnus-util")
+ (autoload 'gnus-server-string "gnus")
(autoload 'gnus-group-name-charset "gnus-group")
+ (autoload 'gnus-group-name-decode "gnus-group")
+ (autoload 'gnus-groups-from-server "gnus")
(autoload 'rmail-output "rmailout"))
\f
(defun message-unquote-tokens (elems)
"Remove double quotes (\") from strings in list ELEMS."
(mapcar (lambda (item)
- (while (string-match "^\\(.*\\)\"\\(.*\\)$" item)
- (setq item (concat (match-string 1 item)
- (match-string 2 item))))
- item)
- elems))
+ (while (string-match "^\\(.*\\)\"\\(.*\\)$" item)
+ (setq item (concat (match-string 1 item)
+ (match-string 2 item))))
+ item)
+ elems))
(defun message-tokenize-header (header &optional separator)
"Split HEADER into a list of header elements.
((and (eq (char-after) ?\))
(not quoted))
(setq paren nil))))
- (nreverse elems)))))
+ (nreverse elems)))))
(defun message-mail-file-mbox-p (file)
"Say whether FILE looks like a Unix mbox file."
gnus-list-identifiers
(mapconcat 'identity gnus-list-identifiers " *\\|"))))
(if (string-match (concat "\\(\\(\\(Re: +\\)?\\(" regexp
- " *\\)\\)+\\(Re: +\\)?\\)") subject)
+ " *\\)\\)+\\(Re: +\\)?\\)") subject)
(concat (substring subject 0 (match-beginning 1))
(or (match-string 3 subject)
(match-string 5 subject))
(define-key message-mode-map "\C-c\C-s" 'message-send)
(define-key message-mode-map "\C-c\C-k" 'message-kill-buffer)
(define-key message-mode-map "\C-c\C-d" 'message-dont-send)
+ (define-key message-mode-map "\C-c\n" 'gnus-delay-article)
(define-key message-mode-map "\C-c\C-e" 'message-elide-region)
(define-key message-mode-map "\C-c\C-v" 'message-delete-not-region)
(define-key message-mode-map "\M-;" 'comment-region))
(easy-menu-define
- message-mode-menu message-mode-map "Message Menu."
- `("Message"
- ["Sort Headers" message-sort-headers t]
- ["Yank Original" message-yank-original t]
- ["Fill Yanked Message" message-fill-yanked-message t]
- ["Insert Signature" message-insert-signature t]
- ["Caesar (rot13) Message" message-caesar-buffer-body t]
- ["Caesar (rot13) Region" message-caesar-region (mark t)]
- ["Elide Region" message-elide-region (mark t)]
- ["Delete Outside Region" message-delete-not-region (mark t)]
- ["Kill To Signature" message-kill-to-signature t]
- ["Newline and Reformat" message-newline-and-reformat t]
- ["Rename buffer" message-rename-buffer t]
- ["Spellcheck" ispell-message
- ,@(if (featurep 'xemacs) '(t)
- '(:help "Spellcheck this message"))]
- ["Attach file as MIME" mml-attach-file
- ,@(if (featurep 'xemacs) '(t)
- '(:help "Attach a file at point"))]
- "----"
- ["Send Message" message-send-and-exit
- ,@(if (featurep 'xemacs) '(t)
- '(:help "Send this message"))]
- ["Abort Message" message-dont-send
- ,@(if (featurep 'xemacs) '(t)
- '(:help "File this draft message and exit"))]
- ["Kill Message" message-kill-buffer
- ,@(if (featurep 'xemacs) '(t)
- '(:help "Delete this message without sending"))]))
+ message-mode-menu message-mode-map "Message Menu."
+ `("Message"
+ ["Sort Headers" message-sort-headers t]
+ ["Yank Original" message-yank-original t]
+ ["Fill Yanked Message" message-fill-yanked-message t]
+ ["Insert Signature" message-insert-signature t]
+ ["Caesar (rot13) Message" message-caesar-buffer-body t]
+ ["Caesar (rot13) Region" message-caesar-region (mark t)]
+ ["Elide Region" message-elide-region (mark t)]
+ ["Delete Outside Region" message-delete-not-region (mark t)]
+ ["Kill To Signature" message-kill-to-signature t]
+ ["Newline and Reformat" message-newline-and-reformat t]
+ ["Rename buffer" message-rename-buffer t]
+ ["Spellcheck" ispell-message
+ ,@(if (featurep 'xemacs) '(t)
+ '(:help "Spellcheck this message"))]
+ "----"
+ ["Send Message" message-send-and-exit
+ ,@(if (featurep 'xemacs) '(t)
+ '(:help "Send this message"))]
+ ["Postpone Message" message-dont-send
+ ,@(if (featurep 'xemacs) '(t)
+ '(:help "File this draft message and exit"))]
+ ["Send at Specific Time" gnus-delay-article
+ ,@(if (featurep 'xemacs) '(t)
+ '(:help "Ask, then arrange to send message at that time"))]
+ ["Kill Message" message-kill-buffer
+ ,@(if (featurep 'xemacs) '(t)
+ '(:help "Delete this message without sending"))]))
(easy-menu-define
- message-mode-field-menu message-mode-map ""
- '("Field"
- ["Fetch To" message-insert-to t]
- ["Fetch Newsgroups" message-insert-newsgroups t]
- "----"
- ["To" message-goto-to t]
- ["Subject" message-goto-subject t]
- ["Cc" message-goto-cc t]
- ["Reply-To" message-goto-reply-to t]
- ["Summary" message-goto-summary t]
- ["Keywords" message-goto-keywords t]
- ["Newsgroups" message-goto-newsgroups t]
- ["Followup-To" message-goto-followup-to t]
- ["Distribution" message-goto-distribution t]
- ["Body" message-goto-body t]
- ["Signature" message-goto-signature t]))
+ message-mode-field-menu message-mode-map ""
+ '("Field"
+ ["Fetch To" message-insert-to t]
+ ["Fetch Newsgroups" message-insert-newsgroups t]
+ "----"
+ ["To" message-goto-to t]
+ ["Subject" message-goto-subject t]
+ ["Cc" message-goto-cc t]
+ ["Reply-To" message-goto-reply-to t]
+ ["Summary" message-goto-summary t]
+ ["Keywords" message-goto-keywords t]
+ ["Newsgroups" message-goto-newsgroups t]
+ ["Followup-To" message-goto-followup-to t]
+ ["Distribution" message-goto-distribution t]
+ ["Body" message-goto-body t]
+ ["Signature" message-goto-signature t]))
(defvar message-tool-bar-map nil)
(defvar facemenu-remove-face-function))
;;;###autoload
-(defun message-mode ()
+(define-derived-mode message-mode text-mode "Message"
"Major mode for editing mail and news to be sent.
Like Text Mode but with these additional commands:\\<message-mode-map>
C-c C-s `message-send' (send the message) C-c C-c `message-send-and-exit'
C-c C-r `message-caesar-buffer-body' (rot13 the message body).
C-c C-a `mml-attach-file' (attach a file as MIME).
M-RET `message-newline-and-reformat' (break the line and reformat)."
- (interactive)
- (if (local-variable-p 'mml-buffer-list (current-buffer))
- (mml-destroy-buffers))
- (kill-all-local-variables)
(set (make-local-variable 'message-reply-buffer) nil)
(make-local-variable 'message-send-actions)
(make-local-variable 'message-exit-actions)
(make-local-variable 'message-kill-actions)
(make-local-variable 'message-postpone-actions)
(make-local-variable 'message-draft-article)
- (make-local-hook 'kill-buffer-hook)
- (set-syntax-table message-mode-syntax-table)
- (use-local-map message-mode-map)
- (setq local-abbrev-table message-mode-abbrev-table)
- (setq major-mode 'message-mode)
- (setq mode-name "Message")
(setq buffer-offer-save t)
- (make-local-variable 'facemenu-add-face-function)
- (make-local-variable 'facemenu-remove-face-function)
- (setq facemenu-add-face-function
- (lambda (face end)
- (let ((face-fun (cdr (assq face message-face-alist))))
- (if face-fun
- (funcall face-fun (point) end)
- (error "Face %s not configured for %s mode" face mode-name)))
- "")
- facemenu-remove-face-function t)
- (make-local-variable 'message-reply-headers)
- (setq message-reply-headers nil)
+ (set (make-local-variable 'facemenu-add-face-function)
+ (lambda (face end)
+ (let ((face-fun (cdr (assq face message-face-alist))))
+ (if face-fun
+ (funcall face-fun (point) end)
+ (error "Face %s not configured for %s mode" face mode-name)))
+ ""))
+ (set (make-local-variable 'facemenu-remove-face-function) t)
+ (set (make-local-variable 'message-reply-headers) nil)
(make-local-variable 'message-newsreader)
(make-local-variable 'message-mailer)
(make-local-variable 'message-post-method)
(mail-aliases-setup)))
(message-set-auto-save-file-name)
(mm-enable-multibyte)
- (make-local-variable 'indent-tabs-mode) ;Turn off tabs for indentation.
- (setq indent-tabs-mode nil)
- (mml-mode)
- (run-hooks 'text-mode-hook 'message-mode-hook))
+ (set (make-local-variable 'indent-tabs-mode) nil) ;No tabs for indentation.
+ (mml-mode))
(defun message-setup-fill-variables ()
"Setup message fill variables."
- (set (make-local-variable 'fill-paragraph-function)
+ (set (make-local-variable 'fill-paragraph-function)
'message-fill-paragraph)
(make-local-variable 'paragraph-separate)
(make-local-variable 'paragraph-start)
(unless (boundp 'adaptive-fill-first-line-regexp)
(setq adaptive-fill-first-line-regexp nil))
(make-local-variable 'adaptive-fill-first-line-regexp)
- (make-local-variable 'auto-fill-inhibit-regexp)
(let ((quote-prefix-regexp
;; User should change message-cite-prefix-regexp if
;; message-yank-prefix is set to an abnormal value.
- (concat "\\(" message-cite-prefix-regexp "\\)[ \t]*")))
+ (concat "\\(" message-cite-prefix-regexp "\\)[ \t]*")))
(setq paragraph-start
- (concat
- (regexp-quote mail-header-separator) "$\\|"
- "[ \t]*$\\|" ; blank lines
- "-- $\\|" ; signature delimiter
- "---+$\\|" ; delimiters for forwarded messages
- page-delimiter "$\\|" ; spoiler warnings
- ".*wrote:$\\|" ; attribution lines
- quote-prefix-regexp "$")) ; empty lines in quoted text
+ (concat
+ (regexp-quote mail-header-separator) "$\\|"
+ "[ \t]*$\\|" ; blank lines
+ "-- $\\|" ; signature delimiter
+ "---+$\\|" ; delimiters for forwarded messages
+ page-delimiter "$\\|" ; spoiler warnings
+ ".*wrote:$\\|" ; attribution lines
+ quote-prefix-regexp "$")) ; empty lines in quoted text
(setq paragraph-separate paragraph-start)
(setq adaptive-fill-regexp
- (concat quote-prefix-regexp "\\|" adaptive-fill-regexp))
+ (concat quote-prefix-regexp "\\|" adaptive-fill-regexp))
(setq adaptive-fill-first-line-regexp
- (concat quote-prefix-regexp "\\|"
- adaptive-fill-first-line-regexp))
- (setq auto-fill-inhibit-regexp "^[A-Z][^: \n\t]+:")))
+ (concat quote-prefix-regexp "\\|"
+ adaptive-fill-first-line-regexp)))
+ (make-local-variable 'auto-fill-inhibit-regexp)
+ ;;(setq auto-fill-inhibit-regexp "^[A-Z][^: \n\t]+:")
+ (setq auto-fill-inhibit-regexp nil)
+ (make-local-variable 'normal-auto-fill-function)
+ (setq normal-auto-fill-function 'message-do-auto-fill)
+ ;; KLUDGE: auto fill might already be turned on in `text-mode-hook'.
+ ;; In that case, ensure that it uses the right function. The real
+ ;; solution would be not to use `define-derived-mode', and run
+ ;; `text-mode-hook' ourself at the end of the mode.
+ ;; -- Per Abrahamsen <abraham@dina.kvl.dk> Date: 2001-10-19.
+ (when auto-fill-function
+ (setq auto-fill-function normal-auto-fill-function)))
\f
(expand-abbrev))
(goto-char (point-min))
(or (search-forward (concat "\n" mail-header-separator "\n") nil t)
- (search-forward "\n\n" nil t)))
+ (search-forward-regexp "[^:]+:\\([^\n]\\|\n[ \t]\\)+\n\n" nil t)))
(defun message-goto-eoh ()
"Move point to the end of the headers."
(defun message-delete-not-region (beg end)
"Delete everything in the body of the current message outside of the region."
(interactive "r")
- (save-excursion
- (goto-char end)
- (delete-region (point) (if (not (message-goto-signature))
- (point)
- (forward-line -2)
- (point)))
- (insert "\n")
- (goto-char beg)
- (delete-region beg (progn (message-goto-body)
- (forward-line 2)
- (point))))
+ (let (citeprefix)
+ (save-excursion
+ (goto-char beg)
+ ;; snarf citation prefix, if appropriate
+ (unless (eq (point) (progn (beginning-of-line) (point)))
+ (when (looking-at message-cite-prefix-regexp)
+ (setq citeprefix (match-string 0))))
+ (goto-char end)
+ (delete-region (point) (if (not (message-goto-signature))
+ (point)
+ (forward-line -2)
+ (point)))
+ (insert "\n")
+ (goto-char beg)
+ (delete-region beg (progn (message-goto-body)
+ (forward-line 2)
+ (point)))
+ (when citeprefix
+ (insert citeprefix))))
(when (message-goto-signature)
(forward-line -2)))
(if not-break
(while (and (not (eobp))
(not (looking-at message-cite-prefix-regexp))
- (looking-at paragraph-start))
+ (looking-at paragraph-start))
(forward-line 1)))
;; Find the prefix
(when (looking-at message-cite-prefix-regexp)
(insert quoted leading-space)))
(if quoted
(let* ((adaptive-fill-regexp
- (regexp-quote (concat quoted leading-space)))
+ (regexp-quote (concat quoted leading-space)))
(adaptive-fill-first-line-regexp
adaptive-fill-regexp ))
(fill-paragraph arg))
(defun message-fill-paragraph (&optional arg)
"Like `fill-paragraph'."
(interactive (list (if current-prefix-arg 'full)))
- (message-newline-and-reformat arg t)
- t)
+ (if (and (boundp 'filladapt-mode) filladapt-mode)
+ nil
+ (message-newline-and-reformat arg t)
+ t))
+
+(defun message-do-auto-fill ()
+ "Like `do-auto-fill', but don't fill in message header."
+ (when (> (point) (save-excursion
+ (goto-char (point-min))
+ (if (re-search-forward
+ (concat "^" (regexp-quote mail-header-separator)
+ "\n") nil t)
+ (match-beginning 0)
+ (point-max))))
+ (do-auto-fill)))
(defun message-insert-signature (&optional force)
"Insert a signature. See documentation for variable `message-signature'."
(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
+ (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)
(save-excursion
(save-restriction
(when (message-goto-body)
- (narrow-to-region (point) (point-max)))
+ (narrow-to-region (point) (point-max)))
(shell-command-on-region
(point-min) (point-max) program nil t))))
(save-excursion
(goto-char start)
(while (< (point) (mark t))
- (insert message-yank-prefix)
- (forward-line 1))))
+ (if (or (looking-at ">") (looking-at "^$"))
+ (insert message-yank-cited-prefix)
+ (insert message-yank-prefix))
+ (forward-line 1))))
(goto-char start)))
(defun message-yank-original (&optional arg)
(insert "\n"))
(funcall message-citation-line-function))))
-(eval-when-compile (defvar mail-citation-hook)) ;Compiler directive
+(eval-when-compile (defvar mail-citation-hook)) ;Compiler directive
(defun message-cite-original ()
"Cite function in the standard Message manner."
(if (and (boundp 'mail-citation-hook)
(format
"Already sent message via %s; resend? "
(car elem)))
- (error "Denied posting -- multiple copies.")))
+ (error "Denied posting -- multiple copies")))
(setq success (funcall (caddr elem) arg)))
(setq sent t))))
(unless (or sent (not success))
(pop actions)))
(defun message-send-mail-partially ()
- "Sendmail as message/partial."
+ "Send mail as message/partial."
;; replace the header delimiter with a blank line
(goto-char (point-min))
(re-search-forward
(insert "Mime-Version: 1.0\n")
(setq header (buffer-substring (point-min) (point-max))))
(goto-char (point-max))
- (insert (format "Content-Type: message/partial; id=\"%s\"; number=%d; total=%d\n"
+ (insert (format "Content-Type: message/partial; id=\"%s\"; number=%d; total=%d\n\n"
id n total))
+ (forward-char -1)
(let ((mail-header-separator ""))
(when (memq 'Message-ID message-required-mail-headers)
(insert "Message-ID: " (message-make-message-id) "\n"))
(when (memq 'Lines message-required-mail-headers)
- (let ((mail-header-separator ""))
- (insert "Lines: " (message-make-lines) "\n")))
+ (insert "Lines: " (message-make-lines) "\n"))
(message-goto-subject)
(end-of-line)
(insert (format " (%d/%d)" n total))
- (goto-char (point-max))
- (insert "\n")
(widen)
(mm-with-unibyte-current-buffer
- (funcall message-send-mail-function)))
+ (funcall (or message-send-mail-real-function
+ message-send-mail-function))))
(setq n (+ n 1))
(setq p (pop plist))
(erase-buffer)))
(message-insert-courtesy-copy))
(if (or (not message-send-mail-partially-limit)
(< (point-max) message-send-mail-partially-limit)
- (not (y-or-n-p "The message size is too large, should it be sent partially? ")))
+ (not (y-or-n-p "Message exceeds message-send-mail-partially-limit, send in parts? ")))
(mm-with-unibyte-current-buffer
- (funcall message-send-mail-function))
+ (message "Sending via mail...")
+ (funcall (or message-send-mail-real-function
+ message-send-mail-function)))
(message-send-mail-partially)))
(kill-buffer tembuf))
(set-buffer mailbuf)
;; qmail-inject doesn't say anything on it's stdout/stderr,
;; we have to look at the retval instead
(0 nil)
- (1 (error "qmail-inject reported permanent failure"))
+ (100 (error "qmail-inject reported permanent failure"))
(111 (error "qmail-inject reported transient failure"))
;; should never happen
(t (error "qmail-inject reported unknown failure"))))
(method (if (message-functionp message-post-method)
(funcall message-post-method arg)
message-post-method))
- (group-name-charset (gnus-group-name-charset method ""))
+ (newsgroups-field (save-restriction
+ (message-narrow-to-headers-or-head)
+ (message-fetch-field "Newsgroups")))
+ (followup-field (save-restriction
+ (message-narrow-to-headers-or-head)
+ (message-fetch-field "Followup-To")))
+ ;; BUG: We really need to get the charset for each name in the
+ ;; Newsgroups and Followup-To lines to allow crossposting
+ ;; between group namess with incompatible character sets.
+ ;; -- Per Abrahamsen <abraham@dina.kvl.dk> 2001-10-08.
+ (group-field-charset
+ (gnus-group-name-charset method newsgroups-field))
+ (followup-field-charset
+ (gnus-group-name-charset method (or followup-field "")))
(rfc2047-header-encoding-alist
- (if group-name-charset
- (cons (cons "Newsgroups" group-name-charset)
- rfc2047-header-encoding-alist)
- rfc2047-header-encoding-alist))
+ (append (when group-field-charset
+ (list (cons "Newsgroups" group-field-charset)))
+ (when followup-field-charset
+ (list (cons "Followup-To" followup-field-charset)))
+ rfc2047-header-encoding-alist))
(messbuf (current-buffer))
(message-syntax-checks
- (if arg
+ (if (and arg
+ (listp message-syntax-checks))
(cons '(existing-newsgroups . disabled)
message-syntax-checks)
message-syntax-checks))
(message-this-is-news t)
- (message-posting-charset (gnus-setup-posting-charset
- (save-restriction
- (message-narrow-to-headers-or-head)
- (message-fetch-field "Newsgroups"))))
+ (message-posting-charset
+ (gnus-setup-posting-charset newsgroups-field))
result)
(if (not (message-check-news-body-syntax))
nil
(message-generate-headers message-required-news-headers)
;; Let the user do all of the above.
(run-hooks 'message-header-hook))
- (if group-name-charset
- (setq message-syntax-checks
+ ;; Note: This check will be disabled by the ".*" default value for
+ ;; gnus-group-name-charset-group-alist. -- Pa 2001-10-07.
+ (when (and group-field-charset
+ (listp message-syntax-checks))
+ (setq message-syntax-checks
(cons '(valid-newsgroups . disabled)
message-syntax-checks)))
(message-cleanup-headers)
- (if (not (message-check-news-syntax))
+ (if (not (let ((message-post-method method))
+ (message-check-news-syntax)))
nil
(unwind-protect
(save-excursion
(backward-char 1))
(run-hooks 'message-send-news-hook)
(gnus-open-server method)
+ (message "Sending news with %s..." (gnus-server-string method))
(setq result (let ((mail-header-separator ""))
(gnus-request-post method))))
(kill-buffer tembuf))
(if followup-to
(concat newsgroups "," followup-to)
newsgroups)))
- (hashtb (and (boundp 'gnus-active-hashtb)
- gnus-active-hashtb))
+ (post-method (if (message-functionp message-post-method)
+ (funcall message-post-method)
+ message-post-method))
+ ;; KLUDGE to handle nnvirtual groups. Doing this right
+ ;; would probably involve a new nnoo function.
+ ;; -- Per Abrahamsen <abraham@dina.kvl.dk>, 2001-10-17.
+ (method (if (and (consp post-method)
+ (eq (car post-method) 'nnvirtual)
+ gnus-message-group-art)
+ (let ((group (car (nnvirtual-find-group-art
+ (car gnus-message-group-art)
+ (cdr gnus-message-group-art)))))
+ (gnus-find-method-for-group group))
+ post-method))
+ (known-groups
+ (mapcar (lambda (n)
+ (gnus-group-name-decode
+ (gnus-group-real-name n)
+ (gnus-group-name-charset method n)))
+ (gnus-groups-from-server method)))
errors)
- (if (or (not hashtb)
- (not (boundp 'gnus-read-active-file))
- (not gnus-read-active-file)
- (eq gnus-read-active-file 'some))
- t
- (while groups
- (when (and (not (boundp (intern (car groups) hashtb)))
- (not (equal (car groups) "poster")))
- (push (car groups) errors))
- (pop groups))
- (if (not errors)
- t
- (y-or-n-p
- (format
- "Really post to %s unknown group%s: %s? "
- (if (= (length errors) 1) "this" "these")
- (if (= (length errors) 1) "" "s")
- (mapconcat 'identity errors ", ")))))))
+ (while groups
+ (unless (or (equal (car groups) "poster")
+ (member (car groups) known-groups))
+ (push (car groups) errors))
+ (pop groups))
+ (cond
+ ;; Gnus is not running.
+ ((or (not (and (boundp 'gnus-active-hashtb)
+ gnus-active-hashtb))
+ (not (boundp 'gnus-read-active-file)))
+ t)
+ ;; We don't have all the group names.
+ ((and (or (not gnus-read-active-file)
+ (eq gnus-read-active-file 'some))
+ errors)
+ (y-or-n-p
+ (format
+ "Really post to %s possibly unknown group%s: %s? "
+ (if (= (length errors) 1) "this" "these")
+ (if (= (length errors) 1) "" "s")
+ (mapconcat 'identity errors ", "))))
+ ;; There were no errors.
+ ((not errors)
+ t)
+ ;; There are unknown groups.
+ (t
+ (y-or-n-p
+ (format
+ "Really post to %s unknown group%s: %s? "
+ (if (= (length errors) 1) "this" "these")
+ (if (= (length errors) 1) "" "s")
+ (mapconcat 'identity errors ", ")))))))
;; Check the Newsgroups & Followup-To headers for syntax errors.
(message-check 'valid-newsgroups
(let ((case-fold-search t)
"@[^\\.]*\\."
(setq ad (nth 1 (mail-extract-address-components
from))))) ;larsi@ifi
- (string-match "\\.\\." ad) ;larsi@ifi..uio
+ (string-match "\\.\\." ad) ;larsi@ifi..uio
(string-match "@\\." ad) ;larsi@.ifi.uio
(string-match "\\.$" ad) ;larsi@ifi.uio.
(not (string-match "^[^@]+@[^@]+$" ad)) ;larsi.ifi.uio
(message
"Denied posting -- the From looks strange: \"%s\"." from)
nil)
+ ((let ((addresses (rfc822-addresses from)))
+ (while (and addresses
+ (not (eq (string-to-char (car addresses)) ?\()))
+ (setq addresses (cdr addresses)))
+ addresses)
+ (message
+ "Denied posting -- bad From address: \"%s\"." from)
+ nil)
+ (t t))))
+ ;; Check the Reply-To header.
+ (message-check 'reply-to
+ (let* ((case-fold-search t)
+ (reply-to (message-fetch-field "reply-to"))
+ ad)
+ (cond
+ ((not reply-to)
+ t)
+ ((string-match "," reply-to)
+ (y-or-n-p
+ (format "Multiple Reply-To addresses: \"%s\". Really post? "
+ reply-to)))
+ ((or (not (string-match
+ "@[^\\.]*\\."
+ (setq ad (nth 1 (mail-extract-address-components
+ reply-to))))) ;larsi@ifi
+ (string-match "\\.\\." ad) ;larsi@ifi..uio
+ (string-match "@\\." ad) ;larsi@.ifi.uio
+ (string-match "\\.$" ad) ;larsi@ifi.uio.
+ (not (string-match "^[^@]+@[^@]+$" ad)) ;larsi.ifi.uio
+ (string-match "(.*).*(.*)" reply-to)) ;(lars) (lars)
+ (y-or-n-p
+ (format
+ "The Reply-To looks strange: \"%s\". Really post? "
+ reply-to)))
(t t))))))
(defun message-check-news-body-syntax ()
(concat "^" (regexp-quote mail-header-separator) "$"))
(forward-line 1)
(while (and
- (or (looking-at
+ (or (looking-at
"<#\\(/\\)?\\(multipart\\|part\\|external\\|mml\\)")
(let ((p (point)))
(end-of-line)
(concat "^" (regexp-quote mail-header-separator) "$"))
(while (not (eobp))
(when (not (looking-at "[ \t\n]"))
- (setq sum (logxor (ash sum 1) (if (natnump sum) 0 1)
- (char-after))))
+ (setq sum (logxor (ash sum 1) (if (natnump sum) 0 1)
+ (char-after))))
(forward-char 1)))
sum))
(buf (current-buffer))
list file)
(save-excursion
- (set-buffer (get-buffer-create " *message temp*"))
- (erase-buffer)
- (insert-buffer-substring buf)
(save-restriction
(message-narrow-to-headers)
- (while (setq file (message-fetch-field "fcc"))
- (push file list)
- (message-remove-header "fcc" nil t)))
- (message-encode-message-body)
- (save-restriction
- (message-narrow-to-headers)
- (let ((mail-parse-charset message-default-charset)
- (rfc2047-header-encoding-alist
- (cons '("Newsgroups" . default)
- rfc2047-header-encoding-alist)))
- (mail-encode-encoded-word-buffer)))
- (goto-char (point-min))
- (when (re-search-forward
- (concat "^" (regexp-quote mail-header-separator) "$")
- nil t)
- (replace-match "" t t ))
- ;; Process FCC operations.
- (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 shell-command-switch
- (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 nil t)
- (let ((mail-use-rfc822 t))
- (rmail-output file 1 t t))))))
- (kill-buffer (current-buffer)))))
+ (setq file (message-fetch-field "fcc" t)))
+ (when file
+ (set-buffer (get-buffer-create " *message temp*"))
+ (erase-buffer)
+ (insert-buffer-substring buf)
+ (message-encode-message-body)
+ (save-restriction
+ (message-narrow-to-headers)
+ (while (setq file (message-fetch-field "fcc" t))
+ (push file list)
+ (message-remove-header "fcc" nil t))
+ (let ((mail-parse-charset message-default-charset)
+ (rfc2047-header-encoding-alist
+ (cons '("Newsgroups" . default)
+ rfc2047-header-encoding-alist)))
+ (mail-encode-encoded-word-buffer)))
+ (goto-char (point-min))
+ (when (re-search-forward
+ (concat "^" (regexp-quote mail-header-separator) "$")
+ nil t)
+ (replace-match "" t t ))
+ ;; Process FCC operations.
+ (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 shell-command-switch
+ (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 nil t)
+ (let ((mail-use-rfc822 t))
+ (rmail-output file 1 t t))))))
+ (kill-buffer (current-buffer))))))
(defun message-output (filename)
"Append this article to Unix/babyl mail file FILENAME."
(point)))
(goto-char (point-min))
(while (re-search-forward "\n[ \t]+" nil t)
- (replace-match " " t t)) ;No line breaks (too confusing)
+ (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))
(setq sign "-")
(setq zone (- zone)))
(concat
+ ;; The day name of the %a spec is locale-specific. Pfff.
+ (format "%s, " (capitalize (car (rassoc (nth 6 (decode-time now))
+ parse-time-weekdays))))
(format-time-string "%d" now)
;; The month name of the %b spec is locale-specific. Pfff.
(format " %s "
(let ((system-name (system-name))
(user-mail (message-user-mail-address)))
(cond
- ((string-match "[^.]\\.[^.]" system-name)
+ ((and (string-match "[^.]\\.[^.]" system-name)
+ (not (string-match message-bogus-system-names system-name)))
;; `system-name' returned the right result.
system-name)
;; Try `mail-host-address'.
(nthcdr (+ (- cut 2) surplus 1) list)))
(defun message-shorten-references (header references)
- "Trim REFERENCES to be less than 31 Message-ID long, and fold them.
+ "Trim REFERENCES to be 21 Message-ID long or less, and fold them.
If folding is disallowed, also check that the REFERENCES are less
than 988 characters long, and if they are not, trim them until they are."
- (let ((maxcount 31)
+ (let ((maxcount 21)
(count 0)
- (cut 6)
+ (cut 2)
refs)
(with-temp-buffer
(insert references)
;; list of buffers.
(setq message-buffer-list (delq (current-buffer) message-buffer-list))
(while (and message-max-buffers
- message-buffer-list
+ message-buffer-list
(>= (length message-buffer-list) message-max-buffers))
;; Kill the oldest buffer -- unless it has been changed.
(let ((buffer (pop message-buffer-list)))
;; Rename the buffer.
(if message-send-rename-function
(funcall message-send-rename-function)
- (when (string-match "\\`\\*\\(sent \\|unsent \\)?\\(.+\\)\\*[^\\*]*"
- (buffer-name))
+ ;; Note: mail-abbrevs of XEmacs renames buffer name behind Gnus.
+ (when (string-match
+ "\\`\\*\\(sent \\|unsent \\)?\\(.+\\)\\*[^\\*]*\\|\\`mail to "
+ (buffer-name))
(let ((name (match-string 2 (buffer-name)))
to group)
- (if (not (or (string-equal name "mail")
+ (if (not (or (null name)
+ (string-equal name "mail")
(string-equal name "news")))
(setq name (concat "*sent " name "*"))
+ (message-narrow-to-headers)
(setq to (message-fetch-field "to"))
(setq group (message-fetch-field "newsgroups"))
+ (widen)
(setq name
- (cond
+ (cond
(to (concat "*sent mail to "
(or (car (mail-extract-address-components to))
to) "*"))
(setq message-draft-article
(nndraft-request-associate-buffer "drafts"))
(setq buffer-file-name (expand-file-name
- (if (eq system-type 'windows-nt)
+ (if (memq system-type
+ '(ms-dos ms-windows windows-nt
+ cygwin32 win32 w32
+ mswindows))
"message"
"*message*")
message-auto-save-directory))
(nconc
`((To . ,(or to "")) (Subject . ,(or subject "")))
(when other-headers other-headers))
- replybuffer)
+ replybuffer send-actions)
;; FIXME: Should return nil if failure.
t))
(Subject . ,(or subject ""))))))
(defun message-get-reply-headers (wide &optional to-address)
- (let (follow-to mct never-mct from to cc reply-to mrt mft ccalist)
+ (let (follow-to mct never-mct to cc author mft recipients)
;; Find all relevant headers we need.
- (setq from (message-fetch-field "from")
- to (message-fetch-field "to")
+ (setq to (message-fetch-field "to")
cc (message-fetch-field "cc")
mct (message-fetch-field "mail-copies-to")
- reply-to (message-fetch-field "reply-to")
- mrt (message-fetch-field "mail-reply-to")
- mft (and message-use-followup-to
- (message-fetch-field "mail-followup-to")))
+ author (or (message-fetch-field "mail-reply-to")
+ (message-fetch-field "reply-to")
+ (message-fetch-field "from")
+ "")
+ mft (and message-use-mail-followup-to
+ (message-fetch-field "mail-followup-to")))
;; Handle special values of Mail-Copies-To.
(when mct
(setq mct nil))
((or (equal (downcase mct) "always")
(equal (downcase mct) "poster"))
- (setq mct (or mrt reply-to from)))))
+ (setq mct author))))
- (if (and (not mft)
- (or (not wide)
- to-address))
- (progn
- (setq follow-to (list (cons 'To (or to-address mrt reply-to from))))
- (when (and (and wide mct)
- (not (member (cons 'To mct) follow-to)))
- (push (cons 'Cc mct) follow-to)))
- (let (ccalist)
- (save-excursion
- (message-set-work-buffer)
- (if (and mft
- message-use-followup-to
- (or (not (eq message-use-followup-to 'ask))
- (message-y-or-n-p
- (concat "Obey Mail-Followup-To? ") t "\
+ (save-match-data
+ ;; Build (textual) list of new recipient addresses.
+ (cond
+ ((not wide)
+ (setq recipients (concat ", " author)))
+ ((and mft
+ (string-match "[^ \t,]" mft)
+ (or (not (eq message-use-mail-followup-to 'ask))
+ (message-y-or-n-p "Obey Mail-Followup-To? " t "\
You should normally obey the Mail-Followup-To: header. In this
article, it has the value of
" mft "
which directs your response to " (if (string-match "," mft)
- "the specified addresses"
- "that address only") ".
+ "the specified addresses"
+ "that address only") ".
+
+Most commonly, Mail-Followup-To is used by a mailing list poster to
+express that responses should be sent to just the list, and not the
+poster as well.
-If a message is posted to several mailing lists, Mail-Followup-To is
-often used to direct the following discussion to one list only,
+If a message is posted to several mailing lists, Mail-Followup-To may
+also be used to direct the following discussion to one list only,
because discussions that are spread over several lists tend to be
fragmented and very difficult to follow.
-Also, some source/announcement lists are not indented for discussion;
+Also, some source/announcement lists are not intended for discussion;
responses here are directed to other addresses.")))
- (insert mft)
- (unless never-mct
- (insert (or mrt reply-to from "")))
- (insert (if to (concat (if (bolp) "" ", ") to "") ""))
- (insert (if mct (concat (if (bolp) "" ", ") mct) ""))
- (insert (if cc (concat (if (bolp) "" ", ") cc) "")))
- (goto-char (point-min))
- (while (re-search-forward "[ \t]+" nil t)
- (replace-match " " t t))
- ;; Remove addresses that match `rmail-dont-reply-to-names'.
- (let ((rmail-dont-reply-to-names message-dont-reply-to-names))
- (insert (prog1 (rmail-dont-reply-to (buffer-string))
- (erase-buffer))))
- (goto-char (point-min))
- ;; Perhaps "Mail-Copies-To: never" removed the only address?
- (when (eobp)
- (insert (or mrt reply-to from "")))
- (setq ccalist
- (mapcar
- (lambda (addr)
- (cons (mail-strip-quoted-names addr) addr))
- (message-tokenize-header (buffer-string))))
- (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
- (let ((ccs (cons 'Cc (mapconcat
- (lambda (addr) (cdr addr)) ccalist ", "))))
- (when (string-match "^ +" (cdr ccs))
- (setcdr ccs (substring (cdr ccs) (match-end 0))))
- (push ccs follow-to)))))
+ (setq recipients (concat ", " mft)))
+ (to-address
+ (setq recipients (concat ", " to-address))
+ ;; If the author explicitly asked for a copy, we don't deny it to them.
+ (if mct (setq recipients (concat recipients ", " mct))))
+ (t
+ (setq recipients (if never-mct "" (concat ", " author)))
+ (if to (setq recipients (concat recipients ", " to)))
+ (if cc (setq recipients (concat recipients ", " cc)))
+ (if mct (setq recipients (concat recipients ", " mct)))))
+ ;; Strip the leading ", ".
+ (setq recipients (substring recipients 2))
+ ;; Squeeze whitespace.
+ (while (string-match "[ \t][ \t]+" recipients)
+ (setq recipients (replace-match " " t t recipients)))
+ ;; Remove addresses that match `rmail-dont-reply-to-names'.
+ (let ((rmail-dont-reply-to-names message-dont-reply-to-names))
+ (setq recipients (rmail-dont-reply-to recipients)))
+ ;; Perhaps "Mail-Copies-To: never" removed the only address?
+ (if (string-equal recipients "")
+ (setq recipients author))
+ ;; Convert string to a list of (("foo@bar" . "Name <foo@bar>") ...).
+ (setq recipients
+ (mapcar
+ (lambda (addr)
+ (cons (mail-strip-quoted-names addr) addr))
+ (message-tokenize-header recipients)))
+ ;; Remove first duplicates. (Why not all duplicates? Is this a bug?)
+ (let ((s recipients))
+ (while s
+ (setq recipients (delq (assoc (car (pop s)) s) recipients))))
+ ;; Build the header alist. Allow the user to be asked whether
+ ;; or not to reply to all recipients in a wide reply.
+ (setq follow-to (list (cons 'To (cdr (pop recipients)))))
+ (when (and recipients
+ (or (not message-wide-reply-confirm-recipients)
+ (y-or-n-p "Reply to all recipients? ")))
+ (setq recipients (mapconcat
+ (lambda (addr) (cdr addr)) recipients ", "))
+ (if (string-match "^ +" recipients)
+ (setq recipients (substring recipients (match-end 0))))
+ (push (cons 'Cc recipients) follow-to)))
follow-to))
-
;;;###autoload
(defun message-reply (&optional to-address wide)
"Start editing a reply to the article in the current buffer."
date (message-fetch-field "date")
from (message-fetch-field "from")
subject (or (message-fetch-field "subject") "none"))
- (when gnus-list-identifiers
- (setq subject (message-strip-list-identifiers subject)))
- (setq subject (concat "Re: " (message-strip-subject-re subject)))
+ (when gnus-list-identifiers
+ (setq subject (message-strip-list-identifiers subject)))
+ (setq subject (concat "Re: " (message-strip-subject-re subject)))
- (when (and (setq gnus-warning (message-fetch-field "gnus-warning"))
- (string-match "<[^>]+>" gnus-warning))
- (setq message-id (match-string 0 gnus-warning)))
+ (when (and (setq gnus-warning (message-fetch-field "gnus-warning"))
+ (string-match "<[^>]+>" gnus-warning))
+ (setq message-id (match-string 0 gnus-warning)))
- (unless follow-to
- (setq follow-to (message-get-reply-headers wide to-address))))
+ (unless follow-to
+ (setq follow-to (message-get-reply-headers wide to-address))))
(unless (message-mail-user-agent)
(message-pop-to-buffer
because discussions that are spread over several newsgroup tend to
be fragmented and very difficult to follow.
-Also, some source/announcement newsgroups are not indented for discussion;
+Also, some source/announcement newsgroups are not intended for discussion;
responses here are directed to other newsgroups."))
(cons 'Newsgroups followup-to)
(cons 'Newsgroups newsgroups))))))
message-id (message-fetch-field "message-id" t)
distribution (message-fetch-field "distribution")))
;; Make sure that this article was written by the user.
- (unless (or (message-gnksa-enable-p 'cancel-messages)
- (and sender
- (string-equal
- (downcase sender)
- (downcase (message-make-sender))))
- (string-equal
- (downcase (cadr (mail-extract-address-components from)))
- (downcase (cadr (mail-extract-address-components
- (message-make-from))))))
+ (unless (or
+ ;; Canlock-logic as suggested by Per Abrahamsen
+ ;; <abraham@dina.kvl.dk>
+ ;;
+ ;; IF article has cancel-lock THEN
+ ;; IF we can load canlock THEN
+ ;; IF we can verify it THEN
+ ;; issue cancel
+ ;; ELSE
+ ;; error: cancellock: article is not yours
+ ;; ELSE
+ ;; error: message is cancel locked
+ ;; ELSE
+ ;; Use old rules, comparing sender...
+ (if (message-fetch-field "Cancel-Lock")
+ (if (ignore-errors (require 'canlock))
+ (if (null (canlock-verify))
+ t
+ (error "Failed to verify Cancel-lock: This article is not yours"))
+ (error "This article is cancel locked, the `canlock.el' library is required."))
+ nil)
+ (message-gnksa-enable-p 'cancel-messages)
+ (and sender
+ (string-equal
+ (downcase sender)
+ (downcase (message-make-sender))))
+ (string-equal
+ (downcase (cadr (mail-extract-address-components from)))
+ (downcase (cadr (mail-extract-address-components
+ (message-make-from))))))
(error "This article is not yours"))
(when (yes-or-no-p "Do you really want to cancel this article? ")
;; Make control message.
Source is the sender, and if the original message was news, Source is
the list of newsgroups is was posted to."
(concat "["
- (let ((prefix
- (or (message-fetch-field
- (if (message-news-p) "newsgroups" "from"))
- "(nowhere)")))
- (if message-forward-decoded-p
- prefix
- (mail-decode-encoded-word-string prefix)))
+ (let ((prefix
+ (or (message-fetch-field "newsgroups")
+ (message-fetch-field "from")
+ "(nowhere)")))
+ (if message-forward-decoded-p
+ prefix
+ (mail-decode-encoded-word-string prefix)))
"] " subject))
(defun message-forward-subject-fwd (subject)
(eval-when-compile
(defvar gnus-article-decoded-p))
+
;;;###autoload
(defun message-forward (&optional news digest)
"Forward the current message via mail.
Optional DIGEST will use digest to forward."
(interactive "P")
(let* ((cur (current-buffer))
- (message-forward-decoded-p
+ (message-forward-decoded-p
(if (local-variable-p 'gnus-article-decoded-p (current-buffer))
- gnus-article-decoded-p ;; In an article buffer.
+ gnus-article-decoded-p ;; In an article buffer.
message-forward-decoded-p))
- (subject (message-make-forward-subject))
- art-beg)
+ (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-forward-before-signature
- (message-goto-body)
- (goto-char (point-max)))
- (if message-forward-as-mime
- (if digest
- (insert "\n<#multipart type=digest>\n")
- (if message-forward-show-mml
- (insert "\n\n<#mml type=message/rfc822 disposition=inline>\n")
- (insert "\n\n<#part type=message/rfc822 disposition=inline raw=t>\n")))
- (insert "\n-------------------- Start of forwarded message --------------------\n"))
- (let ((b (point)) e)
+ (message-forward-make-body cur digest)))
+
+;;;###autoload
+(defun message-forward-make-body (forward-buffer &optional digest)
+ ;; Put point where we want it before inserting the forwarded
+ ;; message.
+ (if message-forward-before-signature
+ (message-goto-body)
+ (goto-char (point-max)))
+ (if message-forward-as-mime
(if digest
- (if message-forward-as-mime
- (insert-buffer-substring cur)
- (mml-insert-buffer cur))
- (if (and message-forward-show-mml
- (not message-forward-decoded-p))
- (insert
- (with-temp-buffer
- (mm-disable-multibyte-mule4) ;; Must copy buffer in unibyte mode
+ (insert "\n<#multipart type=digest>\n")
+ (if message-forward-show-mml
+ (insert "\n\n<#mml type=message/rfc822 disposition=inline>\n")
+ (insert "\n\n<#part type=message/rfc822 disposition=inline raw=t>\n")))
+ (insert "\n-------------------- Start of forwarded message --------------------\n"))
+ (let ((b (point)) e)
+ (if digest
+ (if message-forward-as-mime
+ (insert-buffer-substring forward-buffer)
+ (mml-insert-buffer forward-buffer))
+ (if (and message-forward-show-mml
+ (not message-forward-decoded-p))
+ (insert
+ (with-temp-buffer
+ (mm-disable-multibyte-mule4) ;; Must copy buffer in unibyte mode
(insert
- (with-current-buffer cur
+ (with-current-buffer forward-buffer
(mm-string-as-unibyte (buffer-string))))
(mm-enable-multibyte-mule4)
(mime-to-mml)
(when (looking-at "From ")
(replace-match "X-From-Line: "))
(buffer-string)))
- (save-restriction
- (narrow-to-region (point) (point))
- (mml-insert-buffer cur)
- (goto-char (point-min))
- (when (looking-at "From ")
- (replace-match "X-From-Line: "))
- (goto-char (point-max)))))
- (setq e (point))
- (if message-forward-as-mime
- (if digest
- (insert "<#/multipart>\n")
- (if message-forward-show-mml
- (insert "<#/mml>\n")
- (insert "<#/part>\n")))
- (insert "\n-------------------- End of forwarded message --------------------\n"))
- (if (and digest message-forward-as-mime)
- (save-restriction
- (narrow-to-region b e)
- (goto-char b)
- (narrow-to-region (point)
- (or (search-forward "\n\n" nil t) (point)))
- (delete-region (point-min) (point-max)))
- (when (and (not current-prefix-arg)
- message-forward-ignored-headers)
- (save-restriction
- (narrow-to-region b e)
- (goto-char b)
- (narrow-to-region (point)
- (or (search-forward "\n\n" nil t) (point)))
- (message-remove-header message-forward-ignored-headers t)))))
- (message-position-point)))
+ (save-restriction
+ (narrow-to-region (point) (point))
+ (mml-insert-buffer forward-buffer)
+ (goto-char (point-min))
+ (when (looking-at "From ")
+ (replace-match "X-From-Line: "))
+ (goto-char (point-max)))))
+ (setq e (point))
+ (if message-forward-as-mime
+ (if digest
+ (insert "<#/multipart>\n")
+ (if message-forward-show-mml
+ (insert "<#/mml>\n")
+ (insert "<#/part>\n")))
+ (insert "\n-------------------- End of forwarded message --------------------\n"))
+ (if (and digest message-forward-as-mime)
+ (save-restriction
+ (narrow-to-region b e)
+ (goto-char b)
+ (narrow-to-region (point)
+ (or (search-forward "\n\n" nil t) (point)))
+ (delete-region (point-min) (point-max)))
+ (when (and (not current-prefix-arg)
+ message-forward-ignored-headers)
+ (save-restriction
+ (narrow-to-region b e)
+ (goto-char b)
+ (narrow-to-region (point)
+ (or (search-forward "\n\n" nil t) (point)))
+ (message-remove-header message-forward-ignored-headers t)))))
+ (message-position-point))
+
+;;;###autoload
+(defun message-forward-rmail-make-body (forward-buffer)
+ (with-current-buffer forward-buffer
+ (rmail-toggle-header 0))
+ (message-forward-make-body forward-buffer))
+
+;;;###autoload
+(defun message-insinuate-rmail ()
+ "Let RMAIL uses message to forward."
+ (interactive)
+ (setq rmail-enable-mime-composing t)
+ (setq rmail-insert-mime-forwarded-message-function
+ 'message-forward-rmail-make-body))
;;;###autoload
(defun message-resend (address)
(undo-boundary)
(goto-char (point-min))
(search-forward "\n\n" nil t)
- (or (and (re-search-forward message-unsent-separator nil t)
- (forward-line 1))
- (re-search-forward "^Return-Path:.*\n" nil t))
- ;; We remove everything before the bounced mail.
- (delete-region
- (point-min)
- (if (re-search-forward "^[^ \n\t]+:" nil t)
- (match-beginning 0)
- (point))))
+ (if (or (and (re-search-forward message-unsent-separator nil t)
+ (forward-line 1))
+ (re-search-forward "^Return-Path:.*\n" nil t))
+ ;; We remove everything before the bounced mail.
+ (delete-region
+ (point-min)
+ (if (re-search-forward "^[^ \n\t]+:" nil t)
+ (match-beginning 0)
+ (point)))
+ (when (re-search-backward "^.?From .*\n" nil t)
+ (delete-region (match-beginning 0) (match-end 0)))))
(mm-enable-multibyte)
(mime-to-mml)
(save-restriction
"^\\(Newsgroups\\|Followup-To\\|Posted-To\\|Gcc\\):"
"Regexp that match headers that lists groups.")
+(defvar message-completion-alist
+ (list (cons message-newgroups-header-regexp 'message-expand-group)
+ '("^\\(Resent-\\)?\\(To\\|B?Cc\\):" . message-expand-name))
+ "Alist of (RE . FUN). Use FUN for completion on header lines matching RE.")
+
+(defvar message-tab-body-function 'indent-relative
+ "*Function to execute when `message-tab' (TAB) is executed in the body.")
+
(defun message-tab ()
- "Expand group names in Newsgroups and Followup-To headers.
-Do a `tab-to-tab-stop' if not in those headers."
+ "Complete names according to `message-completion-alist'.
+Do an `indent-relative' if not in those headers."
(interactive)
- (if (let ((mail-abbrev-mode-regexp message-newgroups-header-regexp))
- (mail-abbrev-in-expansion-header-p))
- (message-expand-group)
- (tab-to-tab-stop)))
+ (let ((alist message-completion-alist))
+ (while (and alist
+ (let ((mail-abbrev-mode-regexp (caar alist)))
+ (not (mail-abbrev-in-expansion-header-p))))
+ (setq alist (cdr alist)))
+ (funcall (or (cdar alist) message-tab-body-function))))
(defun message-expand-group ()
"Expand the group name under point."
(goto-char (point-min))
(delete-region (point) (progn (forward-line 3) (point))))))))))
+(defun message-expand-name ()
+ (if (fboundp 'bbdb-complete-name)
+ (bbdb-complete-name)
+ (expand-abbrev)))
+
;;; Help stuff.
(defun message-talkative-question (ask question show &rest text)
(mail-strip-quoted-names
(message-fetch-field "from")))
(message-options-set 'message-recipients
- (mail-strip-quoted-names
- (message-fetch-field "to")))))
+ (mail-strip-quoted-names
+ (let ((to (message-fetch-field "to"))
+ (cc (message-fetch-field "cc"))
+ (bcc (message-fetch-field "bcc")))
+ (concat
+ (or to "")
+ (if (and to cc) ", ")
+ (or cc "")
+ (if (and (or to cc) bcc) ", ")
+ (or bcc "")))))))
(when (featurep 'xemacs)
(require 'messagexmas)
projects / gnus / blobdiff