1 ;;; mh-comp.el --- MH-E functions for composing messages
3 ;; Copyright (C) 1993, 95, 1997,
4 ;; 2000, 01, 02, 2003 Free Software Foundation, Inc.
6 ;; Author: Bill Wohler <wohler@newt.com>
7 ;; Maintainer: Bill Wohler <wohler@newt.com>
11 ;; This file is part of GNU Emacs.
13 ;; GNU Emacs is free software; you can redistribute it and/or modify
14 ;; it under the terms of the GNU General Public License as published by
15 ;; the Free Software Foundation; either version 2, or (at your option)
18 ;; GNU Emacs is distributed in the hope that it will be useful,
19 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
20 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
21 ;; GNU General Public License for more details.
23 ;; You should have received a copy of the GNU General Public License
24 ;; along with GNU Emacs; see the file COPYING. If not, write to the
25 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
26 ;; Boston, MA 02111-1307, USA.
30 ;; Internal support for MH-E package.
40 (eval-when (compile load eval
)
41 (ignore-errors (require 'mailabbrev
)))
43 ;; Shush the byte-compiler
44 (defvar adaptive-fill-first-line-regexp
)
45 (defvar font-lock-defaults
)
47 (defvar sendmail-coding-system
)
48 (defvar mh-identity-list
)
49 (defvar mh-identity-default
)
50 (defvar mh-identity-menu
)
53 (autoload 'Info-goto-node
"info")
54 (autoload 'mail-mode-fill-paragraph
"sendmail")
55 (autoload 'mm-handle-displayed-p
"mm-decode")
57 (autoload 'sc-cite-original
"sc"
58 "Workhorse citing function which performs the initial citation.
59 This is callable from the various mail and news readers' reply
60 function according to the agreed upon standard. See `\\[sc-describe]'
61 for more details. `sc-cite-original' does not do any yanking of the
62 original message but it does require a few things:
64 1) The reply buffer is the current buffer.
66 2) The original message has been yanked and inserted into the
69 3) Verbose mail headers from the original message have been
70 inserted into the reply buffer directly before the text of the
73 4) Point is at the beginning of the verbose headers.
75 5) Mark is at the end of the body of text to be cited.
77 For Emacs 19's, the region need not be active (and typically isn't
78 when this function is called. Also, the hook `sc-pre-hook' is run
79 before, and `sc-post-hook' is run after the guts of this function.")
81 ;;; Site customization (see also mh-utils.el):
83 (defvar mh-send-prog
"send"
84 "Name of the MH send program.
85 Some sites need to change this because of a name conflict.")
87 (defvar mh-redist-full-contents nil
88 "Non-nil if the `dist' command needs whole letter for redistribution.
89 This is the case only when `send' is compiled with the BERK option.
90 If MH will not allow you to redist a previously redist'd msg, set to nil.")
92 (defvar mh-redist-background nil
93 "If non-nil redist will be done in background like send.
94 This allows transaction log to be visible if -watch, -verbose or -snoop are
97 (defvar mh-note-repl
"-"
98 "String whose first character is used to notate replied to messages.")
100 (defvar mh-note-forw
"F"
101 "String whose first character is used to notate forwarded messages.")
103 (defvar mh-note-dist
"R"
104 "String whose first character is used to notate redistributed messages.")
106 (defvar mh-yank-hooks nil
107 "Obsolete hook for modifying a citation just inserted in the mail buffer.
108 Each hook function can find the citation between point and mark.
109 And each hook function should leave point and mark around the citation
112 This is a normal hook, misnamed for historical reasons.
113 It is semi-obsolete and is only used if `mail-citation-hook' is nil.")
115 (defvar mail-citation-hook nil
116 "*Hook for modifying a citation just inserted in the mail buffer.
117 Each hook function can find the citation between point and mark.
118 And each hook function should leave point and mark around the citation
121 If this hook is entirely empty (nil), the text of the message is inserted
122 with `mh-ins-buf-prefix' prefixed to each line.
124 See also the variable `mh-yank-from-start-of-msg', which controls how
125 much of the message passed to the hook.
127 This hook was historically provided to set up supercite. You may now leave
128 this nil and set up supercite by setting the variable
129 `mh-yank-from-start-of-msg' to 'supercite or, for more automatic insertion,
132 (defvar mh-comp-formfile
"components"
133 "Name of file to be used as a skeleton for composing messages.
134 Default is \"components\". If not an absolute file name, the file
135 is searched for first in the user's MH directory, then in the
136 system MH lib directory.")
138 (defvar mh-repl-formfile
"replcomps"
139 "Name of file to be used as a skeleton for replying to messages.
140 Default is \"replcomps\". If not an absolute file name, the file
141 is searched for first in the user's MH directory, then in the
142 system MH lib directory.")
144 (defvar mh-repl-group-formfile
"replgroupcomps"
145 "Name of file to be used as a skeleton for replying to messages.
146 This file is used to form replies to the sender and all recipients of a
147 message. Only used if `mh-nmh-flag' is non-nil. Default is \"replgroupcomps\".
148 If not an absolute file name, the file is searched for first in the user's MH
149 directory, then in the system MH lib directory.")
151 (defvar mh-rejected-letter-start
154 '("Content-Type: message/rfc822" ;MIME MDN
155 " ----- Unsent message follows -----" ;from sendmail V5
156 " --------Unsent Message below:" ; from sendmail at BU
157 " ----- Original message follows -----" ;from sendmail V8
158 "------- Unsent Draft" ;from MH itself
159 "---------- Original Message ----------" ;from zmailer
160 " --- The unsent message follows ---" ;from AIX mail system
161 " Your message follows:" ;from MMDF-II
162 "Content-Description: Returned Content" ;1993 KJ sendmail
165 (defvar mh-new-draft-cleaned-headers
166 "^Date:\\|^Received:\\|^Message-Id:\\|^From:\\|^Sender:\\|^Errors-To:\\|^Delivery-Date:\\|^Return-Path:"
167 "Regexp of header lines to remove before offering a message as a new draft.
168 Used by the \\<mh-folder-mode-map>`\\[mh-edit-again]' and `\\[mh-extract-rejected-mail]' commands.")
170 (defvar mh-to-field-choices
'(("t" .
"To:") ("s" .
"Subject:") ("c" .
"Cc:")
171 ("b" .
"Bcc:") ("f" .
"Fcc:") ("r" .
"From:")
173 "Alist of (final-character . field-name) choices for `mh-to-field'.")
175 (defvar mh-letter-mode-map
(copy-keymap text-mode-map
)
176 "Keymap for composing mail.")
178 (defvar mh-letter-mode-syntax-table nil
179 "Syntax table used by MH-E while in MH-Letter mode.")
181 (if mh-letter-mode-syntax-table
183 (setq mh-letter-mode-syntax-table
184 (make-syntax-table text-mode-syntax-table
))
185 (modify-syntax-entry ?%
"." mh-letter-mode-syntax-table
))
187 (defvar mh-sent-from-folder nil
188 "Folder of msg assoc with this letter.")
190 (defvar mh-sent-from-msg nil
191 "Number of msg assoc with this letter.")
193 (defvar mh-send-args nil
194 "Extra args to pass to \"send\" command.")
196 (defvar mh-annotate-char nil
197 "Character to use to annotate `mh-sent-from-msg'.")
199 (defvar mh-annotate-field nil
200 "Field name for message annotation.")
204 "Compose and send mail with the MH mail system.
205 This function is an entry point to MH-E, the Emacs front end
206 to the MH mail system.
208 See documentation of `\\[mh-send]' for more details on composing mail."
211 (call-interactively 'mh-send
))
213 (defvar mh-error-if-no-draft nil
) ;raise error over using old draft
216 (defun mh-smail-batch (&optional to subject other-headers
&rest ignored
)
217 "Set up a mail composition draft with the MH mail system.
218 This function is an entry point to MH-E, the Emacs front end
219 to the MH mail system. This function does not prompt the user
220 for any header fields, and thus is suitable for use by programs
221 that want to create a mail buffer.
222 Users should use `\\[mh-smail]' to compose mail.
223 Optional arguments for setting certain fields include TO, SUBJECT, and
224 OTHER-HEADERS. Additional arguments are IGNORED."
226 (let ((mh-error-if-no-draft t
))
227 (mh-send (or to
"") "" (or subject
""))))
229 ;; XEmacs needs this:
231 (defun mh-user-agent-compose (&optional to subject other-headers continue
232 switch-function yank-action
234 "Set up mail composition draft with the MH mail system.
235 This is `mail-user-agent' entry point to MH-E.
237 The optional arguments TO and SUBJECT specify recipients and the
238 initial Subject field, respectively.
240 OTHER-HEADERS is an alist specifying additional
241 header fields. Elements look like (HEADER . VALUE) where both
242 HEADER and VALUE are strings.
244 CONTINUE, SWITCH-FUNCTION, YANK-ACTION and SEND-ACTIONS are ignored."
246 (let ((mh-error-if-no-draft t
))
247 (mh-send to
"" subject
)
249 (mh-insert-fields (concat (car (car other-headers
)) ":")
250 (cdr (car other-headers
)))
251 (setq other-headers
(cdr other-headers
)))))
254 (defun mh-edit-again (msg)
255 "Clean up a draft or a message MSG previously sent and make it resendable.
256 Default is the current message.
257 The variable `mh-new-draft-cleaned-headers' specifies the headers to remove.
258 See also documentation for `\\[mh-send]' function."
259 (interactive (list (mh-get-msg-num t
)))
260 (let* ((from-folder mh-current-folder
)
261 (config (current-window-configuration))
263 (cond ((and mh-draft-folder
(equal from-folder mh-draft-folder
))
264 (pop-to-buffer (find-file-noselect (mh-msg-filename msg
)) t
)
265 (rename-buffer (format "draft-%d" msg
))
266 ;; Make buffer writable...
267 (setq buffer-read-only nil
)
268 ;; If buffer was being used to display the message reinsert
270 (when (eq major-mode
'mh-show-mode
)
272 (insert-file-contents buffer-file-name
))
275 (mh-read-draft "clean-up" (mh-msg-filename msg
) nil
)))))
276 (mh-clean-msg-header (point-min) mh-new-draft-cleaned-headers nil
)
277 (mh-insert-header-separator)
278 (goto-char (point-min))
280 (mh-compose-and-send-mail draft
"" from-folder nil nil nil nil nil nil
282 (mh-letter-mode-message)))
285 (defun mh-extract-rejected-mail (msg)
286 "Extract message MSG returned by the mail system and make it resendable.
287 Default is the current message. The variable `mh-new-draft-cleaned-headers'
288 gives the headers to clean out of the original message.
289 See also documentation for `\\[mh-send]' function."
290 (interactive (list (mh-get-msg-num t
)))
291 (let ((from-folder mh-current-folder
)
292 (config (current-window-configuration))
293 (draft (mh-read-draft "extraction" (mh-msg-filename msg
) nil
)))
294 (goto-char (point-min))
295 (cond ((re-search-forward mh-rejected-letter-start nil t
)
296 (skip-chars-forward " \t\n")
297 (delete-region (point-min) (point))
298 (mh-clean-msg-header (point-min) mh-new-draft-cleaned-headers nil
))
300 (message "Does not appear to be a rejected letter.")))
301 (mh-insert-header-separator)
302 (goto-char (point-min))
304 (mh-compose-and-send-mail draft
"" from-folder msg
305 (mh-get-header-field "To:")
306 (mh-get-header-field "From:")
307 (mh-get-header-field "Cc:")
309 (mh-letter-mode-message)))
312 (defun mh-forward (to cc
&optional msg-or-seq
)
313 "Forward messages to the recipients TO and CC.
314 Use optional MSG-OR-SEQ argument to specify a message or sequence to forward.
315 Default is the displayed message.
316 If optional prefix argument is provided, then prompt for the message sequence.
317 If variable `transient-mark-mode' is non-nil and the mark is active, then the
318 selected region is forwarded.
319 In a program, MSG-OR-SEQ can be a message number, a list of message numbers, a
320 region in a cons cell, or a sequence.
322 See also documentation for `\\[mh-send]' function."
323 (interactive (list (mh-read-address "To: ")
324 (mh-read-address "Cc: ")
325 (mh-interactive-msg-or-seq "Forward")))
326 (let* ((folder mh-current-folder
)
327 (msgs (mh-msg-or-seq-to-msg-list msg-or-seq
))
328 (config (current-window-configuration))
329 (fwd-msg-file (mh-msg-filename (car msgs
) folder
))
330 ;; forw always leaves file in "draft" since it doesn't have -draft
331 (draft-name (expand-file-name "draft" mh-user-path
))
332 (draft (cond ((or (not (file-exists-p draft-name
))
333 (y-or-n-p "The file 'draft' exists. Discard it? "))
334 (mh-exec-cmd "forw" "-build" (if mh-nmh-flag
"-mime")
336 (mh-coalesce-msg-list msgs
))
338 (mh-read-draft "" draft-name t
)
339 (mh-insert-fields "To:" to
"Cc:" cc
)
342 (mh-read-draft "" draft-name nil
)))))
346 (set-buffer (get-buffer-create mh-temp-buffer
))
348 (insert-file-contents fwd-msg-file
)
349 (setq orig-from
(mh-get-header-field "From:"))
350 (setq orig-subject
(mh-get-header-field "Subject:")))
352 (mh-forwarded-letter-subject orig-from orig-subject
)))
353 (mh-insert-fields "Subject:" forw-subject
)
354 (goto-char (point-min))
355 ;; If using MML, translate mhn
356 (if (equal mh-compose-insertion
'gnus
)
358 (re-search-forward (format "^\\(%s\\)?$"
359 mh-mail-header-separator
))
362 "^#forw \\[\\([^]]+\\)\\] \\(+\\S-+\\) \\(.*\\)$"
364 (let ((description (if (equal (match-string 1)
365 "forwarded messages")
366 "forwarded message %d"
368 (msgs (split-string (match-string 3)))
371 (delete-region (point) (progn (forward-line 1) (point)))
374 (mh-mml-forward-message (format description i
)
376 ;; Postition just before forwarded message
377 (if (re-search-forward "^------- Forwarded Message" nil t
)
379 (re-search-forward (format "^\\(%s\\)?$" mh-mail-header-separator
))
381 (delete-other-windows)
382 (mh-add-msgs-to-seq msgs
'forwarded t
)
383 (mh-compose-and-send-mail draft
"" folder msgs
385 mh-note-forw
"Forwarded:"
387 (mh-letter-mode-message)))))
389 (defun mh-forwarded-letter-subject (from subject
)
390 "Return a Subject suitable for a forwarded message.
391 Original message has headers FROM and SUBJECT."
392 (let ((addr-start (string-match "<" from
))
393 (comment (string-match "(" from
)))
394 (cond ((and addr-start
(> addr-start
0))
395 ;; Full Name <luser@host>
396 (setq from
(substring from
0 (1- addr-start
))))
398 ;; luser@host (Full Name)
399 (setq from
(substring from
(1+ comment
) (1- (length from
)))))))
400 (format mh-forward-subject-format from subject
))
403 (defun mh-smail-other-window ()
404 "Compose and send mail in other window with the MH mail system.
405 This function is an entry point to MH-E, the Emacs front end
406 to the MH mail system.
408 See documentation of `\\[mh-send]' for more details on composing mail."
411 (call-interactively 'mh-send-other-window
))
414 (defun mh-redistribute (to cc
&optional msg
)
415 "Redistribute displayed message to recipients TO and CC.
416 Use optional argument MSG to redistribute another message.
417 Depending on how your copy of MH was compiled, you may need to change the
418 setting of the variable `mh-redist-full-contents'. See its documentation."
419 (interactive (list (mh-read-address "Redist-To: ")
420 (mh-read-address "Redist-Cc: ")
423 (setq msg
(mh-get-msg-num t
)))
424 (save-window-excursion
425 (let ((folder mh-current-folder
)
426 (draft (mh-read-draft "redistribution"
427 (if mh-redist-full-contents
428 (mh-msg-filename msg
)
431 (mh-goto-header-end 0)
432 (insert "Resent-To: " to
"\n")
433 (if (not (equal cc
"")) (insert "Resent-cc: " cc
"\n"))
436 "^Message-Id:\\|^Received:\\|^Return-Path:\\|^Sender:\\|^Date:\\|^From:"
439 (message "Redistributing...")
440 (let ((env "mhdist=1"))
441 ;; Setup environment...
442 (setq env
(concat env
" mhaltmsg=" (if mh-redist-full-contents
444 (mh-msg-filename msg folder
))))
445 (unless mh-redist-full-contents
446 (setq env
(concat env
" mhannotate=1")))
448 (if mh-redist-background
449 (mh-exec-cmd-env-daemon env mh-send-prog nil buffer-file-name
)
450 (mh-exec-cmd-error env mh-send-prog
"-push" buffer-file-name
))
452 (mh-annotate-msg msg folder mh-note-dist
453 "-component" "Resent:"
454 "-text" (format "\"%s %s\"" to cc
)))
456 (message "Redistributing...done"))))
458 (defun mh-show-buffer-message-number (&optional buffer
)
459 "Message number of displayed message in corresponding show buffer.
460 Return nil if show buffer not displayed.
461 If in `mh-letter-mode', don't display the message number being replied to,
462 but rather the message number of the show buffer associated with our
463 originating folder buffer.
464 Optional argument BUFFER can be used to specify the buffer."
468 (cond ((eq major-mode
'mh-show-mode
)
469 (let ((number-start (mh-search-from-end ?
/ buffer-file-name
)))
470 (car (read-from-string (substring buffer-file-name
471 (1+ number-start
))))))
472 ((and (eq major-mode
'mh-folder-mode
)
474 (get-buffer mh-show-buffer
))
475 (mh-show-buffer-message-number mh-show-buffer
))
476 ((and (eq major-mode
'mh-letter-mode
)
478 (get-buffer mh-sent-from-folder
))
479 (mh-show-buffer-message-number mh-sent-from-folder
))
484 (defun mh-reply (message &optional reply-to includep
)
486 Default is the displayed message.
487 If the optional argument REPLY-TO is not given, prompts for type of addresses
490 to sender and primary recipients,
491 cc/all sender and all recipients.
492 If optional prefix argument INCLUDEP provided, then include the message
493 in the reply using filter `mhl.reply' in your MH directory.
494 If the file named by `mh-repl-formfile' exists, it is used as a skeleton
495 for the reply. See also documentation for `\\[mh-send]' function."
498 (let ((minibuffer-help-form
499 "from => Sender only\nto => Sender and primary recipients\ncc or all => Sender and all recipients"))
500 (or mh-reply-default-reply-to
501 (completing-read "Reply to whom? (from, to, all) [from]: "
502 '(("from") ("to") ("cc") ("all"))
506 (let* ((folder mh-current-folder
)
507 (show-buffer mh-show-buffer
)
508 (config (current-window-configuration))
509 (group-reply (or (equal reply-to
"cc") (equal reply-to
"all")))
510 (form-file (cond ((and mh-nmh-flag group-reply
511 (stringp mh-repl-group-formfile
))
512 mh-repl-group-formfile
)
513 ((stringp mh-repl-formfile
) mh-repl-formfile
)
515 (message "Composing a reply...")
516 (mh-exec-cmd "repl" "-build" "-noquery" "-nodraftfolder"
518 (list "-form" form-file
))
519 mh-current-folder message
520 (cond ((or (equal reply-to
"from") (equal reply-to
""))
522 ((equal reply-to
"to")
524 (group-reply (if mh-nmh-flag
525 '("-group" "-nocc" "me")
526 '("-cc" "all" "-nocc" "me"))))
527 (cond ((or (eq mh-yank-from-start-of-msg
'autosupercite
)
528 (eq mh-yank-from-start-of-msg
'autoattrib
))
530 (includep '("-filter" "mhl.reply"))
532 (let ((draft (mh-read-draft "reply"
533 (expand-file-name "reply" mh-user-path
)
535 (delete-other-windows)
538 (let ((to (mh-get-header-field "To:"))
539 (subject (mh-get-header-field "Subject:"))
540 (cc (mh-get-header-field "Cc:")))
541 (goto-char (point-min))
542 (mh-goto-header-end 1)
544 (not mh-reply-show-message-flag
)
545 (mh-in-show-buffer (show-buffer)
546 (mh-display-msg message folder
)))
547 (mh-add-msgs-to-seq message
'answered t
)
548 (message "Composing a reply...done")
549 (mh-compose-and-send-mail draft
"" folder message to subject cc
550 mh-note-repl
"Replied:" config
))
551 (when (and (or (eq 'autosupercite mh-yank-from-start-of-msg
)
552 (eq 'autoattrib mh-yank-from-start-of-msg
))
553 (eq (mh-show-buffer-message-number) mh-sent-from-msg
))
556 (mh-letter-mode-message))))
559 (defun mh-send (to cc subject
)
560 "Compose and send a letter.
562 Do not call this function from outside MH-E; use \\[mh-smail] instead.
564 The file named by `mh-comp-formfile' will be used as the form.
565 The letter is composed in `mh-letter-mode'; see its documentation for more
567 If `mh-compose-letter-function' is defined, it is called on the draft and
568 passed three arguments: TO, CC, and SUBJECT."
570 (mh-read-address "To: ")
571 (mh-read-address "Cc: ")
572 (read-string "Subject: ")))
573 (let ((config (current-window-configuration)))
574 (delete-other-windows)
575 (mh-send-sub to cc subject config
)))
578 (defun mh-send-other-window (to cc subject
)
579 "Compose and send a letter in another window.
581 Do not call this function from outside MH-E; use \\[mh-smail-other-window]
584 The file named by `mh-comp-formfile' will be used as the form.
585 The letter is composed in `mh-letter-mode'; see its documentation for more
587 If `mh-compose-letter-function' is defined, it is called on the draft and
588 passed three arguments: TO, CC, and SUBJECT."
590 (mh-read-address "To: ")
591 (mh-read-address "Cc: ")
592 (read-string "Subject: ")))
593 (let ((pop-up-windows t
))
594 (mh-send-sub to cc subject
(current-window-configuration))))
596 (defun mh-send-sub (to cc subject config
)
597 "Do the real work of composing and sending a letter.
598 Expects the TO, CC, and SUBJECT fields as arguments.
599 CONFIG is the window configuration before sending mail."
600 (let ((folder mh-current-folder
)
601 (msg-num (mh-get-msg-num nil
)))
602 (message "Composing a message...")
603 (let ((draft (mh-read-draft
609 (expand-file-name mh-comp-formfile mh-user-path
)))
613 (expand-file-name mh-comp-formfile mh-lib
)))
617 (expand-file-name mh-comp-formfile
618 ;; What is this mh-etc ?? -sm
619 ;; This is dead code, so
621 ;(and (boundp 'mh-etc) mh-etc)
625 (error (format "Can't find components file \"%s\""
628 (mh-insert-fields "To:" to
"Subject:" subject
"Cc:" cc
)
629 (goto-char (point-max))
630 (mh-compose-and-send-mail draft
"" folder msg-num
633 (mh-letter-mode-message))))
635 (defun mh-read-draft (use initial-contents delete-contents-file
)
636 "Read draft file into a draft buffer and make that buffer the current one.
637 USE is a message used for prompting about the intended use of the message.
638 INITIAL-CONTENTS is filename that is read into an empty buffer, or nil
639 if buffer should not be modified. Delete the initial-contents file if
640 DELETE-CONTENTS-FILE flag is set.
641 Returns the draft folder's name.
642 If the draft folder facility is enabled in ~/.mh_profile, a new buffer is
643 used each time and saved in the draft folder. The draft file can then be
645 (cond (mh-draft-folder
646 (let ((orig-default-dir default-directory
)
647 (draft-file-name (mh-new-draft-name)))
648 (pop-to-buffer (generate-new-buffer
650 (file-name-nondirectory draft-file-name
))))
652 (insert-file-contents draft-file-name t
)
654 (setq default-directory orig-default-dir
)))
656 (let ((draft-name (expand-file-name "draft" mh-user-path
)))
657 (pop-to-buffer "draft") ; Create if necessary
658 (if (buffer-modified-p)
659 (if (y-or-n-p "Draft has been modified; kill anyway? ")
660 (set-buffer-modified-p nil
)
661 (error "Draft preserved")))
662 (setq buffer-file-name draft-name
)
663 (clear-visited-file-modtime)
665 (cond ((and (file-exists-p draft-name
)
666 (not (equal draft-name initial-contents
)))
667 (insert-file-contents draft-name
)
668 (delete-file draft-name
))))))
669 (cond ((and initial-contents
670 (or (zerop (buffer-size))
672 (format "A draft exists. Use for %s? " use
))
673 (if mh-error-if-no-draft
674 (error "A prior draft exists"))
677 (insert-file-contents initial-contents
)
678 (if delete-contents-file
(delete-file initial-contents
))))
681 (save-buffer)) ; Do not reuse draft name
684 (defun mh-new-draft-name ()
685 "Return the pathname of folder for draft messages."
687 (mh-exec-cmd-quiet t
"mhpath" mh-draft-folder
"new")
688 (buffer-substring (point-min) (1- (point-max)))))
690 (defun mh-annotate-msg (msg buffer note
&rest args
)
691 "Mark MSG in BUFFER with character NOTE and annotate message with ARGS.
692 MSG can be a message number, a list of message numbers, or a sequence."
693 (apply 'mh-exec-cmd
"anno" buffer
694 (if (listp msg
) (append msg args
) (cons msg args
)))
696 (cond ((get-buffer buffer
) ; Buffer may be deleted
698 (mh-iterate-on-msg-or-seq nil msg
699 (mh-notate nil note
(1+ mh-cmd-note
)))))))
701 (defun mh-insert-fields (&rest name-values
)
702 "Insert the NAME-VALUES pairs in the current buffer.
703 If the field exists, append the value to it.
704 Do not insert any pairs whose value is the empty string."
705 (let ((case-fold-search t
))
707 (let ((field-name (car name-values
))
708 (value (car (cdr name-values
))))
709 (cond ((equal value
"")
711 ((mh-position-on-field field-name
)
712 (insert " " (or value
"")))
714 (insert field-name
" " value
"\n")))
715 (setq name-values
(cdr (cdr name-values
)))))))
717 (defun mh-position-on-field (field &optional ignored
)
718 "Move to the end of the FIELD in the header.
719 Move to end of entire header if FIELD not found.
720 Returns non-nil iff FIELD was found.
721 The optional second arg is for pre-version 4 compatibility and is IGNORED."
722 (cond ((mh-goto-header-field field
)
723 (mh-header-field-end)
725 ((mh-goto-header-end 0)
728 (defun mh-get-header-field (field)
729 "Find and return the body of FIELD in the mail header.
730 Returns the empty string if the field is not in the header of the
732 (if (mh-goto-header-field field
)
734 (skip-chars-forward " \t") ;strip leading white space in body
735 (let ((start (point)))
736 (mh-header-field-end)
737 (buffer-substring-no-properties start
(point))))
740 (fset 'mh-get-field
'mh-get-header-field
) ;MH-E 4 compatibility
742 (defun mh-goto-header-field (field)
743 "Move to FIELD in the message header.
744 Move to the end of the FIELD name, which should end in a colon.
745 Returns t if found, nil if not."
746 (goto-char (point-min))
747 (let ((case-fold-search t
)
748 (headers-end (save-excursion
749 (mh-goto-header-end 0)
751 (re-search-forward (format "^%s" field
) headers-end t
)))
753 (defun mh-goto-header-end (arg)
754 "Move the cursor ARG lines after the header."
755 (if (re-search-forward "^-*$" nil nil
)
758 (defun mh-extract-from-header-value ()
759 "Extract From: string from header."
761 (if (not (mh-goto-header-field "From:"))
763 (skip-chars-forward " \t")
764 (buffer-substring-no-properties
765 (point) (progn (mh-header-field-end)(point))))))
769 ;;; Mode for composing and sending a draft message.
771 (put 'mh-letter-mode
'mode-class
'special
)
773 ;;; Menu extracted from mh-menubar.el V1.1 (31 July 2001)
774 (eval-when-compile (defvar mh-letter-menu nil
))
776 ((fboundp 'easy-menu-define
)
778 mh-letter-menu mh-letter-mode-map
"Menu for MH-E letter mode."
780 ["Send This Draft" mh-send-letter t
]
781 ["Split Current Line" mh-open-line t
]
782 ["Check Recipient" mh-check-whom t
]
783 ["Yank Current Message" mh-yank-cur-msg t
]
784 ["Insert a Message..." mh-insert-letter t
]
785 ["Insert Signature" mh-insert-signature t
]
787 mh-mml-secure-message-sign-pgpmime mh-gnus-pgp-support-flag
]
788 ["GPG Encrypt message"
789 mh-mml-secure-message-encrypt-pgpmime mh-gnus-pgp-support-flag
]
790 ["Compose Insertion (MIME)..." mh-compose-insertion t
]
791 ;; ["Compose Compressed tar (MIME)..."
792 ;;mh-mhn-compose-external-compressed-tar t]
793 ;; ["Compose Anon FTP (MIME)..." mh-mhn-compose-anon-ftp t]
794 ["Compose Forward (MIME)..." mh-compose-forward t
]
795 ;; The next two will have to be merged. But I also need to make sure the
796 ;; user can't mix directives of both types.
797 ["Pull in All Compositions (mhn)"
798 mh-edit-mhn
(mh-mhn-directive-present-p)]
799 ["Pull in All Compositions (gnus)"
800 mh-mml-to-mime
(mh-mml-directive-present-p)]
801 ["Revert to Non-MIME Edit (mhn)"
802 mh-revert-mhn-edit
(equal mh-compose-insertion
'mhn
)]
803 ["Kill This Draft" mh-fully-kill-draft t
]))))
806 ;;; Group messages logically, more or less.
807 (defvar mh-letter-mode-help-messages
809 "Send letter: \\[mh-send-letter]"
810 "\t\tOpen line: \\[mh-open-line]\n"
811 "Kill letter: \\[mh-fully-kill-draft]"
813 "Check recipients: \\[mh-check-whom]"
814 "\t\t Current message: \\[mh-yank-cur-msg]\n"
815 "Encrypt message: \\[mh-mml-secure-message-encrypt-pgpmime]"
816 "\t\t Attachment: \\[mh-compose-insertion]\n"
817 "Sign message: \\[mh-mml-secure-message-sign-pgpmime]"
818 "\t\t Message to forward: \\[mh-compose-forward]\n"
820 "\t\t Signature: \\[mh-insert-signature]"))
821 "Key binding cheat sheet.
823 This is an associative array which is used to show the most common commands.
824 The key is a prefix char. The value is one or more strings which are
825 concatenated together and displayed in the minibuffer if ? is pressed after
826 the prefix character. The special key nil is used to display the
827 non-prefixed commands.
829 The substitutions described in `substitute-command-keys' are performed as
833 (defun mh-fill-paragraph-function (arg)
834 "Fill paragraph at or after point.
835 Prefix ARG means justify as well. This function enables `fill-paragraph' to
836 work better in MH-Letter mode."
838 (let ((fill-paragraph-function) (fill-prefix))
840 (mail-mode-fill-paragraph arg
)
841 (fill-paragraph arg
))))
843 ;; Avoid compiler warnings in XEmacs and Emacs 20
845 (defvar tool-bar-mode
)
846 (defvar tool-bar-map
))
849 (define-derived-mode mh-letter-mode text-mode
"MH-Letter"
850 "Mode for composing letters in MH-E.\\<mh-letter-mode-map>
852 When you have finished composing, type \\[mh-send-letter] to send the message
853 using the MH mail handling system.
855 There are two types of MIME directives used by MH-E: Gnus and MH. The option
856 `mh-compose-insertion' controls what type of directives are inserted by MH-E
857 commands. These directives can be converted to MIME body parts by running
858 \\[mh-edit-mhn] for mhn directives or \\[mh-mml-to-mime] for Gnus directives.
859 This step is mandatory if these directives are added manually. If the
860 directives are inserted with MH-E commands such as \\[mh-compose-insertion],
861 the directives are expanded automatically when the letter is sent.
863 Options that control this mode can be changed with
864 \\[customize-group]; specify the \"mh-compose\" group.
866 When a message is composed, the hooks `text-mode-hook' and
867 `mh-letter-mode-hook' are run.
869 \\{mh-letter-mode-map}"
871 (or mh-user-path
(mh-find-path))
872 (make-local-variable 'mh-send-args
)
873 (make-local-variable 'mh-annotate-char
)
874 (make-local-variable 'mh-annotate-field
)
875 (make-local-variable 'mh-previous-window-config
)
876 (make-local-variable 'mh-sent-from-folder
)
877 (make-local-variable 'mh-sent-from-msg
)
878 (make-local-variable 'mail-header-separator
)
879 (setq mail-header-separator mh-mail-header-separator
) ;override sendmail.el
880 (make-local-variable 'mh-help-messages
)
881 (setq mh-help-messages mh-letter-mode-help-messages
)
883 ;; From sendmail.el for proper paragraph fill
884 ;; sendmail.el also sets a normal-auto-fill-function (not done here)
885 (make-local-variable 'paragraph-separate
)
886 (make-local-variable 'paragraph-start
)
887 (make-local-variable 'fill-paragraph-function
)
888 (setq fill-paragraph-function
'mh-fill-paragraph-function
)
889 (make-local-variable 'adaptive-fill-regexp
)
890 (setq adaptive-fill-regexp
891 (concat adaptive-fill-regexp
892 "\\|[ \t]*[-[:alnum:]]*>+[ \t]*"))
893 (make-local-variable 'adaptive-fill-first-line-regexp
)
894 (setq adaptive-fill-first-line-regexp
895 (concat adaptive-fill-first-line-regexp
896 "\\|[ \t]*[-[:alnum:]]*>+[ \t]*"))
897 ;; `-- ' precedes the signature. `-----' appears at the start of the
898 ;; lines that delimit forwarded messages.
899 ;; Lines containing just >= 3 dashes, perhaps after whitespace,
900 ;; are also sometimes used and should be separators.
901 (setq paragraph-start
(concat (regexp-quote mail-header-separator
)
902 "\\|\t*\\([-|#;>* ]\\|(?[0-9]+[.)]\\)+$"
903 "\\|[ \t]*[[:alnum:]]*>+[ \t]*$\\|[ \t]*$\\|"
906 (setq paragraph-separate paragraph-start
)
907 ;; --- End of code from sendmail.el ---
909 ;; Enable undo since a show-mode buffer might have been reused.
911 (if (and (boundp 'tool-bar-mode
) tool-bar-mode
)
912 (set (make-local-variable 'tool-bar-map
) mh-letter-tool-bar-map
))
913 (mh-funcall-if-exists mh-toolbar-init
:letter
)
914 (make-local-variable 'font-lock-defaults
)
916 ((or (equal mh-highlight-citation-p
'font-lock
)
917 (equal mh-highlight-citation-p
'gnus
))
918 ;; Let's use font-lock even if gnus is used in show-mode. The reason
919 ;; is that gnus uses static text properties which are not appropriate
920 ;; for a buffer that will be edited. So the choice here is either fontify
921 ;; the citations and header...
922 (setq font-lock-defaults
'(mh-show-font-lock-keywords-with-cite t
)))
924 ;; ...or the header only
925 (setq font-lock-defaults
'(mh-show-font-lock-keywords t
))))
926 (easy-menu-add mh-letter-menu
)
927 (setq fill-column mh-letter-fill-column
)
928 ;; If text-mode-hook turned on auto-fill, tune it for messages
929 (when auto-fill-function
930 (make-local-variable 'auto-fill-function
)
931 (setq auto-fill-function
'mh-auto-fill-for-letter
)))
933 (defun mh-auto-fill-for-letter ()
934 "Perform auto-fill for message.
935 Header is treated specially by inserting a tab before continuation lines."
937 (let ((fill-prefix "\t"))
941 (defun mh-insert-header-separator ()
942 "Insert `mh-mail-header-separator', if absent."
944 (goto-char (point-min))
947 (insert mh-mail-header-separator
))))
950 (defun mh-to-field ()
951 "Move point to the end of a specified header field.
952 The field is indicated by the previous keystroke (the last keystroke
953 of the command) according to the list in the variable `mh-to-field-choices'.
954 Create the field if it does not exist. Set the mark to point before moving."
957 (let ((target (cdr (or (assoc (char-to-string (logior last-input-char ?
`))
959 ;; also look for a char for version 4 compat
960 (assoc (logior last-input-char ?
`)
961 mh-to-field-choices
))))
962 (case-fold-search t
))
964 (cond ((mh-position-on-field target
)
966 (skip-chars-backward " \t")
967 (delete-region (point) eol
))
968 (if (and (not (eq (logior last-input-char ?
`) ?s
))
971 (not (looking-at "[:,]"))))
975 (if (mh-position-on-field "To:")
977 (insert (format "%s \n" target
))
978 (backward-char 1)))))
981 (defun mh-to-fcc (&optional folder
)
982 "Insert an Fcc: FOLDER field in the current message.
983 Prompt for the field name with a completion list of the current folders."
986 (setq folder
(mh-prompt-for-folder
988 (or (and mh-default-folder-for-message-function
990 (goto-char (point-min))
992 mh-default-folder-for-message-function
)))
995 (let ((last-input-char ?\C-f
))
999 (insert (if (mh-folder-name-p folder
)
1000 (substring folder
1)
1004 (defun mh-insert-signature ()
1005 "Insert the file named by `mh-signature-file-name' at point.
1006 The value of `mh-letter-insert-signature-hook' is a list of functions to be
1007 called, with no arguments, before the signature is actually inserted."
1009 (let ((mh-signature-file-name mh-signature-file-name
))
1010 (run-hooks 'mh-letter-insert-signature-hook
)
1011 (if mh-signature-file-name
1012 (insert-file-contents mh-signature-file-name
)))
1013 (force-mode-line-update))
1016 (defun mh-check-whom ()
1017 "Verify recipients of the current letter, showing expansion of any aliases."
1019 (let ((file-name buffer-file-name
))
1021 (message "Checking recipients...")
1022 (mh-in-show-buffer (mh-recipients-buffer)
1023 (bury-buffer (current-buffer))
1025 (mh-exec-cmd-output "whom" t file-name
))
1026 (message "Checking recipients...done")))
1028 (defun mh-tidy-draft-buffer ()
1029 "Run when a draft buffer is destroyed."
1030 (let ((buffer (get-buffer mh-recipients-buffer
)))
1032 (kill-buffer buffer
))))
1036 ;;; Routines to compose and send a letter.
1038 (defun mh-insert-x-face ()
1039 "Append X-Face, Face or X-Image-URL field to header.
1040 If the field already exists, this function does nothing."
1041 (when (and (file-exists-p mh-x-face-file
)
1042 (file-readable-p mh-x-face-file
))
1044 (unless (or (mh-position-on-field "X-Face")
1045 (mh-position-on-field "Face")
1046 (mh-position-on-field "X-Image-URL"))
1048 (goto-char (+ (point) (cadr (insert-file-contents mh-x-face-file
))))
1049 (if (not (looking-at "^"))
1051 (unless (looking-at "\\(X-Face\\|Face\\|X-Image-URL\\): ")
1052 (insert "X-Face: "))))))
1054 (defvar mh-x-mailer-string nil
1055 "*String containing the contents of the X-Mailer header field.
1056 If nil, this variable is initialized to show the version of MH-E, Emacs, and
1057 MH the first time a message is composed.")
1059 (defun mh-insert-x-mailer ()
1060 "Append an X-Mailer field to the header.
1061 The versions of MH-E, Emacs, and MH are shown."
1063 ;; Lazily initialize mh-x-mailer-string.
1064 (when (null mh-x-mailer-string
)
1065 (save-window-excursion
1066 ;; User would be confused if version info buffer disappeared magically,
1067 ;; so don't delete buffer if it already existed.
1068 (let ((info-buffer-exists-p (get-buffer mh-info-buffer
)))
1070 (set-buffer mh-info-buffer
)
1072 (search-forward-regexp "^nmh-\\(\\S +\\)")
1073 (search-forward-regexp "^MH \\(\\S +\\)" nil t
))
1074 (let ((x-mailer-mh (buffer-substring (match-beginning 1)
1076 (setq mh-x-mailer-string
1077 (format "MH-E %s; %s %s; %sEmacs %s"
1078 mh-version
(if mh-nmh-flag
"nmh" "MH") x-mailer-mh
1079 (if mh-xemacs-flag
"X" "GNU ")
1080 (cond ((not mh-xemacs-flag
) emacs-version
)
1081 ((string-match "[0-9.]*\\( +\([ a-z]+[0-9]+\)\\)?"
1083 (match-string 0 emacs-version
))
1086 emacs-minor-version
))))))
1087 (if (not info-buffer-exists-p
)
1088 (kill-buffer mh-info-buffer
)))))
1089 ;; Insert X-Mailer, but only if it doesn't already exist.
1091 (when (null (mh-goto-header-field "X-Mailer"))
1092 (mh-insert-fields "X-Mailer:" mh-x-mailer-string
))))
1094 (defun mh-regexp-in-field-p (regexp &rest fields
)
1095 "Non-nil means REGEXP was found in FIELDS."
1097 (let ((search-result nil
)
1100 (setq field
(car fields
))
1101 (if (and (mh-goto-header-field field
)
1103 regexp
(save-excursion (mh-header-field-end)(point)) t
))
1106 (setq fields
(cdr fields
))))
1109 (defun mh-insert-auto-fields ()
1110 "Insert custom fields if To or Cc match `mh-auto-fields-list'."
1112 (when (and (or (mh-goto-header-field "To:")(mh-goto-header-field "cc:")))
1113 (let ((list mh-auto-fields-list
))
1115 (let ((regexp (nth 0 (car list
)))
1116 (entries (nth 1 (car list
))))
1117 (when (mh-regexp-in-field-p regexp
"To:" "cc:")
1118 (let ((entry-list entries
))
1120 (let ((field (caar entry-list
))
1121 (value (cdar entry-list
)))
1123 ((equal "identity" field
)
1124 (when (assoc value mh-identity-list
)
1125 (mh-insert-identity value
)))
1127 (mh-modify-header-field field value
1128 (equal field
"From")))))
1129 (setq entry-list
(cdr entry-list
))))))
1130 (setq list
(cdr list
)))))))
1132 (defun mh-modify-header-field (field value
&optional overwrite-flag
)
1133 "To header FIELD add VALUE.
1134 If OVERWRITE-FLAG is non-nil then the old value, if present, is discarded."
1135 (cond ((mh-goto-header-field (concat field
":"))
1138 (delete-region (point) (line-end-position))
1140 (t (mh-goto-header-end 0)
1141 (insert field
": " value
"\n"))))
1143 (defun mh-compose-and-send-mail (draft send-args
1144 sent-from-folder sent-from-msg
1146 annotate-char annotate-field
1148 "Edit and compose a draft message in buffer DRAFT and send or save it.
1149 SEND-ARGS is the argument passed to the send command.
1150 SENT-FROM-FOLDER is buffer containing scan listing of current folder, or
1152 SENT-FROM-MSG is the message number or sequence name or nil.
1153 The TO, SUBJECT, and CC fields are passed to the
1154 `mh-compose-letter-function'.
1155 If ANNOTATE-CHAR is non-null, it is used to notate the scan listing of the
1156 message. In that case, the ANNOTATE-FIELD is used to build a string
1157 for `mh-annotate-msg'.
1158 CONFIG is the window configuration to restore after sending the letter."
1159 (pop-to-buffer draft
)
1160 (mh-insert-auto-fields)
1163 ;; mh-identity support
1164 (if (and (boundp 'mh-identity-default
)
1166 (not mh-identity-local
))
1167 (mh-insert-identity mh-identity-default
))
1168 (when (and (boundp 'mh-identity-list
)
1170 (mh-identity-make-menu)
1171 (easy-menu-add mh-identity-menu
))
1173 (setq mh-sent-from-folder sent-from-folder
)
1174 (setq mh-sent-from-msg sent-from-msg
)
1175 (setq mh-send-args send-args
)
1176 (setq mh-annotate-char annotate-char
)
1177 (setq mh-annotate-field annotate-field
)
1178 (setq mh-previous-window-config config
)
1179 (setq mode-line-buffer-identification
(list " {%b}"))
1181 (mh-make-local-hook 'kill-buffer-hook
)
1182 (add-hook 'kill-buffer-hook
'mh-tidy-draft-buffer nil t
)
1183 (if (and (boundp 'mh-compose-letter-function
)
1184 mh-compose-letter-function
)
1185 ;; run-hooks will not pass arguments.
1186 (let ((value mh-compose-letter-function
))
1187 (if (and (listp value
) (not (eq (car value
) 'lambda
)))
1189 (funcall (car value
) to subject cc
)
1190 (setq value
(cdr value
)))
1191 (funcall mh-compose-letter-function to subject cc
)))))
1193 (defun mh-letter-mode-message ()
1194 "Display a help message for users of `mh-letter-mode'.
1195 This should be the last function called when composing the draft."
1196 (message "%s" (substitute-command-keys
1197 (concat "Type \\[mh-send-letter] to send message, "
1198 "\\[mh-help] for help."))))
1201 (defun mh-send-letter (&optional arg
)
1202 "Send the draft letter in the current buffer.
1203 If optional prefix argument ARG is provided, monitor delivery.
1204 The value of `mh-before-send-letter-hook' is a list of functions to be called,
1205 with no arguments, before doing anything.
1206 Run `\\[mh-edit-mhn]' if mhn directives are present; otherwise
1207 run `\\[mh-mml-to-mime]' if mml directives are present.
1208 Insert X-Mailer field if variable `mh-insert-x-mailer-flag' is set.
1209 Insert X-Face field if the file specified by `mh-x-face-file' exists."
1211 (run-hooks 'mh-before-send-letter-hook
)
1212 (cond ((mh-mhn-directive-present-p)
1214 ((mh-mml-directive-present-p)
1216 (if mh-insert-x-mailer-flag
(mh-insert-x-mailer))
1219 (message "Sending...")
1220 (let ((draft-buffer (current-buffer))
1221 (file-name buffer-file-name
)
1222 (config mh-previous-window-config
)
1223 (coding-system-for-write
1224 (if (and (local-variable-p 'buffer-file-coding-system
1225 (current-buffer)) ;XEmacs needs two args
1226 ;; We're not sure why, but buffer-file-coding-system
1227 ;; tends to get set to undecided-unix.
1228 (not (memq buffer-file-coding-system
1229 '(undecided undecided-unix undecided-dos
))))
1230 buffer-file-coding-system
1231 (or (and (boundp 'sendmail-coding-system
) sendmail-coding-system
)
1232 (and (boundp 'default-buffer-file-coding-system
)
1233 default-buffer-file-coding-system
)
1235 ;; The default BCC encapsulation will make a MIME message unreadable.
1236 ;; With nmh use the -mime arg to prevent this.
1237 (if (and mh-nmh-flag
1238 (mh-goto-header-field "Bcc:")
1239 (mh-goto-header-field "Content-Type:"))
1240 (setq mh-send-args
(format "-mime %s" mh-send-args
)))
1242 (pop-to-buffer mh-mail-delivery-buffer
)
1244 (mh-exec-cmd-output mh-send-prog t
"-watch" "-nopush"
1245 "-nodraftfolder" mh-send-args file-name
)
1246 (goto-char (point-max)) ; show the interesting part
1248 (set-buffer draft-buffer
)) ; for annotation below
1250 (mh-exec-cmd-daemon mh-send-prog nil
"-nodraftfolder" "-noverbose"
1251 mh-send-args file-name
)))
1252 (if mh-annotate-char
1253 (mh-annotate-msg mh-sent-from-msg
1256 "-component" mh-annotate-field
1257 "-text" (format "\"%s %s\""
1258 (mh-get-header-field "To:")
1259 (mh-get-header-field "Cc:"))))
1261 (cond ((or (not arg
)
1262 (y-or-n-p "Kill draft buffer? "))
1263 (kill-buffer draft-buffer
)
1265 (set-window-configuration config
))))
1267 (message "Sending...done")
1268 (message "Sending...backgrounded"))))
1271 (defun mh-insert-letter (folder message verbatim
)
1272 "Insert a message into the current letter.
1273 Removes the header fields according to the variable `mh-invisible-headers'.
1274 Prefixes each non-blank line with `mh-ins-buf-prefix', unless
1275 `mh-yank-from-start-of-msg' is set for supercite in which case supercite is
1276 used to format the message.
1277 Prompts for FOLDER and MESSAGE. If prefix argument VERBATIM provided, do
1278 not indent and do not delete headers. Leaves the mark before the letter
1279 and point after it."
1281 (list (mh-prompt-for-folder "Message from" mh-sent-from-folder nil
)
1282 (read-input (format "Message number%s: "
1283 (if (numberp mh-sent-from-msg
)
1284 (format " [%d]" mh-sent-from-msg
)
1286 current-prefix-arg
))
1288 (narrow-to-region (point) (point))
1289 (let ((start (point-min)))
1290 (if (equal message
"") (setq message
(int-to-string mh-sent-from-msg
)))
1291 (insert-file-contents
1292 (expand-file-name message
(mh-expand-file-name folder
)))
1293 (when (not verbatim
)
1294 (mh-clean-msg-header start mh-invisible-headers mh-visible-headers
)
1295 (goto-char (point-max)) ;Needed for sc-cite-original
1296 (push-mark) ;Needed for sc-cite-original
1297 (goto-char (point-min)) ;Needed for sc-cite-original
1298 (mh-insert-prefix-string mh-ins-buf-prefix
)))))
1300 (defun mh-extract-from-attribution ()
1301 "Extract phrase or comment from From header field."
1303 (if (not (mh-goto-header-field "From: "))
1305 (skip-chars-forward " ")
1307 ((looking-at "\"\\([^\"\n]+\\)\" \\(<.+>\\)")
1308 (format "%s %s %s" (match-string 1)(match-string 2)
1309 mh-extract-from-attribution-verb
))
1310 ((looking-at "\\([^<\n]+<.+>\\)$")
1311 (format "%s %s" (match-string 1) mh-extract-from-attribution-verb
))
1312 ((looking-at "\\([^ ]+@[^ ]+\\) +(\\(.+\\))$")
1313 (format "%s <%s> %s" (match-string 2)(match-string 1)
1314 mh-extract-from-attribution-verb
))
1315 ((looking-at " *\\(.+\\)$")
1316 (format "%s %s" (match-string 1) mh-extract-from-attribution-verb
))))))
1319 (defun mh-yank-cur-msg ()
1320 "Insert the current message into the draft buffer.
1321 Prefix each non-blank line in the message with the string in
1322 `mh-ins-buf-prefix'. If a region is set in the message's buffer, then
1323 only the region will be inserted. Otherwise, the entire message will
1324 be inserted if `mh-yank-from-start-of-msg' is non-nil. If this variable
1325 is nil, the portion of the message following the point will be yanked.
1326 If `mh-delete-yanked-msg-window-flag' is non-nil, any window displaying the
1327 yanked message will be deleted."
1329 (if (and mh-sent-from-folder
1330 (save-excursion (set-buffer mh-sent-from-folder
) mh-show-buffer
)
1331 (save-excursion (set-buffer mh-sent-from-folder
)
1332 (get-buffer mh-show-buffer
))
1334 (let ((to-point (point))
1335 (to-buffer (current-buffer)))
1336 (set-buffer mh-sent-from-folder
)
1337 (if mh-delete-yanked-msg-window-flag
1338 (delete-windows-on mh-show-buffer
))
1339 (set-buffer mh-show-buffer
) ; Find displayed message
1340 (let* ((from-attr (mh-extract-from-attribution))
1341 (yank-region (mh-mark-active-p nil
))
1343 (cond ((and yank-region
1344 (or (eq 'supercite mh-yank-from-start-of-msg
)
1345 (eq 'autosupercite mh-yank-from-start-of-msg
)
1346 (eq t mh-yank-from-start-of-msg
)))
1347 ;; supercite needs the full header
1349 (buffer-substring (point-min) (mh-mail-header-end))
1351 (buffer-substring (region-beginning) (region-end))))
1353 (buffer-substring (region-beginning) (region-end)))
1354 ((or (eq 'body mh-yank-from-start-of-msg
)
1356 mh-yank-from-start-of-msg
)
1358 mh-yank-from-start-of-msg
))
1361 (goto-char (point-min))
1362 (mh-goto-header-end 1)
1365 ((or (eq 'supercite mh-yank-from-start-of-msg
)
1366 (eq 'autosupercite mh-yank-from-start-of-msg
)
1367 (eq t mh-yank-from-start-of-msg
))
1368 (buffer-substring (point-min) (point-max)))
1370 (buffer-substring (point) (point-max))))))
1371 (set-buffer to-buffer
)
1373 (narrow-to-region to-point to-point
)
1374 (insert (mh-filter-out-non-text mh-ins-str
))
1375 (goto-char (point-max)) ;Needed for sc-cite-original
1376 (push-mark) ;Needed for sc-cite-original
1377 (goto-char (point-min)) ;Needed for sc-cite-original
1378 (mh-insert-prefix-string mh-ins-buf-prefix
)
1379 (if (or (eq 'attribution mh-yank-from-start-of-msg
)
1380 (eq 'autoattrib mh-yank-from-start-of-msg
))
1381 (insert from-attr
"\n\n"))
1382 ;; If the user has selected a region, he has already "edited" the
1383 ;; text, so leave the cursor at the end of the yanked text. In
1384 ;; either case, leave a mark at the opposite end of the included
1385 ;; text to make it easy to jump or delete to the other end of the
1388 (goto-char (point-max))
1389 (if (null yank-region
)
1390 (mh-exchange-point-and-mark-preserving-active-mark)))))
1391 (error "There is no current message")))
1393 (defun mh-filter-out-non-text (string)
1394 "Return STRING but without adornments such as MIME buttons and smileys."
1396 ;; Insert the string to filter
1398 (goto-char (point-min))
1400 ;; Remove the MIME buttons
1401 (let ((can-move-forward t
)
1403 (while can-move-forward
1404 (cond ((and (not (get-text-property (point) 'mh-data
))
1406 (delete-region (1- (point)) (point))
1407 (setq in-button nil
))
1408 ((get-text-property (point) 'mh-data
)
1409 (delete-region (point)
1410 (save-excursion (forward-line) (point)))
1412 (t (setq can-move-forward
(= (forward-line) 0))))))
1414 ;; Return the contents without properties... This gets rid of emphasis
1416 (buffer-substring-no-properties (point-min) (point-max))))
1418 (defun mh-insert-prefix-string (mh-ins-string)
1419 "Insert prefix string before each line in buffer.
1420 The inserted letter is cited using `sc-cite-original' if
1421 `mh-yank-from-start-of-msg' is one of 'supercite or 'autosupercite. Otherwise,
1422 simply insert MH-INS-STRING before each line."
1423 (goto-char (point-min))
1424 (cond ((or (eq mh-yank-from-start-of-msg
'supercite
)
1425 (eq mh-yank-from-start-of-msg
'autosupercite
))
1428 (run-hooks 'mail-citation-hook
))
1429 (mh-yank-hooks ;old hook name
1430 (run-hooks 'mh-yank-hooks
))
1432 (or (bolp) (forward-line 1))
1433 (while (< (point) (point-max))
1434 (insert mh-ins-string
)
1436 (goto-char (point-min))))) ;leave point like sc-cite-original
1439 (defun mh-fully-kill-draft ()
1440 "Kill the draft message file and the draft message buffer.
1441 Use \\[kill-buffer] if you don't want to delete the draft message file."
1443 (if (y-or-n-p "Kill draft message? ")
1444 (let ((config mh-previous-window-config
))
1445 (if (file-exists-p buffer-file-name
)
1446 (delete-file buffer-file-name
))
1447 (set-buffer-modified-p nil
)
1448 (kill-buffer (buffer-name))
1451 (set-window-configuration config
)))
1452 (error "Message not killed")))
1454 (defun mh-current-fill-prefix ()
1455 "Return the `fill-prefix' on the current line as a string."
1458 ;; This assumes that the major-mode sets up adaptive-fill-regexp
1459 ;; correctly such as mh-letter-mode or sendmail.el's mail-mode. But
1460 ;; perhaps I should use the variable and simply inserts its value here,
1461 ;; and set it locally in a let scope. --psg
1462 (if (re-search-forward adaptive-fill-regexp nil t
)
1467 (defun mh-open-line ()
1468 "Insert a newline and leave point after it.
1469 In addition, insert newline and quoting characters before text after point.
1470 This is useful in breaking up paragraphs in replies."
1472 (let ((column (current-column))
1473 (prefix (mh-current-fill-prefix)))
1474 (if (> (length prefix
) column
)
1475 (message "Sorry, point seems to be within the line prefix")
1478 (while (> column
(current-column))
1480 (forward-line -
1))))
1482 (mh-do-in-xemacs (defvar mail-abbrevs
))
1484 (defun mh-folder-expand-at-point ()
1485 "Do folder name completion in Fcc header field."
1486 (let* ((end (point))
1487 (syntax-table (syntax-table))
1488 (beg (unwind-protect
1490 (mh-funcall-if-exists mail-abbrev-make-syntax-table
)
1491 (set-syntax-table mail-abbrev-syntax-table
)
1494 (set-syntax-table syntax-table
)))
1495 (folder (buffer-substring beg end
))
1496 (leading-plus (and (> (length folder
) 0) (equal (aref folder
0) ?
+)))
1497 (last-slash (mh-search-from-end ?
/ folder
))
1498 (prefix (and last-slash
(substring folder
0 last-slash
)))
1500 (mapcar #'(lambda (x)
1501 (list (cond (prefix (format "%s/%s" prefix x
))
1502 (leading-plus (format "+%s" x
))
1504 (mh-folder-completion-function folder nil t
))))
1505 (if (fboundp 'mail-abbrev-complete-alias
)
1506 (mh-funcall-if-exists mail-abbrev-complete-alias
)
1507 (error "Fcc completion not supported in your version of Emacs"))))
1510 (defun mh-letter-complete (arg)
1511 "Perform completion on header field or word preceding point.
1512 Alias completion is done within the mail header on selected fields and
1513 by the function designated by `mh-letter-complete-function' elsewhere,
1514 passing the prefix ARG if any."
1516 (let ((case-fold-search t
))
1518 ((and (mh-in-header-p)
1520 (mh-header-field-beginning)
1521 (looking-at "^fcc:")))
1522 (mh-folder-expand-at-point))
1523 ((and (mh-in-header-p)
1525 (mh-header-field-beginning)
1526 (looking-at "^.*\\(to\\|cc\\|from\\):")))
1527 (mh-alias-letter-expand-alias))
1529 (funcall mh-letter-complete-function arg
)))))
1531 ;;; Build the letter-mode keymap:
1532 ;;; If this changes, modify mh-letter-mode-help-messages accordingly, above.
1533 (gnus-define-keys mh-letter-mode-map
1535 "\C-c\C-c" mh-send-letter
1536 "\C-c\C-d" mh-insert-identity
1537 "\C-c\C-e" mh-edit-mhn
1538 "\C-c\C-f\C-b" mh-to-field
1539 "\C-c\C-f\C-c" mh-to-field
1540 "\C-c\C-f\C-d" mh-to-field
1541 "\C-c\C-f\C-f" mh-to-fcc
1542 "\C-c\C-f\C-r" mh-to-field
1543 "\C-c\C-f\C-s" mh-to-field
1544 "\C-c\C-f\C-t" mh-to-field
1545 "\C-c\C-fb" mh-to-field
1546 "\C-c\C-fc" mh-to-field
1547 "\C-c\C-fd" mh-to-field
1548 "\C-c\C-ff" mh-to-fcc
1549 "\C-c\C-fr" mh-to-field
1550 "\C-c\C-fs" mh-to-field
1551 "\C-c\C-ft" mh-to-field
1552 "\C-c\C-i" mh-insert-letter
1553 "\C-c\C-m\C-e" mh-mml-secure-message-encrypt-pgpmime
1554 "\C-c\C-m\C-f" mh-compose-forward
1555 "\C-c\C-m\C-i" mh-compose-insertion
1556 "\C-c\C-m\C-m" mh-mml-to-mime
1557 "\C-c\C-m\C-s" mh-mml-secure-message-sign-pgpmime
1558 "\C-c\C-m\C-u" mh-revert-mhn-edit
1559 "\C-c\C-me" mh-mml-secure-message-encrypt-pgpmime
1560 "\C-c\C-mf" mh-compose-forward
1561 "\C-c\C-mi" mh-compose-insertion
1562 "\C-c\C-mm" mh-mml-to-mime
1563 "\C-c\C-ms" mh-mml-secure-message-sign-pgpmime
1564 "\C-c\C-mu" mh-revert-mhn-edit
1565 "\C-c\C-o" mh-open-line
1566 "\C-c\C-q" mh-fully-kill-draft
1567 "\C-c\C-\\" mh-fully-kill-draft
;if no C-q
1568 "\C-c\C-s" mh-insert-signature
1569 "\C-c\C-^" mh-insert-signature
;if no C-s
1570 "\C-c\C-w" mh-check-whom
1571 "\C-c\C-y" mh-yank-cur-msg
1572 "\M-\t" mh-letter-complete
)
1574 ;; "C-c /" prefix is used in mh-letter-mode by pgp.el and mailcrypt.el.
1576 ;;;###autoload(add-to-list 'auto-mode-alist '("/drafts/[0-9]+\\'" . mh-letter-mode))
1580 ;;; Local Variables:
1581 ;;; indent-tabs-mode: nil
1582 ;;; sentence-end-double-space: nil
1585 ;;; mh-comp.el ends here