(require 'mail-abbrevs))
(require 'mail-parse)
(require 'mml)
+(require 'rfc822)
(defgroup message '((user-mail-address custom-variable)
(user-full-name custom-variable))
'(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
:group 'message-insertion)
(defcustom message-yank-cited-prefix ">"
- "*Prefix inserted on cited lines of yanked messages.
+ "*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
(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,
+ ;; 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.
(concat
"From "
- ;; Many things can happen to an RFC 822 mailbox before it is put into
+ ;; Many things can happen to an RFC 822 mailbox before it is put into
;; a `From' line. The leading phrase can be stripped, e.g.
-;; `Joe <@w.x:joe@y.z>' -> `<@w.x:joe@y.z>'. The <> can be stripped, e.g.
-;; `<@x.y:joe@y.z>' -> `@x.y:joe@y.z'. Everything starting with a CRLF
+ ;; `Joe <@w.x:joe@y.z>' -> `<@w.x:joe@y.z>'. The <> can be stripped, e.g.
+ ;; `<@x.y:joe@y.z>' -> `@x.y:joe@y.z'. Everything starting with a CRLF
;; can be removed, e.g.
;; From: joe@y.z (Joe K
;; User)
- ;; can yield `From joe@y.z (Joe K Fri Mar 22 08:11:15 1996', and
+ ;; can yield `From joe@y.z (Joe K Fri Mar 22 08:11:15 1996', and
;; From: Joe User
;; <joe@y.z>
;; can yield `From Joe User Fri Mar 22 08:11:15 1996'.
;; From: "Joe User"{space}{tab}
;; <joe@y.z>
;; can yield `From {space}{tab} Fri Mar 22 08:11:15 1996',
-;; where {space} and {tab} represent the Ascii space and tab characters.
+ ;; where {space} and {tab} represent the Ascii space and tab characters.
;; We want to match the results of any of these manglings.
;; The following regexp rejects names whose first characters are
;; obviously bogus, but after that anything goes.
(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-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
(setq last t))
(delete-region
(point)
- ;; There might be a continuation header, so we have to search
+ ;; There might be a continuation header, so we have to search
;; until we find a new non-continuation line.
(progn
(forward-line 1)
(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)
["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
+ ["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"))]))
(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 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]+:")))
+ 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
(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
(goto-char start)
(while (< (point) (mark t))
- (if (looking-at message-cite-prefix-regexp)
+ (if (or (looking-at ">") (looking-at "^$"))
(insert message-yank-cited-prefix)
- (insert message-yank-prefix))
- (forward-line 1))))
+ (insert message-yank-prefix))
+ (forward-line 1))))
(goto-char start)))
(defun message-yank-original (&optional arg)
(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 (or message-send-mail-real-function
(apply
'call-process-region 1 (point-max) message-qmail-inject-program
nil nil nil
- ;; qmail-inject's default behaviour is to look for addresses on the
+ ;; qmail-inject's default behaviour is to look for addresses on the
;; command line; if there're none, it scans the headers.
- ;; yes, it does The Right Thing w.r.t. Resent-To and it's kin.
+ ;; yes, it does The Right Thing w.r.t. Resent-To and it's kin.
;;
- ;; in general, ALL of qmail-inject's defaults are perfect for simply
- ;; reading a formatted (i. e., at least a To: or Resent-To header)
+ ;; in general, ALL of qmail-inject's defaults are perfect for simply
+ ;; reading a formatted (i. e., at least a To: or Resent-To header)
;; message from stdin.
;;
;; qmail also has the advantage of not having been raped by
- ;; various vendors, so we don't have to allow for that, either --
+ ;; various vendors, so we don't have to allow for that, either --
;; compare this with message-send-mail-with-sendmail and weep
;; for sendmail's lost innocence.
;;
- ;; all this is way cool coz it lets us keep the arguments entirely
- ;; free for -inject-arguments -- a big win for the user and for us
- ;; since we don't have to play that double-guessing game and the user
- ;; gets full control (no gestapo'ish -f's, for instance). --sj
+ ;; all this is way cool coz it lets us keep the arguments entirely
+ ;; free for -inject-arguments -- a big win for the user and for us
+ ;; since we don't have to play that double-guessing game and the user
+ ;; gets full control (no gestapo'ish -f's, for instance). --sj
message-qmail-inject-args))
;; qmail-inject doesn't say anything on it's stdout/stderr,
;; we have to look at the retval instead
(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))
- (when group-name-charset
+ ;; 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
(if followup-to
(concat newsgroups "," followup-to)
newsgroups)))
+ (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-real-name n))
- (gnus-groups-from-server
- (cond ((equal gnus-post-method 'current)
- gnus-current-select-method)
- (gnus-post-method gnus-post-method)
- (t gnus-select-method)))))
+ (mapcar (lambda (n)
+ (gnus-group-name-decode
+ (gnus-group-real-name n)
+ (gnus-group-name-charset method n)))
+ (gnus-groups-from-server method)))
errors)
(while groups
(unless (or (equal (car groups) "poster")
(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
;; 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.
+ ;; 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)))))
(insert login))
((or (eq style 'angles)
(and (not (eq style 'parens))
- ;; Use angles if no quoting is needed, or if parens would
+ ;; Use angles if no quoting is needed, or if parens would
;; need quoting too.
(or (not (string-match "[^- !#-'*+/-9=?A-Z^-~]" fullname))
(let ((tmp (concat fullname nil)))
(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'.
(get-text-property (1+ (match-beginning 0)) 'message-deletable)
(message-delete-line))
(pop headers)))
- ;; Go through all the required headers and see if they are in the
+ ;; 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.
":")
nil t))
(progn
- ;; The header was found. We insert a space after the
+ ;; The header was found. We insert a space after the
;; colon, if there is none.
(if (/= (char-after) ? ) (insert " ") (forward-char 1))
;; Find out whether the header is empty...
;; 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.
+ ;; 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
;; If folding is disallowed, make sure the total length (including
;; the spaces between) will be less than MAXSIZE characters.
;;
- ;; Only disallow folding for News messages. At this point the headers
-;; have not been generated, thus we use message-this-is-news directly.
+ ;; Only disallow folding for News messages. At this point the headers
+ ;; have not been generated, thus we use message-this-is-news directly.
(when (and message-this-is-news message-cater-to-broken-inn)
(let ((maxsize 988)
(totalsize (+ (apply #'+ (mapcar #'length refs))
(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))
(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")
+ 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")))
(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
- wide
- (or (not (eq message-use-mail-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
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)))
- ;; Allow the user to be asked whether or not to reply to all
- ;; recipients in a wide reply.
- (if (and ccalist wide message-wide-reply-confirm-recipients
- (not (y-or-n-p "Reply to all recipients?")))
- (setq follow-to (delq (assoc 'Cc follow-to) 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."
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.
(let ((cur (current-buffer))
(sender (message-fetch-field "sender"))
(from (message-fetch-field "from")))
- ;; Check whether the user owns the article that is to be superseded.
+ ;; Check whether the user owns the article that is to be superseded.
(unless (or (message-gnksa-enable-p 'cancel-messages)
(and sender
(string-equal
the list of newsgroups is was posted to."
(concat "["
(let ((prefix
- (or (message-fetch-field
- (if (message-news-p) "newsgroups" "from"))
+ (or (message-fetch-field "newsgroups")
+ (message-fetch-field "from")
"(nowhere)")))
(if message-forward-decoded-p
prefix
(eval-when-compile
(defvar gnus-article-decoded-p))
+
;;;###autoload
(defun message-forward (&optional news digest)
"Forward the current message via mail.
(if (local-variable-p 'gnus-article-decoded-p (current-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&n