(require 'mail-parse)
(require 'mml))
+(require 'rfc822)
+
(defgroup message '((user-mail-address custom-variable)
(user-full-name custom-variable))
"Mail and news message composing."
'(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
is the symbol `guess', try to detect \"Re: \" within an encoded-word."
:group 'message-various
:type '(choice (const :tag "off" nil)
- (const :tag "on" t)
- (const guess)))
+ (const :tag "on" t)
+ (const guess)))
;;;###autoload
(defcustom message-signature-separator "^-- *$"
:type 'regexp
:group 'message-various)
+(defcustom message-signature-separator-for-insertion "-- \n"
+ "*Signature separator. This value will be inserted as signature separator
+when composing message. Default value is \"-- \\n\". Notice: Changing this
+value may go against RFC-1036 and draft-ietf-usefor-article-05.txt. "
+ :type 'string
+ :group 'message-insertion)
+
(defcustom message-elide-ellipsis "\n[...]\n\n"
"*The string which is inserted for elided text."
:type 'string
:group 'message-interface
:type '(choice function (const nil)))
-(defcustom message-use-followup-to t
+(defcustom message-use-followup-to 'ask
"*Specifies what to do with Followup-To header.
If nil, always ignore the header. If it is t, use its value, but
query before using the \"poster\" value. If it is the symbol `ask',
(const :tag "always" use)
(const :tag "ask" ask)))
-(defcustom message-use-mail-followup-to 'ask
- "*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 t or the symbol
-`use', always use the value."
- :group 'message-interface
- :type '(choice (const :tag "ignore" nil)
- (const :tag "maybe" t)
- (const :tag "always" use)
- (const :tag "ask" ask)))
-
;;; XXX: 'ask and 'use are not implemented yet.
(defcustom message-use-mail-reply-to 'ask
"*Specifies what to do with Mail-Reply-To/Reply-To header.
(const :tag "always" use)
(const :tag "ask" 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 t or the symbol
+`use', always use the value."
+ :group 'message-interface
+ :type '(choice (const :tag "ignore" nil)
+ (const :tag "maybe" t)
+ (const :tag "always" use)
+ (const :tag "ask" ask)))
+
(defcustom message-sendmail-f-is-evil nil
"*Non-nil means don't add \"-f username\" to the sendmail command line.
Doing so would be even more evil than leaving it out."
;;;###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)
: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
:group 'message-insertion)
;;;###autoload
+(defcustom message-suspend-font-lock-when-citing nil
+ "Non-nil means suspend font-lock'ing while citing an original message.
+Some lazy demand-driven fontification tools (or Emacs itself) have a
+bug that they often miss a buffer to be fontified. It will mostly
+occur when Emacs prompts user for any inputs in the minibuffer.
+Setting this option to non-nil may help you to avoid unpleasant errors
+even if it is an add-hoc expedient."
+ :type 'boolean
+ :group 'message-insertion)
+
+;;;###autoload
(defcustom 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
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))
"Face used for displaying MML."
:group 'message-faces)
-(defvar message-font-lock-fence-open-regexp "[+|]"
- "*Regexp that matches fence open string.")
-
-(defvar message-font-lock-fence-close-regexp "|"
- "*Regexp that matches fence close string.")
-
-(defvar message-font-lock-fence-open-position nil
- "*Cons of SYMBOL of a function or a variable and a number of OFFSET that
-indicate the fence open position. If it is non-nil,
-`message-font-lock-fence-open-regexp' is not used for searching for the
-fence open position. If SYMBOL is a function, it is called with one argument
-last cursor position and should return the fence open position as a number
-or a marker. If SYMBOL is a variable symbol, the value is examined with
-`symbol-value'. OFFSET is added to the position to compensate the value.
-For example, the following combinations of variable symbol and offset value
-can be used:
-
-Egg v3: '(egg:*region-start* . -1)
-Canna: '(canna:*region-start* . 0)
-")
-
-(defvar message-font-lock-fence-close-position nil
- "*Cons of SYMBOL of a function or a variable and a number of OFFSET that
-indicate the fence close position. If it is non-nil,
-`message-font-lock-fence-close-regexp' is not used for searching for the
-fence close position. If SYMBOL is a function, it is called with one argument
-last cursor position and should return the fence close position as a number
-or a marker. If SYMBOL is a variable symbol, the value is examined with
-`symbol-value'. OFFSET is added to the position to compensate the value.
-For example, the following combinations of variable symbol and offset value
-can be used:
-
-Egg v3: '(egg:*region-end* . 0)
-Canna: '(canna:*region-end* . 0)
-")
-
-(defvar message-font-lock-cited-text-regexp
- "^[\t ]*\\([^\000- :>|}\177]*\\)[:>|}].*"
- "*Regexp that matches cited text. It should have a grouping for the
-citation prefix which is ended at the beginning of citation mark string.")
-
-(defvar message-font-lock-citation-name-max-column 10
- "*Maximun number of column for citation name for fontifying.")
-
-(defvar message-font-lock-last-position nil
- "Internal buffer local variable to save the last cursor position
-before fontifying.")
-
-(eval-after-load "font-lock"
- '(defadvice font-lock-after-change-function
- (before message-font-lock-save-last-position activate)
- "Save last cursor position before fontifying."
- (if (eq 'message-mode major-mode)
- (setq message-font-lock-last-position (point)))))
-
-(defun message-font-lock-cited-text-matcher (limit)
- "Search for a cited text containing `message-font-lock-cited-text-regexp'
-forward. Argument LIMIT bounds the search. If a cited text is found, it
-returns t and sets match data 1 and 2, otherwise it returns nil. Normally,
-match data 2 has zero length, but if the FENCE (for input method) is detected
-in matched text, result is divided into match data 1 and 2 across the FENCE.
-See also the documentations for the following variables:
- `message-font-lock-fence-open-regexp'
- `message-font-lock-fence-close-regexp'
- `message-font-lock-fence-open-position'
- `message-font-lock-fence-close-position'
-"
- (prog1
- (when (re-search-forward message-font-lock-cited-text-regexp limit t)
- (let* ((start0 (match-beginning 0))
- (end0 (match-end 0))
- (cite-mark (match-end 1))
- (should-fontify
- (progn
- (goto-char cite-mark)
- (<= (current-column)
- message-font-lock-citation-name-max-column)))
- end1 start2)
- (and
- should-fontify
- message-font-lock-last-position
- (>= message-font-lock-last-position start0)
- (<= message-font-lock-last-position end0)
- (cond
- (message-font-lock-fence-open-position
- (let* ((symbol (car message-font-lock-fence-open-position))
- (open
- (cond ((functionp symbol)
- (funcall symbol message-font-lock-last-position))
- ((and (symbolp symbol)
- (boundp symbol))
- (symbol-value symbol)))))
- (when (markerp open)
- (setq open (marker-position open)))
- (and (numberp open)
- (setq open
- (+ open
- (cdr message-font-lock-fence-open-position)))
- (>= message-font-lock-last-position open)
- (goto-char open)
- (or (not message-font-lock-fence-open-regexp)
- (looking-at message-font-lock-fence-open-regexp))
- (setq end1 open))))
- (message-font-lock-fence-open-regexp
- (goto-char message-font-lock-last-position)
- (when (re-search-backward
- message-font-lock-fence-open-regexp start0 t)
- (setq end1 (match-beginning 0)))))
- (setq should-fontify
- (and message-font-lock-fence-open-position
- (not (eq cite-mark end1))))
- (cond
- (message-font-lock-fence-close-position
- (let* ((symbol (car message-font-lock-fence-close-position))
- (close
- (cond ((functionp symbol)
- (funcall symbol message-font-lock-last-position))
- ((and (symbolp symbol)
- (boundp symbol))
- (symbol-value symbol)))))
- (when (markerp close)
- (setq close (marker-position close)))
- (and (numberp close)
- (setq close
- (+ close
- (cdr message-font-lock-fence-close-position)))
- (<= message-font-lock-last-position close)
- (setq start2 close))))
- (message-font-lock-fence-close-regexp
- (goto-char message-font-lock-last-position)
- (when (looking-at message-font-lock-fence-close-regexp)
- (setq start2 (match-end 0)))))
- (setq should-fontify
- (and (not (and (not message-font-lock-fence-open-position)
- (eq cite-mark end1)))
- (not (eq cite-mark start2)))))
- (goto-char end0)
- (when should-fontify
- (if start2
- (store-match-data (list start0 end0 start0 end1 start2 end0))
- (store-match-data (list start0 end0 start0 end0 end0 end0)))
- t)))
- (setq message-font-lock-last-position nil)))
-
-(defvar message-font-lock-keywords-1
+(defvar message-font-lock-keywords
(let ((content "[ \t]*\\(.+\\(\n[ \t].*\\)*\\)\n?"))
`((,(concat "^\\([Tt]o:\\)" content)
(1 'message-header-name-face)
(not (equal mail-header-separator "")))
`((,(concat "^\\(" (regexp-quote mail-header-separator) "\\)$")
1 'message-separator-face))
- nil))))
-
-(defvar message-font-lock-keywords-2
- (append message-font-lock-keywords-1
- `((message-font-lock-cited-text-matcher
- (1 'message-cited-text-face)
- (2 'message-cited-text-face))
- (,(concat "^\\(" message-cite-prefix-regexp "\\).*")
- (0 'message-cited-text-face))
- ("<#/?\\(multipart\\|part\\|external\\|mml\\).*>"
- (0 'message-mml-face)))))
-
-(defvar message-font-lock-keywords message-font-lock-keywords-2
+ nil)
+ (,(concat "^\\(" message-cite-prefix-regexp "\\).*")
+ (0 'message-cited-text-face))
+ (,mime-edit-tag-regexp
+ (0 'message-mml-face))))
"Additional expressions to highlight in Message mode.")
;; XEmacs does it like this. For Emacs, we have to set the
;; `font-lock-defaults' buffer-local variable.
-(put 'message-mode 'font-lock-defaults
- '((message-font-lock-keywords
- message-font-lock-keywords-1
- message-font-lock-keywords-2)
- nil nil nil nil
- (font-lock-mark-block-function . mark-paragraph)))
+(put 'message-mode 'font-lock-defaults '(message-font-lock-keywords t))
(defvar message-face-alist
'((bold . bold-region)
;; 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'.
(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-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")
(autoload 'mu-cite-original "mu-cite"))
((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."
(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)
["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"))]))
(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-f C-k move to Keywords C-c C-f C-d move to Distribution
C-c C-f C-m move to Mail-Followup-To
C-c C-f C-f move to Followup-To
+ C-c C-f c move to Mail-Copies-To
C-c C-t `message-insert-to' (add a To header to a news followup)
C-c C-n `message-insert-newsgroups' (add a Newsgroup header to a news reply)
C-c C-b `message-goto-body' (move to beginning of message text).
C-c C-z `message-kill-to-signature' (kill the text up to the signature).
C-c C-r `message-caesar-buffer-body' (rot13 the message body).
M-RET `message-newline-and-reformat' (break the line and reformat)."
- (interactive)
- (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-user-agent)
(make-local-variable 'message-post-method)
(set (make-local-variable 'message-sent-message-via) nil)
(if (featurep 'xemacs)
(message-setup-toolbar)
(set (make-local-variable 'font-lock-defaults)
- '((message-font-lock-keywords
- message-font-lock-keywords-1
- message-font-lock-keywords-2)
- nil nil nil nil
- (font-lock-mark-block-function . mark-paragraph)))
+ '(message-font-lock-keywords t))
(if (boundp 'tool-bar-map)
(set (make-local-variable 'tool-bar-map) (message-tool-bar-map))))
- (set (make-local-variable 'message-font-lock-last-position) nil)
(easy-menu-add message-mode-menu message-mode-map)
(easy-menu-add message-mode-field-menu message-mode-map)
;; Allow mail alias things.
(mail-abbrevs-setup)
(mail-aliases-setup)))
(message-set-auto-save-file-name)
- (make-local-variable 'indent-tabs-mode) ;Turn off tabs for indentation.
- (setq indent-tabs-mode nil)
- (run-hooks 'text-mode-hook 'message-mode-hook))
+ (set (make-local-variable 'indent-tabs-mode) nil)) ;No tabs for indentation.
(defun message-setup-fill-variables ()
"Setup message fill variables."
(setq adaptive-fill-first-line-regexp nil))
(make-local-variable 'adaptive-fill-first-line-regexp)
(make-local-variable 'auto-fill-inhibit-regexp)
+ (make-local-variable 'normal-auto-fill-function)
(let ((quote-prefix-regexp
;; User should change message-cite-prefix-regexp if
;; message-yank-prefix is set to an abnormal value.
(setq adaptive-fill-first-line-regexp
(concat quote-prefix-regexp "\\|"
adaptive-fill-first-line-regexp))
- (setq auto-fill-inhibit-regexp "^[A-Z][^: \n\t]+:")))
+ ;;(setq auto-fill-inhibit-regexp "^[A-Z][^: \n\t]+:")
+ (setq auto-fill-inhibit-regexp nil)
+ (setq normal-auto-fill-function 'message-do-auto-fill)))
\f
(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."
+ (unless (text-property-any (gnus-point-at-bol) (point) 'field 'header)
+ (do-auto-fill)))
(defun message-insert-signature (&optional force)
"Insert a signature. See documentation for variable `message-signature'."
;; Insert the signature.
(unless (bolp)
(insert "\n"))
- (insert "\n-- \n")
+ (insert "\n" message-signature-separator-for-insertion)
+ (unless (bolp)
+ (insert "\n"))
(if (eq signature t)
(insert-file-contents message-signature-file)
(insert signature))
(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))
- (if (looking-at message-cite-prefix-regexp)
+ (if (looking-at ">")
(insert message-yank-cited-prefix)
(insert message-yank-prefix))
(forward-line 1))))
(backward-delete-char 1)))))
(unless arg
- (funcall message-cite-function))
+ (if (and message-suspend-font-lock-when-citing
+ (boundp 'font-lock-mode)
+ (symbol-value 'font-lock-mode))
+ (unwind-protect
+ (progn
+ (sit-for 0)
+ (font-lock-mode 0)
+ (funcall message-cite-function))
+ (font-lock-mode 1))
+ (funcall message-cite-function)))
(message-exchange-point-and-mark)
(unless (bolp)
(insert ?\n))
(save-excursion
(set-buffer message-encoding-buffer)
(erase-buffer)
- ;; Avoid copying text props.
- (let (message-invisibles)
- (insert
- (with-current-buffer message-edit-buffer
- (setq message-invisibles (message-find-invisible-regions))
- (buffer-substring-no-properties (point-min) (point-max))))
- ;; Inherit the invisible property of texts to make MIME-Edit
- ;; find the MIME part boundaries.
- (dolist (region message-invisibles)
- (put-text-property (car region) (cdr region) 'invisible t)))
+ ;; ;; Avoid copying text props.
+ ;; T-gnus change: copy all text props, except for `field', from
+ ;; the editing buffer into the encoding buffer. `field' is the
+ ;; special text property on Emacs 21, see NEWS for details.
+ (insert-buffer message-edit-buffer)
+ (put-text-property (point-min) (point-max) 'field nil)
(funcall message-encode-function)
(while (and success
(setq elem (pop alist)))
(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))
(put 'message-check 'lisp-indent-function 1)
(put 'message-check 'edebug-form-spec '(form body))
-;; This function will be used by MIME-Edit when inserting invisible parts.
-(defun message-invisible-region (start end)
- (if (featurep 'xemacs)
- (if (save-excursion
- (goto-char start)
- (eq (following-char) ?\n))
- (setq start (1+ start)))
- (if (save-excursion
- (goto-char (1- end))
- (eq (following-char) ?\n))
- (setq end (1- end))))
- (put-text-property start end 'invisible t)
- (if (eq 'message-mode major-mode)
- (put-text-property start end 'message-invisible t)))
-
-(eval-after-load "invisible"
- '(defalias 'invisible-region 'message-invisible-region))
-
-(defun message-find-invisible-regions ()
- "Find invisible texts with the property `message-invisible' and
-return a list of points."
- (let (from
- (to (point-min))
- regions)
- (while (setq from (text-property-any to (point-max)
- 'message-invisible t))
- (setq to (or (text-property-not-all from (point-max)
- 'message-invisible t)
- (point-max)))
- (push (cons from to) regions))
- regions))
+;; Advise the function `invisible-region'.
+(let (current-load-list)
+ (eval
+ `(defadvice invisible-region (around add-mime-edit-invisible (start end)
+ activate)
+ "Advised by T-gnus Message.
+Add the text property `mime-edit-invisible' to an invisible text when
+the buffer's major mode is `message-mode'. The added property will be
+used to distinguish whether the invisible text is a MIME part or not."
+ ,(if (featurep 'xemacs)
+ '(if (eq ?\n (char-after start))
+ (setq start (1+ start)))
+ '(if (eq ?\n (char-after (1- end)))
+ (setq end (1- end))))
+ (setq ad-return-value
+ (if (eq 'message-mode major-mode)
+ (add-text-properties start end
+ '(invisible t mime-edit-invisible t))
+ (put-text-property start end 'invisible t))))))
(defun message-fix-before-sending ()
"Do various things to make the message nice before sending it."
(goto-char (point-max))
(unless (bolp)
(insert "\n"))
- ;; Expose all invisible text with the property `message-invisible'.
- ;; We should believe that the things might be created by MIME-Edit.
- (let ((message-invisibles (message-find-invisible-regions)))
- (dolist (region message-invisibles)
- (put-text-property (car region) (cdr region) 'invisible nil))
- ;; Expose all invisible text.
- (message-check 'invisible-text
- (when (text-property-any (point-min) (point-max) 'invisible t)
- (put-text-property (point-min) (point-max) 'invisible nil)
+ ;; Delete all invisible text except for the mime parts which might
+ ;; be inserted by the MIME-Edit.
+ (message-check 'invisible-text
+ (let (from
+ (to (point-min))
+ mime-from mime-to hidden-start)
+ (while (setq from (text-property-any to (point-max) 'invisible t))
+ (setq to (or (text-property-not-all from (point-max) 'invisible t)
+ (point-max))
+ mime-to from)
+ (while (setq mime-from (text-property-any mime-to to
+ 'mime-edit-invisible t))
+ (when (> mime-from mime-to)
+ (setq hidden-start (or hidden-start mime-to))
+ (put-text-property mime-to mime-from 'invisible nil))
+ (setq mime-to (or (text-property-not-all mime-from to
+ 'mime-edit-invisible t)
+ to)))
+ (when (< mime-to to)
+ (setq hidden-start (or hidden-start mime-to))
+ (put-text-property mime-to to 'invisible nil)))
+ (when hidden-start
+ (goto-char hidden-start)
+ (set-window-start (selected-window) (gnus-point-at-bol))
(unless (yes-or-no-p
"Invisible text found and made visible; continue posting? ")
- (error "Invisible text found and made visible"))))
- ;; Hide again all text with the property `message-invisible'.
- ;; It is needed to make MIME-Edit find the MIME part boundaries.
- (dolist (region message-invisibles)
- (put-text-property (car region) (cdr region) 'invisible t))))
+ (error "Invisible text found and made visible"))))))
(defun message-add-action (action &rest types)
"Add ACTION to be performed when doing an exit of type TYPES."
(delete-region (match-end 0) (std11-field-end))
(insert " " (message-make-message-id))))
(condition-case err
- (funcall message-send-mail-function)
+ (funcall (or message-send-mail-real-function
+ message-send-mail-function))
(error
(throw 'message-sending-mail-failure err))))))
nil)
(condition-case err
(progn
- (funcall message-send-mail-function)
+ (funcall (or message-send-mail-real-function
+ message-send-mail-function))
nil)
(error err))))
(when failure
(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)))
(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 "")))
+ (mime-field-encoding-method-alist
+ (append (when group-field-charset
+ (list (cons "Newsgroups" group-field-charset)))
+ (when followup-field-charset
+ (list (cons "Followup-To" followup-field-charset)))
+ mime-field-encoding-method-alist))
(message-syntax-checks
- (if arg
+ (if (and arg
+ (listp message-syntax-checks))
(cons '(existing-newsgroups . disabled)
message-syntax-checks)
message-syntax-checks))
(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)))
- (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)
(while groups
- (when (and (not (boundp (intern (car groups) hashtb)))
- (not (equal (car groups) "poster")))
+ (unless (or (equal (car groups) "poster")
+ (member (car groups) known-groups))
(push (car groups) errors))
(pop groups))
(cond
;; Gnus is not running.
- ((or (not hashtb)
+ ((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.
(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)
- (headers '("Newsgroups" "Followup-To"))
- header error)
- (while (and headers (not error))
- (when (setq header (mail-fetch-field (car headers)))
- (if (or
- (not
- (string-match
- "\\`\\([-+_&.a-zA-Z0-9]+\\)?\\(,[-+_&.a-zA-Z0-9]+\\)*\\'"
- header))
- (memq
- nil (mapcar
- (lambda (g)
- (not (string-match "\\.\\'\\|\\.\\." g)))
- (message-tokenize-header header ","))))
- (setq error t)))
- (unless error
- (pop headers)))
- (if (not error)
- t
- (y-or-n-p
- (format "The %s header looks odd: \"%s\". Really post? "
- (car headers) header)))))
- (message-check 'repeated-newsgroups
- (let ((case-fold-search t)
- (headers '("Newsgroups" "Followup-To"))
- header error groups group)
- (while (and headers
- (not error))
- (when (setq header (mail-fetch-field (pop headers)))
- (setq groups (message-tokenize-header header ","))
- (while (setq group (pop groups))
- (when (member group groups)
- (setq error group
- groups nil)))))
- (if (not error)
- t
- (y-or-n-p
- (format "Group %s is repeated in headers. Really post? " error)))))
- ;; Check the From header.
- (message-check 'from
- (let* ((case-fold-search t)
- (from (message-fetch-field "from"))
- ad)
- (cond
- ((not from)
- (message "There is no From line. Posting is denied.")
- nil)
- ((or (not (string-match
- "@[^\\.]*\\."
- (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.
- (not (string-match "^[^@]+@[^@]+$" ad)) ;larsi.ifi.uio
- (string-match "(.*).*(.*)" from)) ;(lars) (lars)
- (message
- "Denied posting -- the From looks strange: \"%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))))))
+ ;; Check the Newsgroups & Followup-To headers for syntax errors.
+ (message-check 'valid-newsgroups
+ (let ((case-fold-search t)
+ (headers '("Newsgroups" "Followup-To"))
+ header error)
+ (while (and headers (not error))
+ (when (setq header (mail-fetch-field (car headers)))
+ (if (or
+ (not
+ (string-match
+ "\\`\\([-+_&.a-zA-Z0-9]+\\)?\\(,[-+_&.a-zA-Z0-9]+\\)*\\'"
+ header))
+ (memq
+ nil (mapcar
+ (lambda (g)
+ (not (string-match "\\.\\'\\|\\.\\." g)))
+ (message-tokenize-header header ","))))
+ (setq error t)))
+ (unless error
+ (pop headers)))
+ (if (not error)
+ t
+ (y-or-n-p
+ (format "The %s header looks odd: \"%s\". Really post? "
+ (car headers) header)))))
+ (message-check 'repeated-newsgroups
+ (let ((case-fold-search t)
+ (headers '("Newsgroups" "Followup-To"))
+ header error groups group)
+ (while (and headers
+ (not error))
+ (when (setq header (mail-fetch-field (pop headers)))
+ (setq groups (message-tokenize-header header ","))
+ (while (setq group (pop groups))
+ (when (member group groups)
+ (setq error group
+ groups nil)))))
+ (if (not error)
+ t
+ (y-or-n-p
+ (format "Group %s is repeated in headers. Really post? " error)))))
+ ;; Check the From header.
+ (message-check 'from
+ (let* ((case-fold-search t)
+ (from (message-fetch-field "from"))
+ ad)
+ (cond
+ ((not from)
+ (message "There is no From line. Posting is denied.")
+ nil)
+ ((or (not (string-match
+ "@[^\\.]*\\."
+ (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.
+ (not (string-match "^[^@]+@[^@]+$" ad)) ;larsi.ifi.uio
+ (string-match "(.*).*(.*)" from)) ;(lars) (lars)
+ (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 ()
(and
"Make a followup Subject."
(cond
((and (eq message-use-subject-re 'guess)
- (string-match message-subject-encoded-re-regexp subject))
+ (string-match message-subject-encoded-re-regexp subject))
subject)
(message-use-subject-re
(concat "Re: " (message-strip-subject-re subject)))
(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'.
(when (not quoted)
(if (and (> (current-column) 78)
last)
- (save-excursion
- (goto-char last)
+ (save-excursion
+ (goto-char last)
(looking-at "[ \t]*")
- (replace-match "\n " t t)))
- (setq last (1+ (point))))
+ (replace-match "\n " t t)))
+ (setq last (1+ (point))))
(setq quoted (not quoted)))
(unless (eobp)
(forward-char 1))))
(insert (capitalize (symbol-name header))
": "
(std11-fill-msg-id-list-string
- (if (consp value) (car value) value))
+ (if (consp value) (car value) value))
"\n"))
(defun message-fill-header (header value)
(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)))
(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
(to (concat "*sent mail to "
;;;(defvar mc-modes-alist)
(defun message-setup-1 (headers &optional replybuffer actions)
;;; (when (and (boundp 'mc-modes-alist)
-;;; (not (assq 'message-mode mc-modes-alist)))
+;;; (not (assq 'message-mode mc-modes-alist)))
;;; (push '(message-mode (encrypt . mc-encrypt-message)
-;;; (sign . mc-sign-message))
-;;; mc-modes-alist))
+;;; (sign . mc-sign-message))
+;;; mc-modes-alist))
(when actions
(setq message-send-actions actions))
(setq message-reply-buffer
(set-buffer-modified-p nil)
(setq buffer-undo-list nil)
(run-hooks 'message-setup-hook)
+ (save-restriction
+ (message-narrow-to-headers)
+ (put-text-property (point-min) (point-max) 'field 'header))
(message-position-point)
(undo-boundary))
(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))
mrt (when message-use-mail-reply-to
(message-fetch-field "mail-reply-to"))
mft (when (and (not (or to-address mrt reply-to))
- (or message-use-followup-to
- message-use-mail-followup-to))
+ message-use-mail-followup-to)
(message-fetch-field "mail-followup-to")))
;; Handle special values of Mail-Copies-To.
;; Handle Mail-Followup-To.
(when (and mft
- (eq (or message-use-followup-to
- message-use-mail-followup-to) 'ask)
+ (eq message-use-mail-followup-to 'ask)
(not (message-y-or-n-p
(concat "Obey Mail-Followup-To: " mft "? ") t "\
You should normally obey the Mail-Followup-To: header.
(save-excursion
(message-set-work-buffer)
(if (and mft
- message-use-followup-to
wide
- (or (not (eq message-use-followup-to 'ask))
+ (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
"the specified addresses"
"that address only") ".
-If a message is posted to several mailing lists, Mail-Followup-To is
-often used to direct the following discussion to one list 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 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.
;; 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?")))
+ (not (y-or-n-p "Reply to all recipients? ")))
(setq follow-to (delq (assoc 'Cc follow-to) follow-to)))))
follow-to))
distribution (message-fetch-field "distribution")
mct (when message-use-mail-copies-to
(message-fetch-field "mail-copies-to"))
- mft (when (or message-use-followup-to
- message-use-mail-followup-to)
+ mft (when message-use-mail-followup-to
(message-fetch-field "mail-followup-to")))
(when (and (setq gnus-warning (message-fetch-field "gnus-warning"))
(string-match "<[^>]+>" gnus-warning))
(setq follow-to (list (cons 'Newsgroups newsgroups)))))))
;; Handle Mail-Followup-To, followup via e-mail.
((and mft
- (or (not (eq (or message-use-followup-to
- message-use-mail-followup-to) 'ask))
+ (or (not (eq message-use-mail-followup-to 'ask))
(message-y-or-n-p
(concat "Obey Mail-Followup-To: " mft "? ") t "\
You should normally obey the Mail-Followup-To: header.
(widen)
(goto-char (point-min))
(search-forward "\n\n" nil t)
- (or (and boundary
- (re-search-forward boundary nil t)
- (forward-line 2))
- (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 boundary
+ (re-search-forward boundary nil t)
+ (forward-line 2))
+ (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))))
(save-restriction
(message-narrow-to-head-1)
(message-remove-header message-ignored-bounced-headers t)
"^\\(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
+ (mail-strip-quoted-names
(let ((to (message-fetch-field "to"))
(cc (message-fetch-field "cc"))
(bcc (message-fetch-field "bcc")))
(interactive)
(message "Saving %s..." buffer-file-name)
(let ((reply-headers message-reply-headers)
- (msg (buffer-substring-no-properties (point-min) (point-max)))
- (message-invisibles (message-find-invisible-regions)))
+ (buffer (current-buffer)))
(with-temp-file buffer-file-name
- (insert msg)
- ;; Inherit the invisible property of texts to make MIME-Edit
- ;; find the MIME part boundaries.
- (dolist (region message-invisibles)
- (put-text-property (car region) (cdr region) 'invisible t))
+ (insert-buffer buffer)
(setq message-reply-headers reply-headers)
(message-generate-headers '((optional . In-Reply-To)))
(mime-edit-translate-buffer))
projects / elisp / gnus.git- / blobdiff