(eval-when-compile
(require 'cl))
-(require 'mail-header)
+(require 'mailheader)
+(require 'rmail)
(require 'nnheader)
(require 'timezone)
(require 'easymenu)
(defvar message-directory "~/Mail/"
"*Directory from which all other mail file variables are derived.")
+(defvar message-max-buffers 10
+ "*How many buffers to keep before starting to kill them off.")
+
+(defvar message-send-rename-function nil
+ "Function called to rename the buffer after sending it.")
+
;;;###autoload
(defvar message-fcc-handler-function 'rmail-output
"*A function called to save outgoing articles.
included. Organization, Lines and X-Mailer are optional.")
;;;###autoload
-(defvar message-deletable-headers '(Message-ID Date)
+(defvar message-deletable-headers '(Message-ID Date Lines)
"*Headers to be deleted if they already exist and were generated by message previously.")
;;;###autoload
"*Regexp of headers to be removed unconditionally before mailing.")
;;;###autoload
-(defvar message-ignored-supersedes-headers
- "^Path:\\|^Date\\|^NNTP-Posting-Host:\\|^Xref:\\|^Lines:\\|^Received:\\|^X-From-Line:\\|Return-Path:"
+(defvar message-ignored-supersedes-headers "^Path:\\|^Date\\|^NNTP-Posting-Host:\\|^Xref:\\|^Lines:\\|^Received:\\|^X-From-Line:\\|Return-Path:\\|^Supersedes:"
"*Header lines matching this regexp will be deleted before posting.
It's best to delete old Path and Date headers before posting to avoid
any confusion.")
nil means let mailer mail back a message to report errors.")
;;;###autoload
-(defvar message-generate-new-buffers nil
- "*Non-nil means that a new message buffer will be created whenever `mail-setup' is called.")
+(defvar message-generate-new-buffers t
+ "*Non-nil means that a new message buffer will be created whenever `mail-setup' is called.
+If this is a function, call that function with three parameters: The type,
+the to address and the group name. (Any of these may be nil.) The function
+should return the new buffer name.")
;;;###autoload
(defvar message-kill-buffer-on-exit nil
"*Non-nil means that the message buffer will be killed after sending a message.")
(defvar gnus-local-organization)
-;;;###autoload
(defvar message-user-organization
(or (and (boundp 'gnus-local-organization)
gnus-local-organization)
(defvar message-user-organization-file "/usr/lib/news/organization"
"*Local news organization file.")
-;;;###autoload
-(defvar message-autosave-directory
- (concat (file-name-as-directory message-directory) "drafts/")
+(defvar message-autosave-directory "~/"
+ ; (concat (file-name-as-directory message-directory) "drafts/")
"*Directory where message autosaves buffers.
If nil, message won't autosave.")
(defvar message-ignored-cited-headers "."
"Delete these headers from the messages you yank.")
+(defvar message-cancel-message "I am canceling my own article."
+ "Message to be inserted in the cancel message.")
+
;; Useful to set in site-init.el
;;;###autoload
(defvar message-send-mail-function 'message-send-mail-with-sendmail
The headers should be delimited by a line whose contents match the
variable `mail-header-separator'.
-Legal values include `message-send-mail-with-mh' and
-`message-send-mail-with-sendmail', which is the default.")
+Legal values include `message-send-mail-with-sendmail' (the default),
+`message-send-mail-with-mh' and `message-send-mail-with-qmail'.")
;;;###autoload
(defvar message-send-news-function 'message-send-news
"Function to call to send the current buffer as news.
The headers should be delimited by a line whose contents match the
-variable `message-header-separator'.")
+variable `mail-header-separator'.")
;;;###autoload
(defvar message-reply-to-function nil
whether to ignore the \"poster\" value. If it is the symbol `use',
always use the value.")
+;; qmail-related stuff
+(defvar message-qmail-inject-program "/var/qmail/bin/qmail-inject"
+ "Location of the qmail-inject program.")
+
+(defvar message-qmail-inject-args nil
+ "Arguments passed to qmail-inject programs.
+This should be a list of strings, one string for each argument.
+
+For e.g., if you wish to set the envelope sender address so that bounces
+go to the right place or to deal with listserv's usage of that address, you
+might set this variable to '(\"-f\" \"you@some.where\").")
+
(defvar gnus-post-method)
(defvar gnus-select-method)
;;;###autoload
(defvar message-generate-headers-first nil
"*If non-nil, generate all possible headers before composing.")
-;;;###autoload
-(defvar message-header-separator "--text follows this line--"
- "*Line used to separate headers from text in messages being composed.")
-
(defvar message-setup-hook nil
"Normal hook, run each time a new outgoing message is initialized.
The function `message-setup' runs this hook.")
+(defvar message-signature-setup-hook nil
+ "Normal hook, run each time a new outgoing message is initialized.
+It is run after the headers have been inserted and before
+the signature is inserted.")
+
+(defvar message-mode-hook nil
+ "Hook run in message mode buffers.")
+
+(defvar message-header-hook nil
+ "Hook run in a message mode buffer narrowed to the headers.")
+
(defvar message-header-setup-hook nil
"Hook called narrowed to the headers when setting up a message buffer.")
The value should be an expression to test whether the problem will
actually occur.")
+;;; Internal variables.
+;;; Well, not really internal.
+
(defvar message-mode-syntax-table
(let ((table (copy-syntax-table text-mode-syntax-table)))
(modify-syntax-entry ?% ". " table)
table)
"Syntax table used while in Message mode.")
+(defvar message-mode-abbrev-table text-mode-abbrev-table
+ "Abbrev table used in Message mode buffers.
+Defaults to `text-mode-abbrev-table'.")
+
(defvar message-font-lock-keywords
(let* ((cite-prefix "A-Za-z") (cite-suffix (concat cite-prefix "0-9_.@-")))
(list '("^To:" . font-lock-function-name-face)
;;; Internal variables.
+(defvar message-buffer-list nil)
+
+;; Byte-compiler warning
+(defvar gnus-active-hashtb)
+
;;; Regexp matching the delimiter of messages in UNIX mail format
;;; (UNIX From lines), minus the initial ^.
(defvar message-unix-mail-delimiter
(defvar message-header-format-alist
`((Newsgroups)
- (To . message-fill-header)
- (Cc . message-fill-header)
+ (To . message-fill-address)
+ (Cc . message-fill-address)
(Subject)
(In-Reply-To)
(Fcc)
"Alist used for formatting headers.")
(eval-and-compile
- (autoload 'message-setup-toolbar "message-xmas")
+ (autoload 'message-setup-toolbar "messagexmas")
(autoload 'mh-send-letter "mh-comp"))
\f
(point)
(goto-char p))))
+(defmacro message-y-or-n-p (question show &rest text)
+ "Ask QUESTION, displaying the rest of the arguments in a temp. buffer if SHOW"
+ `(message-talkative-question 'y-or-n-p ,question ,show ,@text))
+
;; Delete the current line (and the next N lines.);
(defmacro message-delete-line (&optional n)
`(delete-region (progn (beginning-of-line) (point))
(defun message-tokenize-header (header &optional separator)
"Split HEADER into a list of header elements.
\",\" is used as the separator."
- (let* ((beg 0)
- (separator (or separator ","))
- (regexp
- (format "[ \t]*\\([^%s]+\\)?\\([%s]+\\|\\'\\)" separator separator))
- elems)
- (while (and (string-match regexp header beg)
- (< beg (length header)))
- (when (match-beginning 1)
- (push (match-string 1 header) elems))
- (setq beg (match-end 0)))
- (nreverse elems)))
+ (let ((regexp (format "[%s]+" (or separator ",")))
+ (beg 1)
+ (first t)
+ quoted elems paren)
+ (save-excursion
+ (message-set-work-buffer)
+ (insert header)
+ (goto-char (point-min))
+ (while (not (eobp))
+ (if first
+ (setq first nil)
+ (forward-char 1))
+ (cond ((and (> (point) beg)
+ (or (eobp)
+ (and (looking-at regexp)
+ (not quoted)
+ (not paren))))
+ (push (buffer-substring beg (point)) elems)
+ (setq beg (match-end 0)))
+ ((= (following-char) ?\")
+ (setq quoted (not quoted)))
+ ((and (= (following-char) ?\()
+ (not quoted))
+ (setq paren t))
+ ((and (= (following-char) ?\))
+ (not quoted))
+ (setq paren nil))))
+ (nreverse elems))))
(defun message-fetch-field (header)
"The same as `mail-fetch-field', only remove all newlines."
(forward-char -1)))
(lambda ()
(or (get-text-property (point) 'message-rank)
- 0))))
+ 10000))))
(defun message-sort-headers ()
"Sort the headers of the current message according to `message-header-format-alist'."
"----"
["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]
["Sort Headers" message-sort-headers t]
["Yank Original" message-yank-original t]
["Fill Yanked Message" message-fill-yanked-message t]
- ;; ["Insert Signature" news-reply-signature t]
+ ["Insert Signature" message-insert-signature t]
["Caesar (rot13) Message" message-caesar-buffer-body t]
["Rename buffer" message-rename-buffer t]
["Spellcheck" ispell-message t]
["Send Message" message-send-and-exit t]
["Abort Message" message-dont-send t]))
+(defvar facemenu-add-face-function)
+(defvar facemenu-remove-face-function)
+
;;;###autoload
(defun message-mode ()
"Major mode for editing mail and news to be sent.
(make-local-variable 'message-postpone-actions)
(set-syntax-table message-mode-syntax-table)
(use-local-map message-mode-map)
- (setq local-abbrev-table text-mode-abbrev-table)
+ (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 'paragraph-start)
(setq paragraph-start (concat (regexp-quote mail-header-separator)
"$\\|[ \t]*[-_][-_][-_]+$\\|"
+ "-- $\\|"
paragraph-start))
(setq paragraph-separate (concat (regexp-quote mail-header-separator)
"$\\|[ \t]*[-_][-_][-_]+$\\|"
+ "-- $\\|"
paragraph-separate))
(make-local-variable 'message-reply-headers)
(setq message-reply-headers nil)
(setq message-sent-message-via nil)
(make-local-variable 'message-checksum)
(setq message-checksum nil)
- (when (fboundp 'mail-hist-define-keys)
- (mail-hist-define-keys))
+ ;;(when (fboundp 'mail-hist-define-keys)
+ ;; (mail-hist-define-keys))
(when (string-match "XEmacs\\|Lucid" emacs-version)
(message-setup-toolbar))
(easy-menu-add message-mode-menu message-mode-map)
(defun message-goto-body ()
"Move point to the beginning of the message body."
(interactive)
+ (if (looking-at "[ \t]*\n") (expand-abbrev))
(goto-char (point-min))
(search-forward (concat "\n" mail-header-separator "\n") nil t))
(defun message-insert-to ()
"Insert a To header that points to the author of the article being replied to."
(interactive)
- (when (message-position-on-field "To")
+ (when (and (message-position-on-field "To")
+ (mail-fetch-field "to")
+ (not (string-match "\\` *\\'" (mail-fetch-field "to"))))
(insert ", "))
(insert (or (message-fetch-reply-field "reply-to")
(message-fetch-reply-field "from") "")))
(defun message-insert-newsgroups ()
"Insert the Newsgroups header from the article being replied to."
(interactive)
- (when (message-position-on-field "Newsgroups")
+ (when (and (message-position-on-field "Newsgroups")
+ (mail-fetch-field "newsgroups")
+ (not (string-match "\\` *\\'" (mail-fetch-field "newsgroups"))))
(insert ","))
(insert (or (message-fetch-reply-field "newsgroups") "")))
(defun message-insert-signature (&optional force)
"Insert a signature. See documentation for the `message-signature' variable."
- (interactive (list t))
+ (interactive (list 0))
(let* ((signature
(cond ((and (null message-signature)
+ (eq force 0))
+ (save-excursion
+ (goto-char (point-max))
+ (not (re-search-backward
+ message-signature-separator nil t))))
+ ((and (null message-signature)
force)
t)
((message-functionp message-signature)
(file-exists-p message-signature-file))
signature))))
(when signature
- ;; Remove blank lines at the end of the message.
(goto-char (point-max))
- (skip-chars-backward " \t\n")
- (end-of-line)
- (delete-region (point) (point-max))
;; Insert the signature.
- (insert "\n\n-- \n")
+ (unless (bolp)
+ (insert "\n"))
+ (insert "\n-- \n")
(if (eq signature t)
(insert-file-contents message-signature-file)
(insert signature))
(name-default (concat "*message* " mail-trimmed-to))
(name (if enter-string
(read-string "New buffer name: " name-default)
- name-default)))
- (rename-buffer name t)))))
+ name-default))
+ (default-directory
+ (file-name-as-directory message-autosave-directory)))
+ (rename-buffer name t)))))
(defun message-fill-yanked-message (&optional justifyp)
"Fill the paragraphs of a message yanked into this one.
(if (search-forward "\n\n" nil t)
(1- (point))
(point)))
- (message-remove-header message-ignored-cited-headers t)))
+ (message-remove-header message-ignored-cited-headers t)
+ (goto-char (point-max))))
+ ;; Delete blank lines at the start of the buffer.
+ (while (and (point-min)
+ (eolp))
+ (message-delete-line))
+ ;; Delete blank lines at the end of the buffer.
+ (goto-char (point-max))
+ (unless (eolp)
+ (insert "\n"))
+ (while (and (zerop (forward-line -1))
+ (looking-at "$"))
+ (message-delete-line))
;; Do the indentation.
(if (null message-yank-prefix)
(indent-rigidly start (mark t) message-indentation-spaces)
Normally indents each nonblank line ARG spaces (default 3). However,
if `message-yank-prefix' is non-nil, insert that prefix on each line.
+This function uses `message-cite-function' to do the actual citing.
+
Just \\[universal-argument] as argument means don't indent, insert no
prefix, and don't delete any headers."
(interactive "P")
(delete-windows-on message-reply-buffer t)
(insert-buffer message-reply-buffer)
(funcall message-cite-function)
- (exchange-point-and-mark)
+ (message-exchange-point-and-mark)
(unless (bolp)
(insert ?\n))
(unless modified
- (setq message-checksum (message-checksum))))))
+ (setq message-checksum (cons (message-checksum) (buffer-size)))))))
-(defun message-cite-original ()
+(defun message-cite-original ()
+ "Cite function in the standard Message manner."
(let ((start (point))
(functions
(when message-indent-citation-function
(y-or-n-p "No changes in the buffer; really send? ")))
;; Make it possible to undo the coming changes.
(undo-boundary)
+ (let ((inhibit-read-only t))
+ (put-text-property (point-min) (point-max) 'read-only nil))
(message-fix-before-sending)
(run-hooks 'message-send-hook)
(message "Sending...")
"Already sent message via mail; resend? "))
(message-send-mail arg))))
(message-do-fcc)
- (when (fboundp 'mail-hist-put-headers-into-history)
- (mail-hist-put-headers-into-history))
+ ;;(when (fboundp 'mail-hist-put-headers-into-history)
+ ;; (mail-hist-put-headers-into-history))
(run-hooks 'message-sent-hook)
(message "Sending...done")
;; If buffer has no file, mark it as unmodified and delete autosave.
(unless buffer-file-name
(set-buffer-modified-p nil)
(delete-auto-save-file-if-necessary t))
+ ;; Delete other mail buffers and stuff.
+ (message-do-send-housekeeping)
(message-do-actions message-send-actions)
;; Return success.
t)))
(save-excursion
(set-buffer tembuf)
(erase-buffer)
- (insert-buffer-substring mailbuf)
+ ;; Avoid copying text props.
+ (insert (format
+ "%s" (save-excursion
+ (set-buffer mailbuf)
+ (buffer-string))))
;; Remove some headers.
(save-restriction
(message-narrow-to-headers)
(when (bufferp errbuf)
(kill-buffer errbuf)))))
+(defun message-send-mail-with-qmail ()
+ "Pass the prepared message buffer to qmail-inject.
+Refer to the documentation for the variable `message-send-mail-function'
+to find out how to use this."
+ ;; replace the header delimiter with a blank line
+ (goto-char (point-min))
+ (re-search-forward
+ (concat "^" (regexp-quote mail-header-separator) "\n"))
+ (replace-match "\n")
+ ;; send the message
+ (case
+ (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
+ ;; 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.
+ ;;
+ ;; 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 being raped by
+ ;; 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
+ message-qmail-inject-args)
+ ;; 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."))
+ (111 (error "qmail-inject reported transient failure."))
+ ;; should never happen
+ (t (error "qmail-inject reported unknown failure."))))
+
+
(defun message-send-mail-with-mh ()
"Send the prepared message buffer with mh."
(let ((mh-previous-window-config nil)
(concat (file-name-as-directory message-autosave-directory)
"msg."))))
(setq buffer-file-name name)
- (mh-send-letter)
- (condition-case ()
- (delete-file name)
- (error nil))))
+ ;; MH wants to generate these headers itself.
+ (let ((headers message-deletable-headers))
+ (while headers
+ (goto-char (point-min))
+ ;;(message "Deleting header %s" (car headers)) (sit-for 5)
+ (and (re-search-forward
+ (concat "^" (symbol-name (car headers)) ": *") nil t)
+ (message-delete-line))
+ (pop headers)))
+ ;; Pass it on to mh.
+ (mh-send-letter)))
(defun message-send-news (&optional arg)
(let ((tembuf (generate-new-buffer " *message temp*"))
(funcall message-post-method arg)
message-post-method))
(messbuf (current-buffer))
+ (message-syntax-checks
+ (if arg
+ (cons '(existing-newsgroups . disabled)
+ message-syntax-checks)
+ message-syntax-checks))
result)
(save-restriction
(message-narrow-to-headers)
(message-generate-headers message-required-news-headers)
;; Let the user do all of the above.
(run-hooks 'message-header-hook))
+ (message-cleanup-headers)
(when (message-check-news-syntax)
(unwind-protect
(save-excursion
(set-buffer tembuf)
(buffer-disable-undo (current-buffer))
(erase-buffer)
- (insert-buffer-substring messbuf)
+ ;; Avoid copying text props.
+ (insert (format
+ "%s" (save-excursion
+ (set-buffer messbuf)
+ (buffer-string))))
;; Remove some headers.
(save-restriction
(message-narrow-to-headers)
(goto-char (point-min))
(insert "Followup-To: " to "\n"))
t))
-
+ ;; Check "Shoot me".
+ (or (message-check-element 'shoot)
+ (save-excursion
+ (if (re-search-forward
+ "Message-ID.*.i-have-a-misconfigured-system-so-shoot-me"
+ nil t)
+ (y-or-n-p
+ "You appear to have a misconfigured system. Really post? ")
+ t)))
;; Check for Approved.
(or (message-check-element 'approved)
(save-excursion
(if (not hashtb)
t
(while groups
- (unless (boundp (intern (car groups) hashtb))
+ (when (and (not (boundp (intern (car groups) hashtb)))
+ (not (equal (car groups) "poster")))
(push (car groups) errors))
(pop groups))
(if (not errors)
(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))
+ (not
+ (string-match
+ "\\`\\([-+_&.a-zA-Z0-9]+\\)?\\(,[-+_&.a-zA-Z0-9]+\\)*\\'"
+ header))
(memq
nil (mapcar
(lambda (g)
(car headers) header)))))
;; Check the From header.
(or
- (message-check-element 'from)
(save-excursion
(let* ((case-fold-search t)
(from (message-fetch-field "from")))
(concat "^" (regexp-quote mail-header-separator) "$"))
(forward-line 1)
(let ((b (point)))
- (or (re-search-forward message-signature-separator nil t)
- (goto-char (point-max)))
+ (goto-char (point-max))
+ (re-search-backward message-signature-separator nil t)
(beginning-of-line)
(or (re-search-backward "[^ \n\t]" b t)
(y-or-n-p "Empty article. Really post? ")))))
;; Check whether any new text has been added.
(or (message-check-element 'new-text)
(not message-checksum)
- (not (eq (message-checksum) message-checksum))
+ (not (and (eq (message-checksum) (car message-checksum))
+ (eq (buffer-size) (cdr message-checksum))))
(y-or-n-p
"It looks like no new text has been added. Really post? "))
;; Check the length of the signature.
(message-check-element 'signature)
(progn
(goto-char (point-max))
- (if (or (not (re-search-backward "^-- $" nil t))
+ (if (or (not (re-search-backward message-signature-separator nil t))
(search-forward message-forward-end-separator nil t))
t
(if (> (count-lines (point) (point-max)) 5)
(y-or-n-p
(format
"Your .sig is %d lines; it should be max 4. Really post? "
- (count-lines (point) (point-max))))
+ (1- (count-lines (point) (point-max)))))
t))))))
(defun message-check-element (type)
(re-search-forward
(concat "^" (regexp-quote mail-header-separator) "$"))
(while (not (eobp))
- (setq sum (logxor sum (following-char)))
+ (when (not (looking-at "[ \t\n]"))
+ (setq sum (logxor (ash sum 1) (following-char))))
(forward-char 1)))
sum))
(if (string-match "^[ \t]*|[ \t]*\\(.*\\)[ \t]*$" file)
;; Pipe the article to the program in question.
(call-process-region (point-min) (point-max) shell-file-name
- nil nil nil "-c" (match-string 1 file))
+ 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))
(mail-header-subject message-reply-headers))
(message-strip-subject-re psubject))))
"_-_" ""))
- "@" (message-make-fqdm) ">"))
+ "@" (message-make-fqdn) ">"))
(defvar message-unique-id-char nil)
(defun message-make-from ()
"Make a From header."
(let* ((login (message-make-address))
- (fullname (user-full-name)))
+ (fullname
+ (or (and (boundp 'user-full-name)
+ user-full-name)
+ (user-full-name))))
(when (string= fullname "&")
(setq fullname (user-login-name)))
(save-excursion
(when user-mail-address
(nth 1 (mail-extract-address-components user-mail-address))))
-(defun message-make-fqdm ()
+(defun message-make-fqdn ()
"Return user's fully qualified domain name."
- (let ((system-name (system-name)))
+ (let ((system-name (system-name))
+ (user-mail (message-user-mail-address)))
(cond
((string-match "[^.]\\.[^.]" system-name)
;; `system-name' returned the right result.
system-name)
- ;; We try `user-mail-address' as a backup.
- ((string-match "@\\(.*\\)\\'" (message-user-mail-address))
- (match-string 1 user-mail-address))
;; Try `mail-host-address'.
((and (boundp 'mail-host-address)
- mail-host-address)
+ (stringp mail-host-address)
+ (string-match "\\." mail-host-address))
mail-host-address)
+ ;; We try `user-mail-address' as a backup.
+ ((and (string-match "\\." user-mail)
+ (string-match "@\\(.*\\)\\'" user-mail))
+ (match-string 1 user-mail))
;; Default to this bogus thing.
(t
(concat system-name ".i-have-a-misconfigured-system-so-shoot-me")))))
(defun message-make-host-name ()
"Return the name of the host."
- (let ((fqdm (message-make-fqdm)))
- (string-match "^[^.]+\\." fqdm)
- (substring fqdm 0 (1- (match-end 0)))))
+ (let ((fqdn (message-make-fqdn)))
+ (string-match "^[^.]+\\." fqdn)
+ (substring fqdn 0 (1- (match-end 0)))))
(defun message-make-domain ()
"Return the domain name."
(or mail-host-address
- (message-make-fqdm)))
+ (message-make-fqdn)))
(defun message-generate-headers (headers)
"Prepare article HEADERS.
;;; Setting up a message buffer
;;;
+(defun message-fill-address (header value)
+ (save-restriction
+ (narrow-to-region (point) (point))
+ (insert (capitalize (symbol-name header))
+ ": "
+ (if (consp value) (car value) value)
+ "\n")
+ (narrow-to-region (point-min) (1- (point-max)))
+ (let (quoted last)
+ (goto-char (point-min))
+ (while (not (eobp))
+ (skip-chars-forward "^,\"" (point-max))
+ (if (or (= (following-char) ?,)
+ (eobp))
+ (when (not quoted)
+ (if (and (> (current-column) 78)
+ last)
+ (progn
+ (save-excursion
+ (goto-char last)
+ (insert "\n\t"))
+ (setq last (1+ (point))))
+ (setq last (1+ (point)))))
+ (setq quoted (not quoted)))
+ (unless (eobp)
+ (forward-char 1))))
+ (goto-char (point-max))
+ (widen)
+ (forward-line 1)))
+
(defun message-fill-header (header value)
(let ((begin (point))
(fill-column 78)
(forward-line 2)))
(sit-for 0)))
+(defun message-buffer-name (type &optional to group)
+ "Return a new (unique) buffer name based on TYPE and TO."
+ (cond
+ ;; Check whether `message-generate-new-buffers' is a function,
+ ;; and if so, call it.
+ ((message-functionp message-generate-new-buffers)
+ (funcall message-generate-new-buffers type to group))
+ ;; Generate a new buffer name The Message Way.
+ (message-generate-new-buffers
+ (generate-new-buffer-name
+ (concat "*" type
+ (if to
+ (concat " to "
+ (or (car (mail-extract-address-components to))
+ to) "")
+ "")
+ (if (and group (not (string= group ""))) (concat " on " group) "")
+ "*")))
+ ;; Use standard name.
+ (t
+ (format "*%s message*" type))))
+
(defun message-pop-to-buffer (name)
"Pop to buffer NAME, and warn if it already exists and is modified."
- (if message-generate-new-buffers
- (set-buffer (pop-to-buffer (generate-new-buffer name)))
- (let ((buffer (get-buffer name)))
- (if (and buffer
- (buffer-name buffer))
- (progn
- (set-buffer (pop-to-buffer buffer))
- (when (and (buffer-modified-p)
- (not (y-or-n-p
- "Message already being composed; erase? ")))
- (error "Message being composed")))
- (set-buffer (pop-to-buffer name)))))
+ (let ((buffer (get-buffer name)))
+ (if (and buffer
+ (buffer-name buffer))
+ (progn
+ (set-buffer (pop-to-buffer buffer))
+ (when (and (buffer-modified-p)
+ (not (y-or-n-p
+ "Message already being composed; erase? ")))
+ (error "Message being composed")))
+ (set-buffer (pop-to-buffer name))))
(erase-buffer)
(message-mode))
+(defun message-do-send-housekeeping ()
+ "Kill old message buffers."
+ ;; We might have sent this buffer already. Delete it from the
+ ;; list of buffers.
+ (setq message-buffer-list (delq (current-buffer) message-buffer-list))
+ (while (and message-max-buffers
+ (>= (length message-buffer-list) message-max-buffers))
+ ;; Kill the oldest buffer -- unless it has been changed.
+ (let ((buffer (pop message-buffer-list)))
+ (when (and (buffer-name buffer)
+ (not (buffer-modified-p buffer)))
+ (kill-buffer buffer))))
+ ;; Rename the buffer.
+ (if message-send-rename-function
+ (funcall message-send-rename-function)
+ (when (string-match "\\`\\*" (buffer-name))
+ (rename-buffer
+ (concat "*sent " (substring (buffer-name) (match-end 0))) t)))
+ ;; Push the current buffer onto the list.
+ (when message-max-buffers
+ (setq message-buffer-list
+ (nconc message-buffer-list (list (current-buffer))))))
+
+(defvar mc-modes-alist)
(defun message-setup (headers &optional replybuffer actions)
+ (when (and (boundp 'mc-modes-alist)
+ (not (assq 'message-mode mc-modes-alist)))
+ (push '(message-mode (encrypt . mc-encrypt-message)
+ (sign . mc-sign-message))
+ mc-modes-alist))
(when actions
(setq message-send-actions actions))
(setq message-reply-buffer replybuffer)
(pop h))
alist)
headers)
- (forward-line -1)
+ (delete-region (point) (progn (forward-line -1) (point)))
(when message-default-headers
(insert message-default-headers))
- (insert mail-header-separator "\n")
+ (put-text-property
+ (point)
+ (progn
+ (insert mail-header-separator "\n")
+ (1- (point)))
+ 'read-only nil)
(forward-line -1)
(when (message-news-p)
(when message-default-news-headers
(delq 'Lines
(delq 'Subject
(copy-sequence message-required-mail-headers))))))
+ (run-hooks 'message-signature-setup-hook)
(message-insert-signature)
(message-set-auto-save-file-name)
(save-restriction
(defun message-mail (&optional to subject)
"Start editing a mail message to be sent."
(interactive)
- (message-pop-to-buffer "*mail message*")
+ (message-pop-to-buffer (message-buffer-name "mail" to))
(message-setup `((To . ,(or to "")) (Subject . ,(or subject "")))))
;;;###autoload
(defun message-news (&optional newsgroups subject)
"Start editing a news article to be sent."
(interactive)
- (message-pop-to-buffer "*news message*")
+ (message-pop-to-buffer (message-buffer-name "news" nil newsgroups))
(message-setup `((Newsgroups . ,(or newsgroups ""))
(Subject . ,(or subject "")))))
(let ((cur (current-buffer))
from subject date reply-to to cc
references message-id follow-to
+ (inhibit-point-motion-hooks t)
mct never-mct gnus-warning)
(save-restriction
- (narrow-to-region
- (goto-char (point-min))
- (if (search-forward "\n\n" nil t)
- (1- (point))
- (point-max)))
+ (message-narrow-to-head)
;; Allow customizations to have their say.
(if (not wide)
;; This is a regular reply.
(message-set-work-buffer)
(unless never-mct
(insert (or reply-to from "")))
- (insert
- (if (bolp) "" ", ") (or to "")
- (if mct (concat (if (bolp) "" ", ") mct) "")
- (if cc (concat (if (bolp) "" ", ") cc) ""))
+ (insert (if (bolp) "" ", ") (or to ""))
+ (insert (if mct (concat (if (bolp) "" ", ") mct) ""))
+ (insert (if cc (concat (if (bolp) "" ", ") cc) ""))
;; Remove addresses that match `rmail-dont-reply-to-names'.
(insert (prog1 (rmail-dont-reply-to (buffer-string))
(erase-buffer)))
(mapcar
(lambda (addr)
(cons (mail-strip-quoted-names addr) addr))
- (nreverse (mail-parse-comma-list))))
+ (message-tokenize-header (buffer-string))))
(let ((s ccalist))
(while s
(setq ccalist (delq (assoc (car (pop s)) s) ccalist)))))
follow-to)))))
(widen))
- (message-pop-to-buffer "*mail message*")
+ (message-pop-to-buffer (message-buffer-name
+ (if wide "wide reply" "reply") from
+ (if wide to-address nil)))
(setq message-reply-headers
(vector 0 subject from date message-id references 0 0 ""))
(let ((cur (current-buffer))
from subject date reply-to mct
references message-id follow-to
+ (inhibit-point-motion-hooks t)
followup-to distribution newsgroups gnus-warning)
(save-restriction
(narrow-to-region
(setq subject (concat "Re: " subject))
(widen))
- (message-pop-to-buffer "*news message*")
+ (message-pop-to-buffer (message-buffer-name "followup" from newsgroups))
(message-setup
`((Subject . ,subject)
distribution (message-fetch-field "distribution")))
;; Make sure that this article was written by the user.
(unless (string-equal
- (downcase (mail-strip-quoted-names from))
+ (downcase (cadr (mail-extract-address-components from)))
(downcase (message-make-address)))
(error "This article is not yours"))
;; Make control message.
(concat "Distribution: " distribution "\n")
"")
mail-header-separator "\n"
- "This is a cancel message from " from ".\n")
+ message-cancel-message)
(message "Canceling your article...")
(let ((message-syntax-checks 'dont-check-for-anything-just-trust-me))
(funcall message-send-news-function))
(let ((cur (current-buffer)))
;; Check whether the user owns the article that is to be superseded.
(unless (string-equal
- (downcase (mail-strip-quoted-names (message-fetch-field "from")))
- (downcase (mail-strip-quoted-names (message-make-address))))
+ (downcase (cadr (mail-extract-address-components
+ (message-fetch-field "from"))))
+ (downcase (message-make-address)))
(error "This article is not yours"))
;; Get a normal message buffer.
- (message-pop-to-buffer "*supersede message*")
+ (message-pop-to-buffer (message-buffer-name "supersede"))
(insert-buffer-substring cur)
(message-narrow-to-head)
;; Remove unwanted headers.
Optional NEWS will use news to forward instead of mail."
(interactive "P")
(let ((cur (current-buffer))
- (subject (message-make-forward-subject)))
+ (subject (message-make-forward-subject))
+ art-beg)
(if news (message-news nil subject) (message-mail nil subject))
;; Put point where we want it before inserting the forwarded
;; message.
(if message-signature-before-forwarded-message
(goto-char (point-max))
(message-goto-body))
+ ;; Make sure we're at the start of the line.
+ (unless (eolp)
+ (insert "\n"))
;; Narrow to the area we are to insert.
(narrow-to-region (point) (point))
;; Insert the separators and the forwarded buffer.
(insert message-forward-start-separator)
+ (setq art-beg (point))
(insert-buffer-substring cur)
(goto-char (point-max))
(insert message-forward-end-separator)
(set-text-properties (point-min) (point-max) nil)
;; Remove all unwanted headers.
- (goto-char (point-min))
- (forward-line 1)
+ (goto-char art-beg)
(narrow-to-region (point) (if (search-forward "\n\n" nil t)
(1- (point))
(point)))
(interactive)
(let ((cur (current-buffer))
boundary)
- (message-pop-to-buffer "*mail message*")
+ (message-pop-to-buffer (message-buffer-name "bounce"))
(insert-buffer-substring cur)
(undo-boundary)
(message-narrow-to-head)
;; We remove everything before the bounced mail.
(delete-region
(point-min)
- (if (re-search-forward "[^ \t]*:" nil t)
+ (if (re-search-forward "^[^ \n\t]+:" nil t)
(match-beginning 0)
(point)))
(save-restriction
(special-display-regexps nil)
(same-window-buffer-names nil)
(same-window-regexps nil))
- (message-pop-to-buffer "*mail message*"))
+ (message-pop-to-buffer (message-buffer-name "mail" to)))
(message-setup `((To . ,(or to "")) (Subject . ,(or subject "")))))
;;;###autoload
(special-display-regexps nil)
(same-window-buffer-names nil)
(same-window-regexps nil))
- (message-pop-to-buffer "*mail message*"))
+ (message-pop-to-buffer (message-buffer-name "mail" to)))
(message-setup `((To . ,(or to "")) (Subject . ,(or subject "")))))
;;;###autoload
(special-display-regexps nil)
(same-window-buffer-names nil)
(same-window-regexps nil))
- (message-pop-to-buffer "*news message*"))
+ (message-pop-to-buffer (message-buffer-name "news" nil newsgroups)))
(message-setup `((Newsgroups . ,(or newsgroups ""))
(Subject . ,(or subject "")))))
(special-display-regexps nil)
(same-window-buffer-names nil)
(same-window-regexps nil))
- (message-pop-to-buffer "*news message*"))
+ (message-pop-to-buffer (message-buffer-name "news" nil newsgroups)))
(message-setup `((Newsgroups . ,(or newsgroups ""))
(Subject . ,(or subject "")))))
(if (eq (following-char) (char-after (- (point) 2)))
(delete-char -2))))))
+(defalias 'message-exchange-point-and-mark 'exchange-point-and-mark)
+
;; Support for toolbar
(when (string-match "XEmacs\\|Lucid" emacs-version)
- (require 'message-xmas))
+ (require 'messagexmas))
;;; Group name completion.
(message "No matching groups")
(pop-to-buffer "*Completions*")
(buffer-disable-undo (current-buffer))
- (erase-buffer)
- (let ((standard-output (current-buffer)))
- (display-completion-list (sort completions 'string<)))
- (goto-char (point-min))
- (pop-to-buffer cur))))))
+ (let ((buffer-read-only nil))
+ (erase-buffer)
+ (let ((standard-output (current-buffer)))
+ (display-completion-list (sort completions 'string<)))
+ (goto-char (point-min))
+ (pop-to-buffer cur)))))))
;;; Help stuff.
-(defmacro message-y-or-n-p (question show &rest text)
- "Ask QUESTION, displaying the rest of the arguments in a temporary buffer."
- `(message-talkative-question 'y-or-n-p ,question ,show ,@text))
-
(defun message-talkative-question (ask question show &rest text)
"Call FUNCTION with argument QUESTION, displaying the rest of the arguments in a temporary buffer if SHOW.
The following arguments may contain lists of values."
(list
(list list))))
+(run-hooks 'message-load-hook)
+
(provide 'message)
;;; message.el ends here