diff options
Diffstat (limited to 'lisp/mh-e/mh-comp.el')
| -rw-r--r-- | lisp/mh-e/mh-comp.el | 1702 |
1 files changed, 330 insertions, 1372 deletions
diff --git a/lisp/mh-e/mh-comp.el b/lisp/mh-e/mh-comp.el index 984af4e461d..d9ce48a959b 100644 --- a/lisp/mh-e/mh-comp.el +++ b/lisp/mh-e/mh-comp.el @@ -1,4 +1,4 @@ -;;; mh-comp.el --- MH-E functions for composing messages +;;; mh-comp.el --- MH-E functions for composing and sending messages ;; Copyright (C) 1993, 1995, 1997, ;; 2000, 2001, 2002, 2003, 2004, 2005, 2006 Free Software Foundation, Inc. @@ -27,33 +27,23 @@ ;;; Commentary: -;; Internal support for MH-E package. +;; This file includes the functions in the MH-Folder maps that get us +;; into MH-Letter mode, as well the functions in the MH-Letter mode +;; that are used to send the mail. Other that those, functions that +;; are needed in mh-letter.el should be found there. ;;; Change Log: ;;; Code: -;;(message "> mh-comp") -(eval-when-compile (require 'mh-acros)) -(mh-require-cl) - -(require 'easymenu) -(require 'gnus-util) -(require 'mh-buffers) (require 'mh-e) -(require 'mh-gnus) - -(eval-when (compile load eval) - (ignore-errors (require 'mailabbrev))) -;;(message "< mh-comp") - - - -;;; Autoloads +(require 'mh-gnus) ;needed because mh-gnus.el not compiled +(require 'mh-scan) -(autoload 'mail-mode-fill-paragraph "sendmail") -(autoload 'mm-handle-displayed-p "mm-decode") +(require 'sendmail) +(autoload 'easy-menu-add "easymenu") +(autoload 'mml-insert-tag "mml") (autoload 'sc-cite-original "sc" "Workhorse citing function which performs the initial citation. This is callable from the various mail and news readers' reply @@ -80,7 +70,7 @@ before, and `sc-post-hook' is run after the guts of this function.") -;;; Site customization (see also mh-utils.el): +;;; Site Customization (defvar mh-send-prog "send" "Name of the MH send program. @@ -93,26 +83,7 @@ This allows transaction log to be visible if -watch, -verbose or -;;; Scan Line Formats - -(defvar mh-note-repl ?- - "Messages that have been replied to are marked by this character.") - -(defvar mh-note-forw ?F - "Messages that have been forwarded are marked by this character.") - -(defvar mh-note-dist ?R - "Messages that have been redistributed are marked by this character.") - -(defvar mh-yank-hooks nil - "Obsolete hook for modifying a citation just inserted in the mail buffer. - -Each hook function can find the citation between point and mark. -And each hook function should leave point and mark around the -citation text as modified. - -This is a normal hook, misnamed for historical reasons. It is -semi-obsolete and is only used if `mail-citation-hook' is nil.") +;;; Variables (defvar mh-comp-formfile "components" "Name of file to be used as a skeleton for composing messages. @@ -145,7 +116,7 @@ user's MH directory, then in the system MH lib directory.") (regexp-opt '("Content-Type: message/rfc822" ;MIME MDN "------ This is a copy of the message, including all the headers. ------";from exim - "--- Below this line is a copy of the message."; from qmail + "--- Below this line is a copy of the message."; from qmail " ----- Unsent message follows -----" ;from sendmail V5 " --------Unsent Message below:" ; from sendmail at BU " ----- Original message follows -----" ;from sendmail V8 @@ -161,21 +132,6 @@ user's MH directory, then in the system MH lib directory.") "Regexp of header lines to remove before offering a message as a new draft\\<mh-folder-mode-map>. Used by the \\[mh-edit-again] and \\[mh-extract-rejected-mail] commands.") -(defvar mh-to-field-choices '(("a" . "Mail-Reply-To:") - ("b" . "Bcc:") - ("c" . "Cc:") - ("d" . "Dcc:") - ("f" . "Fcc:") - ("l" . "Mail-Followup-To:") - ("m" . "From:") - ("r" . "Reply-To:") - ("s" . "Subject:") - ("t" . "To:")) - "Alist of (final-character . field-name) choices for `mh-to-field'.") - -(defvar mh-letter-mode-map (copy-keymap text-mode-map) - "Keymap for composing mail.") - (defvar mh-letter-mode-syntax-table nil "Syntax table used by MH-E while in MH-Letter mode.") @@ -185,12 +141,6 @@ Used by the \\[mh-edit-again] and \\[mh-extract-rejected-mail] commands.") (make-syntax-table text-mode-syntax-table)) (modify-syntax-entry ?% "." mh-letter-mode-syntax-table)) -(defvar mh-sent-from-folder nil - "Folder of msg assoc with this letter.") - -(defvar mh-sent-from-msg nil - "Number of msg assoc with this letter.") - (defvar mh-send-args nil "Extra args to pass to \"send\" command.") @@ -204,6 +154,10 @@ Used by the \\[mh-edit-again] and \\[mh-extract-rejected-mail] commands.") "Buffer-local variable set when `mh-insert-auto-fields' called successfully.") (make-variable-buffer-local 'mh-insert-auto-fields-done-local) + + +;;; MH-E Entry Points + ;;;###autoload (defun mh-smail () "Compose a message with the MH mail system. @@ -220,6 +174,18 @@ See `mh-send' for more details on composing mail." (mh-find-path) (call-interactively 'mh-send-other-window)) +(defun mh-send-other-window (to cc subject) + "Compose a message in another window. + +See `mh-send' for more information and a description of how the +TO, CC, and SUBJECT arguments are used." + (interactive (list + (mh-interactive-read-address "To: ") + (mh-interactive-read-address "Cc: ") + (mh-interactive-read-string "Subject: "))) + (let ((pop-up-windows t)) + (mh-send-sub to cc subject (current-window-configuration)))) + (defvar mh-error-if-no-draft nil) ;raise error over using old draft ;;;###autoload @@ -271,6 +237,117 @@ ignored." (cdr (car other-headers))) (setq other-headers (cdr other-headers))))) +;; Shush compiler. +(eval-when-compile (mh-do-in-xemacs (defvar sendmail-coding-system))) + +;;;###autoload +(defun mh-send-letter (&optional arg) + "Save draft and send message. + +When you are all through editing a message, you send it with this +command. You can give a prefix argument ARG to monitor the first stage +of the delivery\; this output can be found in a buffer called \"*MH-E +Mail Delivery*\". + +The hook `mh-before-send-letter-hook' is run at the beginning of +this command. For example, if you want to check your spelling in +your message before sending, add the function `ispell-message'. + +In case the MH \"send\" program is installed under a different name, +use `mh-send-prog' to tell MH-E the name." + (interactive "P") + (run-hooks 'mh-before-send-letter-hook) + (if (and (mh-insert-auto-fields t) + mh-auto-fields-prompt-flag + (goto-char (point-min))) + (if (not (y-or-n-p "Auto fields inserted, send? ")) + (error "Send aborted"))) + (cond ((mh-mh-directive-present-p) + (mh-mh-to-mime)) + ((or (mh-mml-tag-present-p) (not (mh-ascii-buffer-p))) + (mh-mml-to-mime))) + (save-buffer) + (message "Sending...") + (let ((draft-buffer (current-buffer)) + (file-name buffer-file-name) + (config mh-previous-window-config) + (coding-system-for-write + (if (and (local-variable-p 'buffer-file-coding-system + (current-buffer)) ;XEmacs needs two args + ;; We're not sure why, but buffer-file-coding-system + ;; tends to get set to undecided-unix. + (not (memq buffer-file-coding-system + '(undecided undecided-unix undecided-dos)))) + buffer-file-coding-system + (or (and (boundp 'sendmail-coding-system) sendmail-coding-system) + (and (boundp 'default-buffer-file-coding-system ) + default-buffer-file-coding-system) + 'iso-latin-1)))) + ;; Adding a Message-ID field looks good, makes it easier to search for + ;; message in your +outbox, and best of all doesn't break threading for + ;; the recipient if you reply to a message in your +outbox. + (setq mh-send-args (concat "-msgid " mh-send-args)) + ;; The default BCC encapsulation will make a MIME message unreadable. + ;; With nmh use the -mime arg to prevent this. + (if (and (mh-variant-p 'nmh) + (mh-goto-header-field "Bcc:") + (mh-goto-header-field "Content-Type:")) + (setq mh-send-args (concat "-mime " mh-send-args))) + (cond (arg + (pop-to-buffer mh-mail-delivery-buffer) + (erase-buffer) + (mh-exec-cmd-output mh-send-prog t "-watch" "-nopush" + "-nodraftfolder" mh-send-args file-name) + (goto-char (point-max)) ; show the interesting part + (recenter -1) + (set-buffer draft-buffer)) ; for annotation below + (t + (mh-exec-cmd-daemon mh-send-prog nil "-nodraftfolder" "-noverbose" + mh-send-args file-name))) + (if mh-annotate-char + (mh-annotate-msg mh-sent-from-msg + mh-sent-from-folder + mh-annotate-char + "-component" mh-annotate-field + "-text" (format "\"%s %s\"" + (mh-get-header-field "To:") + (mh-get-header-field "Cc:")))) + + (cond ((or (not arg) + (y-or-n-p "Kill draft buffer? ")) + (kill-buffer draft-buffer) + (if config + (set-window-configuration config)))) + (if arg + (message "Sending...done") + (message "Sending...backgrounded")))) + +;;;###autoload +(defun mh-fully-kill-draft () + "Quit editing and delete draft message. + +If for some reason you are not happy with the draft, you can use +this command to kill the draft buffer and delete the draft +message. Use the command \\[kill-buffer] if you don't want to +delete the draft message." + (interactive) + (if (y-or-n-p "Kill draft message? ") + (let ((config mh-previous-window-config)) + (if (file-exists-p buffer-file-name) + (delete-file buffer-file-name)) + (set-buffer-modified-p nil) + (kill-buffer (buffer-name)) + (message "") + (if config + (set-window-configuration config))) + (error "Message not killed"))) + + + +;;; MH-Folder Commands + +;; Alphabetical. + ;;;###mh-autoload (defun mh-edit-again (message) "Edit a MESSAGE to send it again. @@ -509,32 +586,6 @@ See also `mh-redist-full-contents-flag'." (kill-buffer draft) (message "Redistributing...done")))) -(defun mh-show-buffer-message-number (&optional buffer) - "Message number of displayed message in corresponding show buffer. - -Return nil if show buffer not displayed. -If in `mh-letter-mode', don't display the message number being replied -to, but rather the message number of the show buffer associated with -our originating folder buffer. -Optional argument BUFFER can be used to specify the buffer." - (save-excursion - (if buffer - (set-buffer buffer)) - (cond ((eq major-mode 'mh-show-mode) - (let ((number-start (mh-search-from-end ?/ buffer-file-name))) - (string-to-number (substring buffer-file-name - (1+ number-start))))) - ((and (eq major-mode 'mh-folder-mode) - mh-show-buffer - (get-buffer mh-show-buffer)) - (mh-show-buffer-message-number mh-show-buffer)) - ((and (eq major-mode 'mh-letter-mode) - mh-sent-from-folder - (get-buffer mh-sent-from-folder)) - (mh-show-buffer-message-number mh-sent-from-folder)) - (t - nil)))) - ;;;###mh-autoload (defun mh-reply (message &optional reply-to includep) "Reply to a MESSAGE. @@ -667,18 +718,50 @@ message." (delete-other-windows) (mh-send-sub to cc subject config))) + + +;;; Support Routines + +(defun mh-interactive-read-address (prompt) + "Read an address. +If `mh-compose-prompt-flag' is non-nil, then read an address with +PROMPT. +Otherwise return the empty string." + (if mh-compose-prompt-flag (mh-read-address prompt) "")) + +(defun mh-interactive-read-string (prompt) + "Read a string. +If `mh-compose-prompt-flag' is non-nil, then read a string with +PROMPT. +Otherwise return the empty string." + (if mh-compose-prompt-flag (read-string prompt) "")) + ;;;###mh-autoload -(defun mh-send-other-window (to cc subject) - "Compose a message in another window. +(defun mh-show-buffer-message-number (&optional buffer) + "Message number of displayed message in corresponding show buffer. -See `mh-send' for more information and a description of how the -TO, CC, and SUBJECT arguments are used." - (interactive (list - (mh-interactive-read-address "To: ") - (mh-interactive-read-address "Cc: ") - (mh-interactive-read-string "Subject: "))) - (let ((pop-up-windows t)) - (mh-send-sub to cc subject (current-window-configuration)))) +Return nil if show buffer not displayed. +If in `mh-letter-mode', don't display the message number being replied +to, but rather the message number of the show buffer associated with +our originating folder buffer. +Optional argument BUFFER can be used to specify the buffer." + (save-excursion + (if buffer + (set-buffer buffer)) + (cond ((eq major-mode 'mh-show-mode) + (let ((number-start (mh-search-from-end ?/ buffer-file-name))) + (string-to-number (substring buffer-file-name + (1+ number-start))))) + ((and (eq major-mode 'mh-folder-mode) + mh-show-buffer + (get-buffer mh-show-buffer)) + (mh-show-buffer-message-number mh-show-buffer)) + ((and (eq major-mode 'mh-letter-mode) + mh-sent-from-folder + (get-buffer mh-sent-from-folder)) + (mh-show-buffer-message-number mh-sent-from-folder)) + (t + nil)))) (defun mh-send-sub (to cc subject config) "Do the real work of composing and sending a letter. @@ -777,19 +860,6 @@ then be reused." (mh-exec-cmd-quiet t "mhpath" mh-draft-folder "new") (buffer-substring (point-min) (1- (point-max))))) -(defun mh-annotate-msg (msg buffer note &rest args) - "Mark MSG in BUFFER with character NOTE and annotate message with ARGS. -MSG can be a message number, a list of message numbers, or a -sequence." - (apply 'mh-exec-cmd "anno" buffer - (if (listp msg) (append msg args) (cons msg args))) - (save-excursion - (cond ((get-buffer buffer) ; Buffer may be deleted - (set-buffer buffer) - (mh-iterate-on-range nil msg - (mh-notate nil note - (+ mh-cmd-note mh-scan-field-destination-offset))))))) - (defun mh-insert-fields (&rest name-values) "Insert the NAME-VALUES pairs in the current buffer. If the field exists, append the value to it. @@ -808,459 +878,56 @@ Do not insert any pairs whose value is the empty string." (insert field-name " " value "\n"))) (setq name-values (cdr (cdr name-values))))))) -(defun mh-position-on-field (field &optional ignored) - "Move to the end of the FIELD in the header. -Move to end of entire header if FIELD not found. -Returns non-nil iff FIELD was found. -The optional second arg is for pre-version 4 compatibility and is -IGNORED." - (cond ((mh-goto-header-field field) - (mh-header-field-end) - t) - ((mh-goto-header-end 0) - nil))) - -;;;###mh-autoload -(defun mh-get-header-field (field) - "Find and return the body of FIELD in the mail header. -Returns the empty string if the field is not in the header of the -current buffer." - (if (mh-goto-header-field field) - (progn - (skip-chars-forward " \t") ;strip leading white space in body - (let ((start (point))) - (mh-header-field-end) - (buffer-substring-no-properties start (point)))) - "")) - -(fset 'mh-get-field 'mh-get-header-field) ;MH-E 4 compatibility - -(defun mh-goto-header-field (field) - "Move to FIELD in the message header. -Move to the end of the FIELD name, which should end in a colon. -Returns t if found, nil if not." - (goto-char (point-min)) - (let ((case-fold-search t) - (headers-end (save-excursion - (mh-goto-header-end 0) - (point)))) - (re-search-forward (format "^%s" field) headers-end t))) - -(defun mh-goto-header-end (arg) - "Move the cursor ARG lines after the header." - (if (re-search-forward "^-*$" nil nil) - (forward-line arg))) - -(defun mh-extract-from-header-value () - "Extract From: string from header." - (save-excursion - (if (not (mh-goto-header-field "From:")) - nil - (skip-chars-forward " \t") - (buffer-substring-no-properties - (point) (progn (mh-header-field-end)(point)))))) - - - -;;; Mode for composing and sending a draft message. - -(defvar mh-pgp-support-flag (not (not (locate-library "mml2015"))) - "Non-nil means PGP support is available.") - -(put 'mh-letter-mode 'mode-class 'special) - -;; Menu extracted from mh-menubar.el V1.1 (31 July 2001) -(eval-when-compile (defvar mh-letter-menu nil)) -(easy-menu-define - mh-letter-menu mh-letter-mode-map "Menu for MH-E letter mode." - '("Letter" - ["Send This Draft" mh-send-letter t] - ["Split Current Line" mh-open-line t] - ["Check Recipient" mh-check-whom t] - ["Yank Current Message" mh-yank-cur-msg t] - ["Insert a Message..." mh-insert-letter t] - ["Insert Signature" mh-insert-signature t] - ("Encrypt/Sign Message" - ["Sign Message" - mh-mml-secure-message-sign mh-pgp-support-flag] - ["Encrypt Message" - mh-mml-secure-message-encrypt mh-pgp-support-flag] - ["Sign+Encrypt Message" - mh-mml-secure-message-signencrypt mh-pgp-support-flag] - ["Disable Security" - mh-mml-unsecure-message mh-pgp-support-flag] - "--" - "Security Method" - ["PGP (MIME)" (setq mh-mml-method-default "pgpmime") - :style radio - :selected (equal mh-mml-method-default "pgpmime")] - ["PGP" (setq mh-mml-method-default "pgp") - :style radio - :selected (equal mh-mml-method-default "pgp")] - ["S/MIME" (setq mh-mml-method-default "smime") - :style radio - :selected (equal mh-mml-method-default "smime")] - "--" - ["Save Method as Default" - (customize-save-variable 'mh-mml-method-default mh-mml-method-default) t] - ) - ["Compose Insertion..." mh-compose-insertion t] - ["Compose Compressed tar (MH)..." - mh-mh-compose-external-compressed-tar t] - ["Compose Get File (MH)..." mh-mh-compose-anon-ftp t] - ["Compose Forward..." mh-compose-forward t] - ;; The next two will have to be merged. But I also need to make sure the - ;; user can't mix tags of both types. - ["Pull in All Compositions (MH)" - mh-mh-to-mime (mh-mh-directive-present-p)] - ["Pull in All Compositions (MML)" - mh-mml-to-mime (mh-mml-tag-present-p)] - ["Revert to Non-MIME Edit (MH)" - mh-mh-to-mime-undo (equal mh-compose-insertion 'mh)] - ["Kill This Draft" mh-fully-kill-draft t])) - - - -;;; Help Messages - -;; Group messages logically, more or less. -(defvar mh-letter-mode-help-messages - '((nil - "Send letter: \\[mh-send-letter]" - "\t\tOpen line: \\[mh-open-line]\n" - "Kill letter: \\[mh-fully-kill-draft]" - "\t\tInsert:\n" - "Check recipients: \\[mh-check-whom]" - "\t\t Current message: \\[mh-yank-cur-msg]\n" - "\t\t Attachment: \\[mh-compose-insertion]\n" - "\t\t Message to forward: \\[mh-compose-forward]\n" - " " - "Security:" - "\t\t Encrypt message: \\[mh-mml-secure-message-encrypt]" - "\t\t Sign+Encrypt message: \\[mh-mml-secure-message-signencrypt]" - "\t\t Sign message: \\[mh-mml-secure-message-sign]\n" - " " - "\t\t Signature: \\[mh-insert-signature]")) - "Key binding cheat sheet. - -This is an associative array which is used to show the most -common commands. The key is a prefix char. The value is one or -more strings which are concatenated together and displayed in the -minibuffer if ? is pressed after the prefix character. The -special key nil is used to display the non-prefixed commands. - -The substitutions described in `substitute-command-keys' are -performed as well.") - -;; Shush compiler. -(eval-when-compile - (defvar adaptive-fill-first-line-regexp) - (defvar tool-bar-map)) - -(defvar mh-letter-buttons-init-flag nil) - -;;;###autoload -(define-derived-mode mh-letter-mode mail-mode "MH-Letter" - "Mode for composing letters in MH-E\\<mh-letter-mode-map>. - -When you have finished composing, type \\[mh-send-letter] to send -the message using the MH mail handling system. - -There are two types of tags used by MH-E when composing MIME -messages: MML and MH. The option `mh-compose-insertion' controls -what type of tags are inserted by MH-E commands. These tags can -be converted to MIME body parts by running \\[mh-mh-to-mime] for -MH-style directives or \\[mh-mml-to-mime] for MML tags. - -Options that control this mode can be changed with -\\[customize-group]; specify the \"mh-compose\" group. - -When a message is composed, the hooks `text-mode-hook', -`mail-mode-hook', and `mh-letter-mode-hook' are run (in that -order). - -\\{mh-letter-mode-map}" - (mh-find-path) - (make-local-variable 'mh-send-args) - (make-local-variable 'mh-annotate-char) - (make-local-variable 'mh-annotate-field) - (make-local-variable 'mh-previous-window-config) - (make-local-variable 'mh-sent-from-folder) - (make-local-variable 'mh-sent-from-msg) - (mh-do-in-gnu-emacs - (unless mh-letter-buttons-init-flag - (mh-tool-bar-letter-buttons-init) - (setq mh-letter-buttons-init-flag t))) - ;; Set the local value of mh-mail-header-separator according to what is - ;; present in the buffer... - (set (make-local-variable 'mh-mail-header-separator) - (save-excursion - (goto-char (mh-mail-header-end)) - (buffer-substring-no-properties (point) (line-end-position)))) - (make-local-variable 'mail-header-separator) - (setq mail-header-separator mh-mail-header-separator) ;override sendmail.el - (make-local-variable 'mh-help-messages) - (setq mh-help-messages mh-letter-mode-help-messages) - (setq buffer-invisibility-spec '((vanish . t) t)) - (set (make-local-variable 'line-move-ignore-invisible) t) - - ;; Enable undo since a show-mode buffer might have been reused. - (buffer-enable-undo) - (set (make-local-variable 'tool-bar-map) mh-letter-tool-bar-map) - (mh-funcall-if-exists mh-tool-bar-init :letter) - (make-local-variable 'font-lock-defaults) - (cond - ((or (equal mh-highlight-citation-style 'font-lock) - (equal mh-highlight-citation-style 'gnus)) - ;; Let's use font-lock even if gnus is used in show-mode. The reason - ;; is that gnus uses static text properties which are not appropriate - ;; for a buffer that will be edited. So the choice here is either fontify - ;; the citations and header... - (setq font-lock-defaults '(mh-letter-font-lock-keywords t))) - (t - ;; ...or the header only - (setq font-lock-defaults '(mh-show-font-lock-keywords t)))) - (easy-menu-add mh-letter-menu) - (setq fill-column mh-letter-fill-column) - ;; If text-mode-hook turned on auto-fill, tune it for messages - (when auto-fill-function - (make-local-variable 'auto-fill-function) - (setq auto-fill-function 'mh-auto-fill-for-letter))) - -(defun mh-font-lock-field-data (limit) - "Find header field region between point and LIMIT." - (and (< (point) (mh-letter-header-end)) - (< (point) limit) - (let ((end (min limit (mh-letter-header-end))) - (point (point)) - data-end data-begin field) - (end-of-line) - (setq data-end (if (re-search-forward "^[^ \t]" end t) - (match-beginning 0) - end)) - (goto-char (1- data-end)) - (if (not (re-search-backward "\\(^[^ \t][^:]*\\):[ \t]*" nil t)) - (setq data-begin (point-min)) - (setq data-begin (match-end 0)) - (setq field (match-string 1))) - (setq data-begin (max point data-begin)) - (goto-char (if (equal point data-end) (1+ data-end) data-end)) - (cond ((and field (mh-letter-skipped-header-field-p field)) - (set-match-data nil) - nil) - (t (set-match-data - (list data-begin data-end data-begin data-end)) - t))))) - -(defun mh-letter-header-end () - "Find the end of the message header. -This function is to be used only for font locking. It works by -searching for `mh-mail-header-separator' in the buffer." - (save-excursion - (goto-char (point-min)) - (cond ((equal mh-mail-header-separator "") (point-min)) - ((search-forward (format "\n%s\n" mh-mail-header-separator) nil t) - (line-beginning-position 0)) - (t (point-min))))) - -(defun mh-auto-fill-for-letter () - "Perform auto-fill for message. -Header is treated specially by inserting a tab before continuation -lines." - (if (mh-in-header-p) - (let ((fill-prefix "\t")) - (do-auto-fill)) - (do-auto-fill))) - -(defun mh-insert-header-separator () - "Insert `mh-mail-header-separator', if absent." - (save-excursion - (goto-char (point-min)) - (rfc822-goto-eoh) - (if (looking-at "$") - (insert mh-mail-header-separator)))) - -;;;###mh-autoload -(defun mh-to-field () - "Move to specified header field. - -The field is indicated by the previous keystroke (the last -keystroke of the command) according to the list in the variable -`mh-to-field-choices'. -Create the field if it does not exist. -Set the mark to point before moving." - (interactive) - (expand-abbrev) - (let ((target (cdr (or (assoc (char-to-string (logior last-input-char ?`)) - mh-to-field-choices) - ;; also look for a char for version 4 compat - (assoc (logior last-input-char ?`) - mh-to-field-choices)))) - (case-fold-search t)) - (push-mark) - (cond ((mh-position-on-field target) - (let ((eol (point))) - (skip-chars-backward " \t") - (delete-region (point) eol)) - (if (and (not (eq (logior last-input-char ?`) ?s)) - (save-excursion - (backward-char 1) - (not (looking-at "[:,]")))) - (insert ", ") - (insert " "))) - (t - (if (mh-position-on-field "To:") - (forward-line 1)) - (insert (format "%s \n" target)) - (backward-char 1))))) - -;;;###mh-autoload -(defun mh-to-fcc (&optional folder) - "Move to \"Fcc:\" header field. - -This command will prompt you for the FOLDER name in which to file -a copy of the draft." - (interactive (list (mh-prompt-for-folder - "Fcc" - (or (and mh-default-folder-for-message-function - (save-excursion - (goto-char (point-min)) - (funcall - mh-default-folder-for-message-function))) - "") - t))) - (let ((last-input-char ?\C-f)) - (expand-abbrev) - (save-excursion - (mh-to-field) - (insert (if (mh-folder-name-p folder) - (substring folder 1) - folder))))) - -(defun mh-file-is-vcard-p (file) - "Return t if FILE is a .vcf vcard." - (let ((case-fold-search t)) - (and (stringp file) - (file-exists-p file) - (or (and (not (mh-have-file-command)) - (not (null (string-match "\.vcf$" file)))) - (string-equal "text/x-vcard" (mh-file-mime-type file)))))) - -;;;###mh-autoload -(defun mh-insert-signature (&optional file) - "Insert signature in message. - -This command inserts your signature at the current cursor location. - -By default, the text of your signature is taken from the file -\"~/.signature\". You can read from other sources by changing the -option `mh-signature-file-name'. - -A signature separator (\"-- \") will be added if the signature block -does not contain one and `mh-signature-separator-flag' is on. - -The hook `mh-insert-signature-hook' is run after the signature is -inserted. Hook functions may access the actual name of the file or the -function used to insert the signature with `mh-signature-file-name'. - -The signature can also be inserted using Identities (see -`mh-identity-list'). - -In a program, you can pass in a signature FILE." - (interactive) - (save-excursion - (insert "\n") - (let ((mh-signature-file-name (or file mh-signature-file-name)) - (mh-mh-p (mh-mh-directive-present-p)) - (mh-mml-p (mh-mml-tag-present-p))) - (save-restriction - (narrow-to-region (point) (point)) - (cond - ((mh-file-is-vcard-p mh-signature-file-name) - (if (equal mh-compose-insertion 'mml) - (insert "<#part type=\"text/x-vcard\" filename=\"" - mh-signature-file-name - "\" disposition=inline description=VCard>\n<#/part>") - (insert "#text/x-vcard; name=\"" - (file-name-nondirectory mh-signature-file-name) - "\" [VCard] " (expand-file-name mh-signature-file-name)))) - (t - (cond - (mh-mh-p - (insert "#\n" "Content-Description: Signature\n")) - (mh-mml-p - (mml-insert-tag 'part 'type "text/plain" 'disposition "inline" - 'description "Signature"))) - (cond ((null mh-signature-file-name)) - ((and (stringp mh-signature-file-name) - (file-readable-p mh-signature-file-name)) - (insert-file-contents mh-signature-file-name)) - ((functionp mh-signature-file-name) - (funcall mh-signature-file-name))))) - (save-restriction - (widen) - (run-hooks 'mh-insert-signature-hook)) - (goto-char (point-min)) - (when (and (not (mh-file-is-vcard-p mh-signature-file-name)) - mh-signature-separator-flag - (> (point-max) (point-min)) - (not (mh-signature-separator-p))) - (cond (mh-mh-p - (forward-line 2)) - (mh-mml-p - (forward-line 1))) - (insert mh-signature-separator)) - (if (not (> (point-max) (point-min))) - (message "No signature found"))))) - (force-mode-line-update)) - -;;;###mh-autoload -(defun mh-check-whom () - "Verify recipients, showing expansion of any aliases. - -This command expands aliases so you can check the actual address(es) -in the alias. A new buffer named \"*MH-E Recipients*\" is created with -the output of \"whom\"." - (interactive) - (let ((file-name buffer-file-name)) - (save-buffer) - (message "Checking recipients...") - (mh-in-show-buffer (mh-recipients-buffer) - (bury-buffer (current-buffer)) - (erase-buffer) - (mh-exec-cmd-output "whom" t file-name)) - (message "Checking recipients...done"))) - -(defun mh-tidy-draft-buffer () - "Run when a draft buffer is destroyed." - (let ((buffer (get-buffer mh-recipients-buffer))) - (if buffer - (kill-buffer buffer)))) +(defun mh-compose-and-send-mail (draft send-args + sent-from-folder sent-from-msg + to subject cc + annotate-char annotate-field + config) + "Edit and compose a draft message in buffer DRAFT and send or save it. +SEND-ARGS is the argument passed to the send command. +SENT-FROM-FOLDER is buffer containing scan listing of current folder, +or nil if none exists. +SENT-FROM-MSG is the message number or sequence name or nil. +The TO, SUBJECT, and CC fields are passed to the +`mh-compose-letter-function'. +If ANNOTATE-CHAR is non-null, it is used to notate the scan listing of +the message. In that case, the ANNOTATE-FIELD is used to build a +string for `mh-annotate-msg'. +CONFIG is the window configuration to restore after sending the +letter." + (pop-to-buffer draft) + (mh-letter-mode) - + ;; Insert identity. + (mh-insert-identity mh-identity-default t) + (mh-identity-make-menu) + (mh-identity-add-menu) -;;; Routines to compose and send a letter. + ;; Insert extra fields. + (mh-insert-x-mailer) + (mh-insert-x-face) -(defun mh-insert-x-face () - "Append X-Face, Face or X-Image-URL field to header. -If the field already exists, this function does nothing." - (when (and (file-exists-p mh-x-face-file) - (file-readable-p mh-x-face-file)) - (save-excursion - (unless (or (mh-position-on-field "X-Face") - (mh-position-on-field "Face") - (mh-position-on-field "X-Image-URL")) - (save-excursion - (goto-char (+ (point) (cadr (insert-file-contents mh-x-face-file)))) - (if (not (looking-at "^")) - (insert "\n"))) - (unless (looking-at "\\(X-Face\\|Face\\|X-Image-URL\\): ") - (insert "X-Face: ")))))) + (mh-letter-hide-all-skipped-fields) -(defvar mh-x-mailer-string nil - "*String containing the contents of the X-Mailer header field. -If nil, this variable is initialized to show the version of MH-E, -Emacs, and MH the first time a message is composed.") + (setq mh-sent-from-folder sent-from-folder) + (setq mh-sent-from-msg sent-from-msg) + (setq mh-send-args send-args) + (setq mh-annotate-char annotate-char) + (setq mh-annotate-field annotate-field) + (setq mh-previous-window-config config) + (setq mode-line-buffer-identification (list " {%b}")) + (mh-logo-display) + (mh-make-local-hook 'kill-buffer-hook) + (add-hook 'kill-buffer-hook 'mh-tidy-draft-buffer nil t) + (if (and (boundp 'mh-compose-letter-function) + mh-compose-letter-function) + ;; run-hooks will not pass arguments. + (let ((value mh-compose-letter-function)) + (if (and (listp value) (not (eq (car value) 'lambda))) + (while value + (funcall (car value) to subject cc) + (setq value (cdr value))) + (funcall mh-compose-letter-function to subject cc))))) (defun mh-insert-x-mailer () "Append an X-Mailer field to the header. @@ -1283,20 +950,89 @@ The versions of MH-E, Emacs, and MH are shown." (null (mh-goto-header-field "X-Mailer"))) (mh-insert-fields "X-Mailer:" mh-x-mailer-string)))) -(defun mh-regexp-in-field-p (regexp &rest fields) - "Non-nil means REGEXP was found in FIELDS." +(defun mh-insert-x-face () + "Append X-Face, Face or X-Image-URL field to header. +If the field already exists, this function does nothing." + (when (and (file-exists-p mh-x-face-file) + (file-readable-p mh-x-face-file)) + (save-excursion + (unless (or (mh-position-on-field "X-Face") + (mh-position-on-field "Face") + (mh-position-on-field "X-Image-URL")) + (save-excursion + (goto-char (+ (point) (cadr (insert-file-contents mh-x-face-file)))) + (if (not (looking-at "^")) + (insert "\n"))) + (unless (looking-at "\\(X-Face\\|Face\\|X-Image-URL\\): ") + (insert "X-Face: ")))))) + +;;;###mh-autoload +(defun mh-letter-hide-all-skipped-fields () + "Hide all skipped fields." (save-excursion - (let ((search-result nil) - (field)) - (while fields - (setq field (car fields)) - (if (and (mh-goto-header-field field) - (re-search-forward - regexp (save-excursion (mh-header-field-end)(point)) t)) - (setq fields nil - search-result t) - (setq fields (cdr fields)))) - search-result))) + (goto-char (point-min)) + (save-restriction + (narrow-to-region (point) (mh-mail-header-end)) + (while (re-search-forward mh-letter-header-field-regexp nil t) + (if (mh-letter-skipped-header-field-p (match-string 1)) + (mh-letter-toggle-header-field-display -1) + (mh-letter-toggle-header-field-display 'long)) + (beginning-of-line 2))))) + +(defun mh-tidy-draft-buffer () + "Run when a draft buffer is destroyed." + (let ((buffer (get-buffer mh-recipients-buffer))) + (if buffer + (kill-buffer buffer)))) + +(defun mh-letter-mode-message () + "Display a help message for users of `mh-letter-mode'. +This should be the last function called when composing the draft." + (message "%s" (substitute-command-keys + (concat "Type \\[mh-send-letter] to send message, " + "\\[mh-help] for help")))) + +(defun mh-letter-adjust-point () + "Move cursor to first header field if are using the no prompt mode." + (unless mh-compose-prompt-flag + (goto-char (point-max)) + (mh-letter-next-header-field))) + +(defun mh-annotate-msg (msg buffer note &rest args) + "Mark MSG in BUFFER with character NOTE and annotate message with ARGS. +MSG can be a message number, a list of message numbers, or a +sequence." + (apply 'mh-exec-cmd "anno" buffer + (if (listp msg) (append msg args) (cons msg args))) + (save-excursion + (cond ((get-buffer buffer) ; Buffer may be deleted + (set-buffer buffer) + (mh-iterate-on-range nil msg + (mh-notate nil note + (+ mh-cmd-note mh-scan-field-destination-offset))))))) + +;;;###mh-autoload +(defun mh-get-header-field (field) + "Find and return the body of FIELD in the mail header. +Returns the empty string if the field is not in the header of the +current buffer." + (if (mh-goto-header-field field) + (progn + (skip-chars-forward " \t") ;strip leading white space in body + (let ((start (point))) + (mh-header-field-end) + (buffer-substring-no-properties start (point)))) + "")) + +(fset 'mh-get-field 'mh-get-header-field) ;MH-E 4 compatibility + +(defun mh-insert-header-separator () + "Insert `mh-mail-header-separator', if absent." + (save-excursion + (goto-char (point-min)) + (rfc822-goto-eoh) + (if (looking-at "$") + (insert mh-mail-header-separator)))) ;;;###mh-autoload (defun mh-insert-auto-fields (&optional non-interactive) @@ -1332,12 +1068,13 @@ Return t if fields added; otherwise return nil." (value (cdar entry-list))) (cond ((equal ":identity" field) - (when ;;(and (not mh-identity-local) + (when + ;;(and (not mh-identity-local) ;; Bug 1204506. But do we need to be able - ;; to set an identity manually that won't be - ;; overridden by mh-insert-auto-fields? - (assoc value mh-identity-list) - ;;) + ;; to set an identity manually that won't be + ;; overridden by mh-insert-auto-fields? + (assoc value mh-identity-list) + ;;) (mh-insert-identity value))) (t (mh-modify-header-field field value @@ -1365,66 +1102,20 @@ discarded." (mh-goto-header-end 0) (insert field ": " value "\n")))) -(defun mh-compose-and-send-mail (draft send-args - sent-from-folder sent-from-msg - to subject cc - annotate-char annotate-field - config) - "Edit and compose a draft message in buffer DRAFT and send or save it. -SEND-ARGS is the argument passed to the send command. -SENT-FROM-FOLDER is buffer containing scan listing of current folder, -or nil if none exists. -SENT-FROM-MSG is the message number or sequence name or nil. -The TO, SUBJECT, and CC fields are passed to the -`mh-compose-letter-function'. -If ANNOTATE-CHAR is non-null, it is used to notate the scan listing of -the message. In that case, the ANNOTATE-FIELD is used to build a -string for `mh-annotate-msg'. -CONFIG is the window configuration to restore after sending the -letter." - (pop-to-buffer draft) - (mh-letter-mode) - - ;; Insert identity. - (if (and (boundp 'mh-identity-default) - mh-identity-default - (not mh-identity-local)) - (mh-insert-identity mh-identity-default)) - (mh-identity-make-menu) - (easy-menu-add mh-identity-menu) - - ;; Insert extra fields. - (mh-insert-x-mailer) - (mh-insert-x-face) - - (mh-letter-hide-all-skipped-fields) - - (setq mh-sent-from-folder sent-from-folder) - (setq mh-sent-from-msg sent-from-msg) - (setq mh-send-args send-args) - (setq mh-annotate-char annotate-char) - (setq mh-annotate-field annotate-field) - (setq mh-previous-window-config config) - (setq mode-line-buffer-identification (list " {%b}")) - (mh-logo-display) - (mh-make-local-hook 'kill-buffer-hook) - (add-hook 'kill-buffer-hook 'mh-tidy-draft-buffer nil t) - (if (and (boundp 'mh-compose-letter-function) - mh-compose-letter-function) - ;; run-hooks will not pass arguments. - (let ((value mh-compose-letter-function)) - (if (and (listp value) (not (eq (car value) 'lambda))) - (while value - (funcall (car value) to subject cc) - (setq value (cdr value))) - (funcall mh-compose-letter-function to subject cc))))) - -(defun mh-letter-mode-message () - "Display a help message for users of `mh-letter-mode'. -This should be the last function called when composing the draft." - (message "%s" (substitute-command-keys - (concat "Type \\[mh-send-letter] to send message, " - "\\[mh-help] for help")))) +(defun mh-regexp-in-field-p (regexp &rest fields) + "Non-nil means REGEXP was found in FIELDS." + (save-excursion + (let ((search-result nil) + (field)) + (while fields + (setq field (car fields)) + (if (and (mh-goto-header-field field) + (re-search-forward + regexp (save-excursion (mh-header-field-end)(point)) t)) + (setq fields nil + search-result t) + (setq fields (cdr fields)))) + search-result))) (defun mh-ascii-buffer-p () "Check if current buffer is entirely composed of ASCII. @@ -1435,739 +1126,6 @@ doesn't exist there." unless (eq charset 'ascii) return nil finally return t)) -;; Shush compiler. -(eval-when-compile (defvar sendmail-coding-system)) - -;;;###mh-autoload -(defun mh-send-letter (&optional arg) - "Save draft and send message. - -When you are all through editing a message, you send it with this -command. You can give a prefix argument ARG to monitor the first stage -of the delivery\; this output can be found in a buffer called \"*MH-E -Mail Delivery*\". - -The hook `mh-before-send-letter-hook' is run at the beginning of -this command. For example, if you want to check your spelling in -your message before sending, add the function `ispell-message'. - -In case the MH \"send\" program is installed under a different name, -use `mh-send-prog' to tell MH-E the name." - (interactive "P") - (run-hooks 'mh-before-send-letter-hook) - (if (and (mh-insert-auto-fields t) - mh-auto-fields-prompt-flag - (goto-char (point-min))) - (if (not (y-or-n-p "Auto fields inserted, send? ")) - (error "Send aborted"))) - (cond ((mh-mh-directive-present-p) - (mh-mh-to-mime)) - ((or (mh-mml-tag-present-p) (not (mh-ascii-buffer-p))) - (mh-mml-to-mime))) - (save-buffer) - (message "Sending...") - (let ((draft-buffer (current-buffer)) - (file-name buffer-file-name) - (config mh-previous-window-config) - (coding-system-for-write - (if (and (local-variable-p 'buffer-file-coding-system - (current-buffer)) ;XEmacs needs two args - ;; We're not sure why, but buffer-file-coding-system - ;; tends to get set to undecided-unix. - (not (memq buffer-file-coding-system - '(undecided undecided-unix undecided-dos)))) - buffer-file-coding-system - (or (and (boundp 'sendmail-coding-system) sendmail-coding-system) - (and (boundp 'default-buffer-file-coding-system ) - default-buffer-file-coding-system) - 'iso-latin-1)))) - ;; Adding a Message-ID field looks good, makes it easier to search for - ;; message in your +outbox, and best of all doesn't break threading for - ;; the recipient if you reply to a message in your +outbox. - (setq mh-send-args (concat "-msgid " mh-send-args)) - ;; The default BCC encapsulation will make a MIME message unreadable. - ;; With nmh use the -mime arg to prevent this. - (if (and (mh-variant-p 'nmh) - (mh-goto-header-field "Bcc:") - (mh-goto-header-field "Content-Type:")) - (setq mh-send-args (concat "-mime " mh-send-args))) - (cond (arg - (pop-to-buffer mh-mail-delivery-buffer) - (erase-buffer) - (mh-exec-cmd-output mh-send-prog t "-watch" "-nopush" - "-nodraftfolder" mh-send-args file-name) - (goto-char (point-max)) ; show the interesting part - (recenter -1) - (set-buffer draft-buffer)) ; for annotation below - (t - (mh-exec-cmd-daemon mh-send-prog nil "-nodraftfolder" "-noverbose" - mh-send-args file-name))) - (if mh-annotate-char - (mh-annotate-msg mh-sent-from-msg - mh-sent-from-folder - mh-annotate-char - "-component" mh-annotate-field - "-text" (format "\"%s %s\"" - (mh-get-header-field "To:") - (mh-get-header-field "Cc:")))) - - (cond ((or (not arg) - (y-or-n-p "Kill draft buffer? ")) - (kill-buffer draft-buffer) - (if config - (set-window-configuration config)))) - (if arg - (message "Sending...done") - (message "Sending...backgrounded")))) - -;;;###mh-autoload -(defun mh-insert-letter (folder message verbatim) - "Insert a message. - -This command prompts you for the FOLDER and MESSAGE number, which -defaults to the current message in that folder. It then inserts -the message, indented by `mh-ins-buf-prefix' (\"> \") unless -`mh-yank-behavior' is set to one of the supercite flavors in -which case supercite is used to format the message. Certain -undesirable header fields (see -`mh-invisible-header-fields-compiled') are removed before -insertion. - -If given a prefix argument VERBATIM, the header is left intact, the -message is not indented, and \"> \" is not inserted before each line. -This command leaves the mark before the letter and point after it." - (interactive - (let* ((folder - (mh-prompt-for-folder "Message from" - mh-sent-from-folder nil)) - (default - (if (and (equal folder mh-sent-from-folder) - (numberp mh-sent-from-msg)) - mh-sent-from-msg - (nth 0 (mh-translate-range folder "cur")))) - (message - (read-string (concat "Message number" - (or (and default - (format " (default %d): " default)) - ": "))))) - (list folder message current-prefix-arg))) - (save-restriction - (narrow-to-region (point) (point)) - (let ((start (point-min))) - (if (and (equal message "") (numberp mh-sent-from-msg)) - (setq message (int-to-string mh-sent-from-msg))) - (insert-file-contents - (expand-file-name message (mh-expand-file-name folder))) - (when (not verbatim) - (mh-clean-msg-header start mh-invisible-header-fields-compiled nil) - (goto-char (point-max)) ;Needed for sc-cite-original - (push-mark) ;Needed for sc-cite-original - (goto-char (point-min)) ;Needed for sc-cite-original - (mh-insert-prefix-string mh-ins-buf-prefix))))) - -(defun mh-extract-from-attribution () - "Extract phrase or comment from From header field." - (save-excursion - (if (not (mh-goto-header-field "From: ")) - nil - (skip-chars-forward " ") - (cond - ((looking-at "\"\\([^\"\n]+\\)\" \\(<.+>\\)") - (format "%s %s " (match-string 1)(match-string 2))) - ((looking-at "\\([^<\n]+<.+>\\)$") - (format "%s " (match-string 1))) - ((looking-at "\\([^ ]+@[^ ]+\\) +(\\(.+\\))$") - (format "%s <%s> " (match-string 2)(match-string 1))) - ((looking-at " *\\(.+\\)$") - (format "%s " (match-string 1))))))) - -;;;###mh-autoload -(defun mh-yank-cur-msg () - "Insert the current message into the draft buffer. - -It is often useful to insert a snippet of text from a letter that -someone mailed to provide some context for your reply. This -command does this by adding an attribution, yanking a portion of -text from the message to which you're replying, and inserting -`mh-ins-buf-prefix' (`> ') before each line. - -The attribution consists of the sender's name and email address -followed by the content of the option -`mh-extract-from-attribution-verb'. - -You can also turn on the option -`mh-delete-yanked-msg-window-flag' to delete the window -containing the original message after yanking it to make more -room on your screen for your reply. - -You can control how the message to which you are replying is -yanked into your reply using `mh-yank-behavior'. - -If this isn't enough, you can gain full control over the -appearance of the included text by setting `mail-citation-hook' -to a function that modifies it. For example, if you set this hook -to `trivial-cite' (which is NOT part of Emacs), set -`mh-yank-behavior' to \"Body and Header\" (see URL -`http://shasta.cs.uiuc.edu/~lrclause/tc.html'). - -Note that if `mail-citation-hook' is set, `mh-ins-buf-prefix' is -not inserted. If the option `mh-yank-behavior' is set to one of -the supercite flavors, the hook `mail-citation-hook' is ignored -and `mh-ins-buf-prefix' is not inserted." - (interactive) - (if (and mh-sent-from-folder - (save-excursion (set-buffer mh-sent-from-folder) mh-show-buffer) - (save-excursion (set-buffer mh-sent-from-folder) - (get-buffer mh-show-buffer)) - mh-sent-from-msg) - (let ((to-point (point)) - (to-buffer (current-buffer))) - (set-buffer mh-sent-from-folder) - (if mh-delete-yanked-msg-window-flag - (delete-windows-on mh-show-buffer)) - (set-buffer mh-show-buffer) ; Find displayed message - (let* ((from-attr (mh-extract-from-attribution)) - (yank-region (mh-mark-active-p nil)) - (mh-ins-str - (cond ((and yank-region - (or (eq 'supercite mh-yank-behavior) - (eq 'autosupercite mh-yank-behavior) - (eq t mh-yank-behavior))) - ;; supercite needs the full header - (concat - (buffer-substring (point-min) (mh-mail-header-end)) - "\n" - (buffer-substring (region-beginning) (region-end)))) - (yank-region - (buffer-substring (region-beginning) (region-end))) - ((or (eq 'body mh-yank-behavior) - (eq 'attribution mh-yank-behavior) - (eq 'autoattrib mh-yank-behavior)) - (buffer-substring - (save-excursion - (goto-char (point-min)) - (mh-goto-header-end 1) - (point)) - (point-max))) - ((or (eq 'supercite mh-yank-behavior) - (eq 'autosupercite mh-yank-behavior) - (eq t mh-yank-behavior)) - (buffer-substring (point-min) (point-max))) - (t - (buffer-substring (point) (point-max)))))) - (set-buffer to-buffer) - (save-restriction - (narrow-to-region to-point to-point) - (insert (mh-filter-out-non-text mh-ins-str)) - (goto-char (point-max)) ;Needed for sc-cite-original - (push-mark) ;Needed for sc-cite-original - (goto-char (point-min)) ;Needed for sc-cite-original - (mh-insert-prefix-string mh-ins-buf-prefix) - (when (or (eq 'attribution mh-yank-behavior) - (eq 'autoattrib mh-yank-behavior)) - (insert from-attr) - (mh-identity-insert-attribution-verb nil) - (insert "\n\n")) - ;; If the user has selected a region, he has already "edited" the - ;; text, so leave the cursor at the end of the yanked text. In - ;; either case, leave a mark at the opposite end of the included - ;; text to make it easy to jump or delete to the other end of the - ;; text. - (push-mark) - (goto-char (point-max)) - (if (null yank-region) - (mh-exchange-point-and-mark-preserving-active-mark))))) - (error "There is no current message"))) - -(defun mh-filter-out-non-text (string) - "Return STRING but without adornments such as MIME buttons and smileys." - (with-temp-buffer - ;; Insert the string to filter - (insert string) - (goto-char (point-min)) - - ;; Remove the MIME buttons - (let ((can-move-forward t) - (in-button nil)) - (while can-move-forward - (cond ((and (not (get-text-property (point) 'mh-data)) - in-button) - (delete-region (1- (point)) (point)) - (setq in-button nil)) - ((get-text-property (point) 'mh-data) - (delete-region (point) - (save-excursion (forward-line) (point))) - (setq in-button t)) - (t (setq can-move-forward (= (forward-line) 0)))))) - - ;; Return the contents without properties... This gets rid of emphasis - ;; and smileys - (buffer-substring-no-properties (point-min) (point-max)))) - -(defun mh-insert-prefix-string (mh-ins-string) - "Insert prefix string before each line in buffer. -The inserted letter is cited using `sc-cite-original' if -`mh-yank-behavior' is one of 'supercite or 'autosupercite. -Otherwise, simply insert MH-INS-STRING before each line." - (goto-char (point-min)) - (cond ((or (eq mh-yank-behavior 'supercite) - (eq mh-yank-behavior 'autosupercite)) - (sc-cite-original)) - (mail-citation-hook - (run-hooks 'mail-citation-hook)) - (mh-yank-hooks ;old hook name - (run-hooks 'mh-yank-hooks)) - (t - (or (bolp) (forward-line 1)) - (while (< (point) (point-max)) - (insert mh-ins-string) - (forward-line 1)) - (goto-char (point-min))))) ;leave point like sc-cite-original - -;;;###mh-autoload -(defun mh-fully-kill-draft () - "Quit editing and delete draft message. - -If for some reason you are not happy with the draft, you can use -this command to kill the draft buffer and delete the draft -message. Use the command \\[kill-buffer] if you don't want to -delete the draft message." - (interactive) - (if (y-or-n-p "Kill draft message? ") - (let ((config mh-previous-window-config)) - (if (file-exists-p buffer-file-name) - (delete-file buffer-file-name)) - (set-buffer-modified-p nil) - (kill-buffer (buffer-name)) - (message "") - (if config - (set-window-configuration config))) - (error "Message not killed"))) - -(defun mh-current-fill-prefix () - "Return the `fill-prefix' on the current line as a string." - (save-excursion - (beginning-of-line) - ;; This assumes that the major-mode sets up adaptive-fill-regexp - ;; correctly such as mh-letter-mode or sendmail.el's mail-mode. But - ;; perhaps I should use the variable and simply inserts its value here, - ;; and set it locally in a let scope. --psg - (if (re-search-forward adaptive-fill-regexp nil t) - (match-string 0) - ""))) - -;;;###mh-autoload -(defun mh-open-line () - "Insert a newline and leave point before it. - -This command is similar to the command \\[open-line] in that it -inserts a newline after point. It differs in that it also inserts -the right number of quoting characters and spaces so that the -next line begins in the same column as it was. This is useful -when breaking up paragraphs in replies." - (interactive) - (let ((column (current-column)) - (prefix (mh-current-fill-prefix))) - (if (> (length prefix) column) - (message "Sorry, point seems to be within the line prefix") - (newline 2) - (insert prefix) - (while (> column (current-column)) - (insert " ")) - (forward-line -1)))) - -(mh-do-in-xemacs (defvar mail-abbrevs)) - -(defmacro mh-display-completion-list-compat (word choices) - "Completes WORD from CHOICES using `display-completion-list'. -Calls `display-completion-list' correctly in older environments. -Versions of Emacs prior to version 22 lacked a COMMON-SUBSTRING -argument which is used to highlight the next possible character you -can enter in the current list of completions." - (if (>= emacs-major-version 22) - `(display-completion-list (all-completions ,word ,choices) ,word) - `(display-completion-list (all-completions ,word ,choices)))) - -;;;###mh-autoload -(defun mh-complete-word (word choices begin end) - "Complete WORD at from CHOICES. -Any match found replaces the text from BEGIN to END." - (let ((completion (try-completion word choices)) - (completions-buffer "*Completions*")) - (cond ((eq completion t) - (ignore-errors - (kill-buffer completions-buffer)) - (message "Completed: %s" word)) - ((null completion) - (ignore-errors - (kill-buffer completions-buffer)) - (message "No completion for %s" word)) - ((stringp completion) - (if (equal word completion) - (with-output-to-temp-buffer completions-buffer - (mh-display-completion-list-compat word choices)) - (ignore-errors - (kill-buffer completions-buffer)) - (delete-region begin end) - (insert completion)))))) - -;;;###mh-autoload -(defun mh-beginning-of-word (&optional n) - "Return position of the N th word backwards." - (unless n (setq n 1)) - (let ((syntax-table (syntax-table))) - (unwind-protect - (save-excursion - (mh-mail-abbrev-make-syntax-table) - (set-syntax-table mail-abbrev-syntax-table) - (backward-word n) - (point)) - (set-syntax-table syntax-table)))) - -(defun mh-folder-expand-at-point () - "Do folder name completion in Fcc header field." - (let* ((end (point)) - (beg (mh-beginning-of-word)) - (folder (buffer-substring beg end)) - (leading-plus (and (> (length folder) 0) (equal (aref folder 0) ?+))) - (last-slash (mh-search-from-end ?/ folder)) - (prefix (and last-slash (substring folder 0 last-slash))) - (choices (mapcar #'(lambda (x) - (list (cond (prefix (format "%s/%s" prefix x)) - (leading-plus (format "+%s" x)) - (t x)))) - (mh-folder-completion-function folder nil t)))) - (mh-complete-word folder choices beg end))) - -(defvar mh-letter-complete-function-alist - '((bcc . mh-alias-letter-expand-alias) - (cc . mh-alias-letter-expand-alias) - (dcc . mh-alias-letter-expand-alias) - (fcc . mh-folder-expand-at-point) - (from . mh-alias-letter-expand-alias) - (mail-followup-to . mh-alias-letter-expand-alias) - (mail-reply-to . mh-alias-letter-expand-alias) - (reply-to . mh-alias-letter-expand-alias) - (to . mh-alias-letter-expand-alias)) - "Alist of header fields and completion functions to use.") - -(defun mh-letter-complete (arg) - "Perform completion on header field or word preceding point. - -If the field contains addresses (for example, \"To:\" or \"Cc:\") -or folders (for example, \"Fcc:\") then this command will provide -alias completion. In the body of the message, this command runs -`mh-letter-complete-function' instead, which is set to -`ispell-complete-word' by default. This command takes a prefix -argument ARG that is passed to the -`mh-letter-complete-function'." - (interactive "P") - (let ((func nil)) - (cond ((not (mh-in-header-p)) - (funcall mh-letter-complete-function arg)) - ((setq func (cdr (assoc (mh-letter-header-field-at-point) - mh-letter-complete-function-alist))) - (funcall func)) - (t (funcall mh-letter-complete-function arg))))) - -(defun mh-letter-complete-or-space (arg) - "Perform completion or insert space. - -Turn on the option `mh-compose-space-does-completion-flag' to use -this command to perform completion in the header. Otherwise, a -space is inserted; use a prefix argument ARG to specify more than -one space." - (interactive "p") - (let ((func nil) - (end-of-prev (save-excursion - (goto-char (mh-beginning-of-word)) - (mh-beginning-of-word -1)))) - (cond ((not mh-compose-space-does-completion-flag) - (self-insert-command arg)) - ((not (mh-in-header-p)) (self-insert-command arg)) - ((> (point) end-of-prev) (self-insert-command arg)) - ((setq func (cdr (assoc (mh-letter-header-field-at-point) - mh-letter-complete-function-alist))) - (funcall func)) - (t (self-insert-command arg))))) - -(defun mh-letter-confirm-address () - "Flash alias expansion. - -Addresses are separated by a comma\; when you press the comma, -this command flashes the alias expansion in the minibuffer if -`mh-alias-flash-on-comma' is turned on." - (interactive) - (cond ((not (mh-in-header-p)) (self-insert-command 1)) - ((eq (cdr (assoc (mh-letter-header-field-at-point) - mh-letter-complete-function-alist)) - 'mh-alias-letter-expand-alias) - (mh-alias-reload-maybe) - (mh-alias-minibuffer-confirm-address)) - (t (self-insert-command 1)))) - -(defvar mh-letter-header-field-regexp "^\\([A-Za-z][A-Za-z0-9-]*\\):") - -(defun mh-letter-header-field-at-point () - "Return the header field name at point. -A symbol is returned whose name is the string obtained by -downcasing the field name." - (save-excursion - (end-of-line) - (and (re-search-backward mh-letter-header-field-regexp nil t) - (intern (downcase (match-string 1)))))) - -;;;###mh-autoload -(defun mh-letter-next-header-field-or-indent (arg) - "Cycle to next field. - -Within the header of the message, this command moves between -fields that are highlighted with the face -`mh-letter-header-field', skipping those fields listed in -`mh-compose-skipped-header-fields'. After the last field, this -command then moves point to the message body before cycling back -to the first field. If point is already past the first line of -the message body, then this command indents by calling -`indent-relative' with the given prefix argument ARG." - (interactive "P") - (let ((header-end (save-excursion - (goto-char (mh-mail-header-end)) - (forward-line) - (point)))) - (if (> (point) header-end) - (indent-relative arg) - (mh-letter-next-header-field)))) - -(defun mh-letter-next-header-field () - "Cycle to the next header field. -If we are at the last header field go to the start of the message -body." - (let ((header-end (mh-mail-header-end))) - (cond ((>= (point) header-end) (goto-char (point-min))) - ((< (point) (progn - (beginning-of-line) - (re-search-forward mh-letter-header-field-regexp - (line-end-position) t) - (point))) - (beginning-of-line)) - (t (end-of-line))) - (cond ((re-search-forward mh-letter-header-field-regexp header-end t) - (if (mh-letter-skipped-header-field-p (match-string 1)) - (mh-letter-next-header-field) - (mh-letter-skip-leading-whitespace-in-header-field))) - (t (goto-char header-end) - (forward-line))))) - -;;;###mh-autoload -(defun mh-letter-previous-header-field () - "Cycle to the previous header field. - -This command moves backwards between the fields and cycles to the -body of the message after the first field. Unlike the command -\\[mh-letter-next-header-field-or-indent], it will always take -point to the last field from anywhere in the body." - (interactive) - (let ((header-end (mh-mail-header-end))) - (if (>= (point) header-end) - (goto-char header-end) - (mh-header-field-beginning)) - (cond ((re-search-backward mh-letter-header-field-regexp nil t) - (if (mh-letter-skipped-header-field-p (match-string 1)) - (mh-letter-previous-header-field) - (goto-char (match-end 0)) - (mh-letter-skip-leading-whitespace-in-header-field))) - (t (goto-char header-end) - (forward-line))))) - -(defun mh-letter-skipped-header-field-p (field) - "Check if FIELD is to be skipped." - (let ((field (downcase field))) - (loop for x in mh-compose-skipped-header-fields - when (equal (downcase x) field) return t - finally return nil))) - -(defun mh-letter-skip-leading-whitespace-in-header-field () - "Skip leading whitespace in a header field. -If the header field doesn't have at least one space after the -colon then a space character is added." - (let ((need-space t)) - (while (memq (char-after) '(?\t ?\ )) - (forward-char) - (setq need-space nil)) - (when need-space (insert " ")))) - -(defvar mh-hidden-header-keymap - (let ((map (make-sparse-keymap))) - (mh-do-in-gnu-emacs - (define-key map [mouse-2] 'mh-letter-toggle-header-field-display-button)) - (mh-do-in-xemacs - (define-key map '(button2) - 'mh-letter-toggle-header-field-display-button)) - map)) - -(defun mh-letter-toggle-header-field-display-button (event) - "Toggle header field display at location of EVENT. -This function does the same thing as -`mh-letter-toggle-header-field-display' except that it is -callable from a mouse button." - (interactive "e") - (mh-do-at-event-location event - (mh-letter-toggle-header-field-display nil))) - -(defun mh-letter-toggle-header-field-display (arg) - "Toggle display of header field at point. - -Use this command to display truncated header fields. This command -is a toggle so entering it again will hide the field. This -command takes a prefix argument ARG: if negative then the field -is hidden, if positive then the field is displayed." - (interactive (list nil)) - (when (and (mh-in-header-p) - (progn - (end-of-line) - (re-search-backward mh-letter-header-field-regexp nil t))) - (let ((buffer-read-only nil) - (modified-flag (buffer-modified-p)) - (begin (point)) - end) - (end-of-line) - (setq end (1- (if (re-search-forward "^[^ \t]" nil t) - (match-beginning 0) - (point-max)))) - (goto-char begin) - ;; Make it clickable... - (add-text-properties begin end `(keymap ,mh-hidden-header-keymap - mouse-face highlight)) - (unwind-protect - (cond ((or (and (not arg) - (text-property-any begin end 'invisible 'vanish)) - (and (numberp arg) (>= arg 0)) - (and (eq arg 'long) (> (line-beginning-position 5) end))) - (remove-text-properties begin end '(invisible nil)) - (search-forward ":" (line-end-position) t) - (mh-letter-skip-leading-whitespace-in-header-field)) - ;; XXX Redesign to make usable by user. Perhaps use a positive - ;; numeric prefix to make that many lines visible. - ((eq arg 'long) - (end-of-line 4) - (mh-letter-truncate-header-field end) - (beginning-of-line)) - (t (end-of-line) - (mh-letter-truncate-header-field end) - (beginning-of-line))) - (set-buffer-modified-p modified-flag))))) - -(defun mh-letter-truncate-header-field (end) - "Replace text from current line till END with an ellipsis. -If the current line is too long truncate a part of it as well." - (let ((max-len (min (window-width) 62))) - (when (> (+ (current-column) 4) max-len) - (backward-char (- (+ (current-column) 5) max-len))) - (when (> end (point)) - (add-text-properties (point) end '(invisible vanish))))) - -(defun mh-letter-hide-all-skipped-fields () - "Hide all skipped fields." - (save-excursion - (goto-char (point-min)) - (save-restriction - (narrow-to-region (point) (mh-mail-header-end)) - (while (re-search-forward mh-letter-header-field-regexp nil t) - (if (mh-letter-skipped-header-field-p (match-string 1)) - (mh-letter-toggle-header-field-display -1) - (mh-letter-toggle-header-field-display 'long)) - (beginning-of-line 2))))) - -(defun mh-interactive-read-address (prompt) - "Read an address. -If `mh-compose-prompt-flag' is non-nil, then read an address with -PROMPT. -Otherwise return the empty string." - (if mh-compose-prompt-flag (mh-read-address prompt) "")) - -(defun mh-interactive-read-string (prompt) - "Read a string. -If `mh-compose-prompt-flag' is non-nil, then read a string with -PROMPT. -Otherwise return the empty string." - (if mh-compose-prompt-flag (read-string prompt) "")) - -(defun mh-letter-adjust-point () - "Move cursor to first header field if are using the no prompt mode." - (unless mh-compose-prompt-flag - (goto-char (point-max)) - (mh-letter-next-header-field))) - - - -;;; Build mh-letter-mode keymap - -;; If this changes, modify mh-letter-mode-help-messages accordingly, above. -(gnus-define-keys mh-letter-mode-map - " " mh-letter-complete-or-space - "," mh-letter-confirm-address - "\C-c?" mh-help - "\C-c\C-\\" mh-fully-kill-draft ;if no C-q - "\C-c\C-^" mh-insert-signature ;if no C-s - "\C-c\C-c" mh-send-letter - "\C-c\C-d" mh-insert-identity - "\C-c\C-e" mh-mh-to-mime - "\C-c\C-f\C-a" mh-to-field - "\C-c\C-f\C-b" mh-to-field - "\C-c\C-f\C-c" mh-to-field - "\C-c\C-f\C-d" mh-to-field - "\C-c\C-f\C-f" mh-to-fcc - "\C-c\C-f\C-l" mh-to-field - "\C-c\C-f\C-m" mh-to-field - "\C-c\C-f\C-r" mh-to-field - "\C-c\C-f\C-s" mh-to-field - "\C-c\C-f\C-t" mh-to-field - "\C-c\C-fa" mh-to-field - "\C-c\C-fb" mh-to-field - "\C-c\C-fc" mh-to-field - "\C-c\C-fd" mh-to-field - "\C-c\C-ff" mh-to-fcc - "\C-c\C-fl" mh-to-field - "\C-c\C-fm" mh-to-field - "\C-c\C-fr" mh-to-field - "\C-c\C-fs" mh-to-field - "\C-c\C-ft" mh-to-field - "\C-c\C-i" mh-insert-letter - "\C-c\C-m\C-e" mh-mml-secure-message-encrypt - "\C-c\C-m\C-f" mh-compose-forward - "\C-c\C-m\C-g" mh-mh-compose-anon-ftp - "\C-c\C-m\C-i" mh-compose-insertion - "\C-c\C-m\C-m" mh-mml-to-mime - "\C-c\C-m\C-n" mh-mml-unsecure-message - "\C-c\C-m\C-s" mh-mml-secure-message-sign - "\C-c\C-m\C-t" mh-mh-compose-external-compressed-tar - "\C-c\C-m\C-u" mh-mh-to-mime-undo - "\C-c\C-m\C-x" mh-mh-compose-external-type - "\C-c\C-mee" mh-mml-secure-message-encrypt - "\C-c\C-mes" mh-mml-secure-message-signencrypt - "\C-c\C-mf" mh-compose-forward - "\C-c\C-mg" mh-mh-compose-anon-ftp - "\C-c\C-mi" mh-compose-insertion - "\C-c\C-mm" mh-mml-to-mime - "\C-c\C-mn" mh-mml-unsecure-message - "\C-c\C-mse" mh-mml-secure-message-signencrypt - "\C-c\C-mss" mh-mml-secure-message-sign - "\C-c\C-mt" mh-mh-compose-external-compressed-tar - "\C-c\C-mu" mh-mh-to-mime-undo - "\C-c\C-mx" mh-mh-compose-external-type - "\C-c\C-o" mh-open-line - "\C-c\C-q" mh-fully-kill-draft - "\C-c\C-s" mh-insert-signature - "\C-c\C-t" mh-letter-toggle-header-field-display - "\C-c\C-w" mh-check-whom - "\C-c\C-y" mh-yank-cur-msg - "\C-c\M-d" mh-insert-auto-fields - "\M-\t" mh-letter-complete - "\t" mh-letter-next-header-field-or-indent - [backtab] mh-letter-previous-header-field) - -;; "C-c /" prefix is used in mh-letter-mode by pgp.el and mailcrypt.el. - (provide 'mh-comp) ;; Local Variables: |