Mercurial > emacs
changeset 48595:8aaba207e44b
Upgraded to MH-E version 7.0.
| author | Bill Wohler <wohler@newt.com> |
|---|---|
| date | Fri, 29 Nov 2002 18:15:21 +0000 |
| parents | 1ccd9291b0b2 |
| children | 65f924c09e6d |
| files | etc/ChangeLog etc/MH-E-NEWS etc/NEWS lisp/ChangeLog lisp/mail/mh-comp.el lisp/mail/mh-e.el lisp/mail/mh-funcs.el lisp/mail/mh-index.el lisp/mail/mh-mime.el lisp/mail/mh-pick.el lisp/mail/mh-seq.el lisp/mail/mh-speed.el lisp/mail/mh-utils.el lisp/mail/mh-xemacs-compat.el lisp/toolbar/reply-all.pbm lisp/toolbar/reply-all.xpm lisp/toolbar/reply-from.pbm lisp/toolbar/reply-from.xpm lisp/toolbar/reply-to.pbm lisp/toolbar/reply-to.xpm |
| diffstat | 20 files changed, 7773 insertions(+), 1663 deletions(-) [+] |
line wrap: on
line diff
--- a/etc/ChangeLog Fri Nov 29 18:02:52 2002 +0000 +++ b/etc/ChangeLog Fri Nov 29 18:15:21 2002 +0000 @@ -1,3 +1,7 @@ +2002-11-29 Bill Wohler <wohler@newt.com> + + * MH-E-NEWS: Upgraded to MH-E version 7.0. + 2002-11-22 Juanma Barranquero <lektu@terra.es> * TUTORIAL.es: Extensively changed and updated by Rafael Sep,Az(Blveda
--- a/etc/MH-E-NEWS Fri Nov 29 18:02:52 2002 +0000 +++ b/etc/MH-E-NEWS Fri Nov 29 18:15:21 2002 +0000 @@ -1,3 +1,377 @@ +* Changes in mh-e 7.0 + +This is a major release which includes a lot of new features including +improved MIME handling, speedbar folder browsing, and indexed +searching. In this version, MH-E runs under XEmacs, passes checkdoc, +and compiles clean under all supported platforms. + +The "passes checkdoc" feature above required changing the name of +several user-visible variables. It is likely that this affects you. +Please be sure to see the table at the end of these notes and rename +your variables accordingly. + +MH-E has been written mh-e, Mh-e, MH-e and MH-E. We have decided that +the proper term should be MH-E. Please try to use MH-E in your +writing. + +** New Features in MH-E 7.0 + +*** Speedbar + +There is now support for the speedbar. Try "M-x speedbar" (closes SF +#503727). + +Press the middle mouse button on the `+' icons to open a folder, +middle mouse button on a folder name to open the folder. Folders with +unseen messages are shown in bold, so this is a handy way to browse +new messages that you have filed with procmail or slocal. + +See the new customization variable `mh-large-folder,' which controls +when the speedbar asks for how many messages to scan when opening a +large folder and `mh-speed-run-flists-flag' whose default value of t +means to use the flists command to populate the count of unseen and +total messages in each folder. + +*** Indexed Search + +Interoperability with swish++, swish, glimpse, and namazu has been +added to enable lightening-fast searches of your mail. If none of +these are present, grep is used. Try "F i (mh-index-search)". + +For more information, read the documentation for the functions +`mh-swish++-execute-search,' `mh-swish-execute-search,' +`mh-namazu-execute-search,' or `mh-glimpse-execute-search' depending +on your preferred indexing program to see what kind of setup is needed +to generate the index. + +*** Threading + +Use "T t (mh-toggle-threads)" to view the threads in the folder. Use +it again to return to a non-threaded view. + +*** Brief Help + +Use "? (mh-help)" and "X ? (mh-prefix-help)," where X is a prefix +character, for a brief synopsis in the minibuffer of frequently used +commands. In the MH-Letter or MH-Pick buffers, use "C-c ? (mh-help)" +(closes SF #493740). + +*** Folder Keymap Shared by Show Buffer + +You can now use the MH-Folder mode commands from the MH-Show buffer. +Because of this, the MH-Show buffer is now read-only (closes SF +#493749 and SF #527946) and you now have to use "M (mh-modify)" to +edit a message. + +*** Better Scanning + +You no longer have to modify your scan format if your folders have +more than 9999 messages in them. If you've only modified your scan +format file to allow for the wider message numbers, consider using the +default behavior of MH-E and simplify your MH-E configuration +considerably (closes SF #635791). + +To do this, you may have to remove your modifications of +`mh-scan.*-regexp' and `mh-cmd-note' and your customization of +`mh-scan-format-file'. + +You may still want the updated format files for running MH commands +outside of MH-E; the default of `mh-scan-format-file' will cause them +to be ignored. + +If you prefer fixed-width message numbers, set the new customization +variable to nil , set this variable to +nil and call `mh-set-cmd-note' with the width specified by the scan format in +`mh-scan-format-file'. For example, the default width is 4, so you would use +"(mh-set-cmd-note 4)" if `mh-scan-format-file' were nil. + +*** X-Face + +MH-E now displays the content of the X-Face header field in the From +field. When sending a message, an X-Face field is appended to the +header if it doesn't already exist and "~/.face" is present. See the +new customization variables `mh-show-use-xface-flag' and `mh-x-face-file' +(closes SF #480770). + +MH-E depends on the external x-face package found in +ftp://ftp.jpl.org/pub/elisp/ to do this. The `uncompface' binary is +also required to be in the execute PATH. It can be obtained from: +http://freshmeat.net/redir/compface/1439/url_tgz/compface-1.4.tar.gz. + +It has also been observed that if you don't see the faces, you might +have to do this (for unknown reasons): + + mv /usr/local/include/compface.h /usr/include/ + +*** Graphical Smileys + +Smiley's are now converted to cute little images. See the new +customization variable `mh-graphical-smileys-flag.' + +*** Text Emphasis + +ASCII formatting is now converted to the appropriate font. For +example, _underline_ is underlined, *bold* appears in bold, /italic/ +appears in italic, etc. See `gnus-emphasis-alist' for the whole list. +See the new customization variables `mh-decode-mime' and +`mh-graphical-emphasis-flag.' + +*** Attachment Handling + +Inline attachments are now displayed. Regular attachments appear as +buttons in show buffer. Use "K TAB (mh-next-button)" or "K SHIFT-TAB +(mh-prev-button)" to cycle through these buttons. Use "K v +(mh-folder-toggle-mime-part)" to view, "K o +(mh-folder-save-mime-part)" to save one part or "K-a +(mh-save-mime-parts)" to save all parts, or "K i +(mh-folder-inline-mime-part)" to view the attachment inline. + +See the new customization variable `mh-decode-mime' for additional +information. Other customization variables that affect this new feature +include `mh-store-mime-parts-default-directory' and +`mh-display-buttons-for-inline-parts-flag'. + +HTML documents can be viewed inline if Gnus v5.10 and w3 or w3m lisp +packages are present. Set the customization variable +`mm-text-html-renderer' accordingly (closes SF #453352). + +*** Quoted-printable Handling + +Quoted-printable body parts are now decoded. + +*** More Choices for `mh-yank-from-start-of-msg' + +Historically, if this variable was t, the entire message, with full +headers would be included and every line would begin with +`mh-ins-buf-prefix.' This usage is deprecated in favor of the setting +`supercite' below. The default has been changed to `attribution.' The +following symbols are now understood: + +`body': yank the message minus the header. + +`supercite': include the entire message, with full headers. This also +causes the invocation of `sc-cite-original' without the setting of +`mail-citation-hook', now deprecated practice. + +`autosupercite': do as for `supercite' automatically when show buffer +matches the message being replied-to. + +`attribution': yank the message minus the header and add a simple +attribution line at the top. + +`autoattrib': do as for `attribution' automatically when show buffer +matches the message being replied-to. + +There is a new customization variable called +`mh-extract-from-attribution-verb' which is used for attribution which +provides a method for setting a different language. + +*** Use Gnus mml Instead of mhn + +When inserting attachments into a message draft, Gnus mml directives +are now used instead of mhn directives. One beneficial side-effect of +this is that attachments can now appear inline as well as separate. + +The new customization variable `mh-compose-insertion' controls whether +Gnus or mhn is used to insert MIME message directives in messages +(default: 'gnus, if the mml library exists). + +*** Content-Type Now Obtained Automatically + +The value of the Content-Type no longer needs to be entered by the +user. + +*** Attachments Automatically Included Upon Send + +You no longer have to run "C-c C-e (mh-edit-mhn)" before sending a +message with attachments--this is done automatically when you send the +message with "C-c C-c (mh-send-letter)". There is, however, a new key +binding "C-c C-m m (mh-mml-to-mime)" which is analogous to "C-c C-e +(mh-edit-mhn)". + +*** GPG Handling + +Messages that have been signed or encrypted with GPG are verified and +decrypted automatically. To sign or encrypt a message, use "C-c RET +C-s (mh-mml-secure-message-sign-pgpmime)" and "C-c C-m C-e +(mh-mml-secure-message-encrypt-pgpmime)." You need Gnus version 5.10 +for this feature. These functions are provided by the pgg.el package. + +Users report "flashing" with the pgg.el package and prefer the gpg.el +package instead. To use gpg.el instead of the pgg.el package you need: + + (setq mml2015-use 'gpg) + +To mimic automatic encryption in gpg.el, use: + + (setq mm-verify-option 'always) + (setq mm-decrypt-option 'always) + +The venerable mailcrypt package is also an option. However, now that +show buffers are read-only, mailcrypt version 3.5.6 and older fail +when they attempt to decrypt the contents. + +*** Mail-Followup-To Header Field + +Support for this controversial field has been added because nmh +supports it (closes SF #627035). If you want to add it to outgoing +mail for selected mailing lists, add those mailing lists to the new +customization variable `mh-insert-mail-followup-to-list.' If you think +this field is evil, set the new customization variable +`mh-insert-mail-followup-to-flag' to nil. + +*** Gnus Issues + +If you update Gnus, you must recompile MH-E. Note that if you are +running the stock version of MH-E that comes with Emacs or the MH-E +package on a Debian GNU/Linux, this is done for you. + +** New Variables in MH-E 7.0 + +New customization variables not mentioned earlier include: + +*** mh-letter-insert-signature-hook + +Invoked at the beginning of the "C-c C-s (mh-insert-signature)" +command. Can be used to determine which signature file to use based on +message content. On return, if `mh-signature-file-name' is non-nil +that file will be inserted at the current point in the buffer. + +*** mh-show-maximum-size + +Maximum size of message (in bytes) to display automatically. Provides +an opportunity to skip over large messages which may be slow to load. +Use a value of 0 to display all messages automatically regardless of +size (closes SF #488696). + +*** mh-tool-bar-reply-3-buttons-flag + +Non-nil means use three buttons for reply commands in tool-bar. If you +have room on your tool-bar because you are using a large font, you may +set this variable to expand the single reply button into three buttons +that won't lead to minibuffer prompt about who to reply to. + +** Bug Fixes in MH-E 7.0 + +*** mh-delete-msg, mh-refile-msg, mh-undo + +Mandrake Linux includes XEmacs initialization code that binds +`transient-mark-mode' which causes problems in MH-E. These problems +have been fixed (closes SF #541915). + +*** mh-edit-again + +This would sometimes yield a read-only buffer. This has been fixed +(closes SF #624283 and SF #625538). + +*** mh-forward + +When using nmh, always specify -mime so as to preserve the original +message(s). + +*** mh-inc-folder + +If you had narrowed to a sequence and then incorporated new mail, +those new messages would not be present in your +inbox when you +widened. This has been fixed (closes SF #489430, SF #489437, SF +#629233). + +*** mh-insert-letter + +No longer uses mhl to include a message as this mangled the header and +gave supercite fits (closes SF #629153). + +*** mh-letter-mode + +"M-q (fill-paragraph)" now fills quoted paragraphs (for example, +starting with "> ") correctly (closes SF #489927). + +*** mh-next-undeleted-msg, mh-previous-undeleted-msg + +If there are no more undeleted messages the point remains at its +original position and a message is produced (closes SF #494304). + +*** mh-pick-mode + +Now calls `mh-pick-mode-hook' as documented. + +*** mh-put-msg-in-seq + +Now puts all messages in region in sequence (closes SF #630324). + +*** mh-refile-msg, mh-write-msg-to-file + +These functions stomped on the variables that held the name of the +last file and folder respectively for the other function. This has +been fixed so that the last folder or file name is preserved (closes +SF #580772). + +*** mh-region-to-sequence + +If the region in MH-Folder was set with "C-x h (mark-whole-buffer)", +you couldn't perform operations on all of the messages as you would +expect. This has been fixed (closes SF #621632). + +*** mh-reply + +Performing an undo the first thing after replying would blank out the +entire draft. Now just the insertion of the yanked message is undone +leaving the header and signature intact for additional editing (closes +SF #623693). + +*** mh-show-mode + +Now calls `mh-show-mode-hook' as documented (closes SF #627222). + +*** mh-subject-thread-to-sequence + +Make 'subject sequence a real one, exported to MH. This means you can, +for example, mh-forward it. But it also shows up with a mark in the +scan output (closes SF #489445). + +*** Other Bug Fixes + +The following bugs have also been closed: + +SF #495450: Folder buffer read-only after inc +SF #489706: mh-page-msg bombs out +SF #580772: mh-last-destination is overloaded + +*** Variables renamed to conform with Emacs coding conventions + +The coding conventions require that boolean variables end in -flag. +The following two tables show which variables were affected (closes SF +#627015). + +Customization Variables (defcustom) + +Old Name New Name + +mh-auto-folder-collect mh-auto-folder-collect-flag +mh-bury-show-buffer mh-bury-show-buffer-flag +mh-clean-message-header mh-clean-message-header-flag +mh-decode-quoted-printable mh-decode-quoted-printable-flag +mh-delete-yanked-msg-window mh-delete-yanked-msg-window-flag +mh-do-not-confirm mh-do-not-confirm-flag +mh-highlight-citation-p mh-highlight-citation +mh-insert-x-mailer-p mh-insert-x-mailer-flag +mh-print-background mh-print-background-flag +mh-recenter-summary-p mh-recenter-summary-flag +mh-recursive-folders mh-recursive-folders-flag +mh-reply-show-message-p mh-reply-show-message-flag +mh-show-use-goto-addr mh-show-use-goto-addr-flag +mh-update-sequences-after-mh-show mh-update-sequences-after-mh-show-flag + +Regular Variables (defvar) + +Old Name New Name + +mh-mhn-compose-insert-p mh-mhn-compose-insert-flag +mh-nmh-p mh-nmh-flag +mh-page-to-next-msg-p mh-page-to-next-msg-flag + + + * Changes in mh-e 6.1 This is a minor release which includes a few bug fixes. The @@ -34,7 +408,7 @@ *** mh-quit -mh-quit now cleans up the buffers named `mh-temp-buffer, +mh-quit now cleans up the buffers named `mh-temp-buffer,' 'mh-temp-folders-buffer' and 'mh-temp-sequences-buffer.'
--- a/etc/NEWS Fri Nov 29 18:02:52 2002 +0000 +++ b/etc/NEWS Fri Nov 29 18:15:21 2002 +0000 @@ -90,7 +90,7 @@ ** MH-E changes. -Upgraded to mh-e version 6.1.1. There have been major changes since +Upgraded to mh-e version 7.0. There have been major changes since version 5.0.2; see MH-E-NEWS for details. +++
--- a/lisp/ChangeLog Fri Nov 29 18:02:52 2002 +0000 +++ b/lisp/ChangeLog Fri Nov 29 18:15:21 2002 +0000 @@ -1,3 +1,18 @@ +2002-11-29 Bill Wohler <wohler@newt.com> + + * mail/mh-comp.el, mail/mh-e.el, mail/mh-funcs.el, + mail/mh-mime.el, mail/mh-pick.el, mail/mh-seq.el, + mail/mh-utils.el, mail/mh-xemacs-compat.el: Upgraded to MH-E + version 7.0. + + * mail/mh-index.el, mail/mh-speed.el: New files for indexed + searches and speedbar support in MH-E version 7.0. + + * toolbar/reply-all.pbm, toolbar/reply-all.xpm, + toolbar/reply-from.pbm, toolbar/reply-from.xpm, + toolbar/reply-to.pbm, toolbar/reply-to.xpm: New toolbar images for + MH-E version 7.0. + 2002-11-29 Markus Rost <rost@math.ohio-state.edu> * mwheel.el (mouse-wheel-inhibit-click-time): Fix custom type.
--- a/lisp/mail/mh-comp.el Fri Nov 29 18:02:52 2002 +0000 +++ b/lisp/mail/mh-comp.el Fri Nov 29 18:15:21 2002 +0000 @@ -1,4 +1,4 @@ -;;; mh-comp.el --- mh-e functions for composing messages +;;; mh-comp.el --- MH-E functions for composing messages ;; Copyright (C) 1993,1995,1997,2000,2001,2002 Free Software Foundation, Inc. @@ -26,21 +26,42 @@ ;;; Commentary: -;; Internal support for mh-e package. +;; Internal support for MH-E package. ;;; Change Log: -;; $Id: mh-comp.el,v 1.56 2002/04/07 19:20:56 wohler Exp $ +;; $Id: mh-comp.el,v 1.145 2002/11/29 16:49:43 wohler Exp $ ;;; Code: -(provide 'mh-comp) (require 'mh-e) (require 'mh-utils) (require 'gnus-util) (require 'easymenu) +(require 'cl) + +;; Shush the byte-compiler +(defvar adaptive-fill-first-line-regexp) +(defvar font-lock-defaults) +(defvar mark-active) +(defvar sendmail-coding-system) +(defvar tool-bar-mode) ;;; autoloads from mh-mime +(autoload 'mh-press-button "mh-mime") + +;;; autoloads for mh-seq +(autoload 'mh-notate-seq "mh-seq") + +(autoload 'mh-compose-insertion "mh-mime" + "Add a MIME directive to insert a file, using mhn or gnus. +If the variable mh-compose-insertion is set to 'mhn, then that will be used. +If it is set to 'gnus, then that will be used instead.") + +(autoload 'mh-compose-forward "mh-mime" + "Add a MIME directive to forward a message, using mhn or gnus. +If the variable mh-compose-insertion is set to 'mhn, then that will be used. +If it is set to 'gnus, then that will be used instead.") (autoload 'mh-mhn-compose-insertion "mh-mime" "Add a directive to insert a MIME message part from a file. @@ -84,19 +105,69 @@ "Undoes the effect of \\[mh-edit-mhn] by reverting to the backup file. Optional non-nil argument means don't ask for confirmation." t) +(autoload 'mh-mml-to-mime "mh-mime" + "Compose MIME message from mml directives.") + +(autoload 'mh-mml-forward-message "mh-mime" + "Forward a message as attachment. +The function will prompt the user for a description, a folder and message +number.") + +(autoload 'mh-mml-attach-file "mh-mime" + "Attach a file to the outgoing MIME message. +The file is not inserted or encoded until you send the message with +`\\[message-send-and-exit]' or `\\[message-send]'. + +Message dispostion is \"inline\" is INLINE is non-nil, else the default is +\"attachment\". +FILE is the name of the file to attach. TYPE is its content-type, a +string of the form \"type/subtype\". DESCRIPTION is a one-line +description of the attachment.") + +(autoload 'mh-mml-secure-message-sign-pgpmime "mh-mime" + "Add MML tag to encrypt/sign the entire message.") + +(autoload 'mh-mml-secure-message-encrypt-pgpmime "mh-mime" + "Add MML tag to encrypt and sign the entire message. +If called with a prefix argument, only encrypt (do NOT sign).") + ;;; Other Autoloads. (autoload 'Info-goto-node "info") (autoload 'mail-mode-fill-paragraph "sendmail") +(autoload 'mm-handle-displayed-p "mm-decode") + +(autoload 'sc-cite-original "sc" + "Workhorse citing function which performs the initial citation. +This is callable from the various mail and news readers' reply +function according to the agreed upon standard. See `\\[sc-describe]' +for more details. `sc-cite-original' does not do any yanking of the +original message but it does require a few things: + + 1) The reply buffer is the current buffer. + + 2) The original message has been yanked and inserted into the + reply buffer. + + 3) Verbose mail headers from the original message have been + inserted into the reply buffer directly before the text of the + original message. + + 4) Point is at the beginning of the verbose headers. + + 5) Mark is at the end of the body of text to be cited. + +For Emacs 19's, the region need not be active (and typically isn't +when this function is called. Also, the hook `sc-pre-hook' is run +before, and `sc-post-hook' is run after the guts of this function.") ;;; Site customization (see also mh-utils.el): (defgroup mh-compose nil - "Mh-e functions for composing messages." + "MH-E functions for composing messages." :prefix "mh-" :group 'mh) - (defvar mh-send-prog "send" "Name of the MH send program. Some sites need to change this because of a name conflict.") @@ -108,7 +179,8 @@ (defvar mh-redist-background nil "If non-nil redist will be done in background like send. -This allows transaction log to be visible if -watch, -verbose or -snoop are used.") +This allows transaction log to be visible if -watch, -verbose or -snoop are +used.") (defvar mh-note-repl "-" "String whose first character is used to notate replied to messages.") @@ -138,36 +210,123 @@ with `mh-ins-buf-prefix' prefixed to each line. See also the variable `mh-yank-from-start-of-msg', which controls how -much of the message passed to the hook.") +much of the message passed to the hook. + +This hook was historically provided to set up supercite. You may now leave +this nil and set up supercite by setting the variable +`mh-yank-from-start-of-msg' to 'supercite or, for more automatic insertion, +to 'autosupercite.") ;;; Personal preferences: -(defcustom mh-insert-x-mailer-p t - "*If t, append an X-Mailer field to the header." +(defcustom mh-compose-insertion (if (locate-library "mml") 'gnus 'mhn) + "Use either 'gnus or 'mhn to insert MIME message directives in messages." + :type '(choice (const :tag "Use gnus" gnus) + (const :tag "Use mhn" mhn)) + :group 'mh-compose) + +(defcustom mh-x-face-file "~/.face" + "*File name containing the encoded X-Face string to insert in outgoing mail. +If nil, or the file does not exist, nothing is added to message headers." + :type 'file + :group 'mh-compose) + +(defcustom mh-insert-x-mailer-flag t + "*Non-nil means append an X-Mailer field to the header." :type 'boolean :group 'mh-compose) (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 +If nil, this variable is initialized to show the version of MH-E, Emacs, and MH the first time a message is composed.") -(defcustom mh-delete-yanked-msg-window nil - "*Controls window display when a message is yanked by \\<mh-letter-mode-map>\\[mh-yank-cur-msg]. +(defcustom mh-insert-mail-followup-to-flag t + "Non-nil means maybe append a Mail-Followup-To field to the header. +The insertion is done if the To: or Cc: fields matches an entry in +`mh-insert-mail-followup-to-list'." + :type 'boolean + :group 'mh-compose) + +(defcustom mh-insert-mail-followup-to-list nil + "Alist of addresses for which a Mail-Followup-To field is inserted. +Each element has the form (REGEXP ADDRESS). +When the REGEXP appears in the To or cc fields of a message, the corresponding +ADDRESS is inserted in a Mail-Followup-To field. + +Here's a customization example: + + regexp: mh-e-users@lists.s\\\\(ourceforge\\\\|f\\\\).net + address: mh-e-users@lists.sourceforge.net + +This corresponds to: + + (setq mh-insert-mail-followup-to-list + '((\"mh-e-users@lists.s\\\\(ourceforge\\\\|f\\\\).net\" + \"mh-e-users@lists.sourceforge.net\"))) + +While it might be tempting to add a descriptive name to the mailing list +address, consider that this field will appear in other people's outgoing +mail in their To: field. It might be best to keep it simple." + :type '(repeat (list (string :tag "regexp") (string :tag "address"))) + :group 'mh-compose) + +(defcustom mh-delete-yanked-msg-window-flag nil + "*Non-nil means delete any window displaying the message. +Controls window display when a message is yanked by \\<mh-letter-mode-map>\\[mh-yank-cur-msg]. If non-nil, yanking the current message into a draft letter deletes any windows displaying the message." :type 'boolean :group 'mh-compose) -(defcustom mh-yank-from-start-of-msg t +(defcustom mh-yank-from-start-of-msg 'attribution "*Controls which part of a message is yanked by \\<mh-letter-mode-map>\\[mh-yank-cur-msg]. -If non-nil, include the entire message. If the symbol `body', then yank the -message minus the header. If nil, yank only the portion of the message -following the point. If the show buffer has a region, this variable is -ignored." +If t, include the entire message, with full headers. This is historically +here for use with supercite, but is now deprecated in favor of the setting +`supercite' below. + +If the symbol `body', then yank the message minus the header. + +If the symbol `supercite', include the entire message, with full headers. +This also causes the invocation of `sc-cite-original' without the setting +of `mail-citation-hook', now deprecated practice. + +If the symbol `autosupercite', do as for `supercite' automatically when +show buffer matches the message being replied-to. When this option is used, +the -noformat switch is passed to the repl program to override a -filter or +-format switch. + +If the symbol `attribution', then yank the message minus the header and add +a simple attribution line at the top. + +If the symbol `autoattrib', do as for `attribution' automatically when show +buffer matches the message being replied-to. You can make sure this is +always the case by setting `mh-reply-show-message-flag' to t (which is the +default) and optionally `mh-delete-yanked-msg-window-flag' to t as well such +that the show window is never displayed. When the `autoattrib' option is +used, the -noformat switch is passed to the repl program to override a +-filter or -format switch. + +If nil, yank only the portion of the message following the point. + +If the show buffer has a region, this variable is ignored unless its value is +one of `attribution' or `autoattrib' in which case the attribution is added +to the yanked region." :type '(choice (const :tag "Below point" nil) (const :tag "Without header" body) - (other :tag "Entire message" t)) + (const :tag "Invoke supercite" supercite) + (const :tag "Invoke supercite, automatically" autosupercite) + (const :tag "Without header, with attribution" attribution) + (const :tag "Without header, with attribution, automatically" + autoattrib) + (const :tag "Entire message with headers" t)) + :group 'mh-compose) + +(defcustom mh-extract-from-attribution-verb "wrote:" + "*Verb to use for attribution when a message is yanked by \\<mh-letter-mode-map>\\[mh-yank-cur-msg]." + :type '(choice (const "wrote:") + (const "a écrit :") + (string :tag "Custom string")) :group 'mh-compose) (defcustom mh-ins-buf-prefix "> " @@ -213,13 +372,14 @@ system MH lib directory.") (defvar mh-repl-group-formfile "replgroupcomps" - "Name of file to be used as a skeleton for replying to the sender and all recipients of a message. -Only used if `mh-nmh-p' is non-nil. Default is \"replgroupcomps\". If not an -absolute file name, the file is searched for first in the user's MH directory, -then in the system MH lib directory.") + "Name of file to be used as a skeleton for replying to messages. +This file is used to form replies to the sender and all recipients of a +message. Only used if `mh-nmh-flag' is non-nil. Default is \"replgroupcomps\". +If not an absolute file name, the file is searched for first in the user's MH +directory, then in the system MH lib directory.") -(defcustom mh-reply-show-message-p t - "*Whether the show buffer is displayed using \\<mh-letter-mode-map>\\[mh-reply]. +(defcustom mh-reply-show-message-flag t + "*Non-nil means the show buffer is displayed using \\<mh-letter-mode-map>\\[mh-reply]. The setting of this variable determines whether the MH `show-buffer' is displayed with the current message when using `mh-reply' without a prefix @@ -233,7 +393,7 @@ (defcustom mh-letter-fill-column 72 "*Fill column to use in `mh-letter-mode'. This is usually less than in other text modes because email messages get -quoted by some prefix (sometimes many times) when they are replied-to, +quoted by some prefix (sometimes many times) when they are replied to, and it's best to avoid quoted lines that span more than 80 columns." :type 'integer :group 'mh-compose) @@ -256,17 +416,27 @@ :type 'hook :group 'mh-compose) +(defcustom mh-letter-insert-signature-hook nil + "Invoked at the beginning of the \\<mh-letter-mode-map>\\[mh-insert-signature] command. +Can be used to determine which signature file to use based on message content. +On return, if `mh-signature-file-name' is non-nil that file will be inserted at +the current point in the buffer." + :type 'hook + :group 'mh-compose) + (defvar mh-rejected-letter-start - (regexp-opt - '("^Content-Type: message/rfc822$" ;MIME MDN - "^ ----- Unsent message follows -----$" ;from sendmail V5 - "^ ----- Original message follows -----$" ;from sendmail V8 - "^------- Unsent Draft$" ;from MH itself - "^---------- Original Message ----------$" ;from zmailer - "^ --- The unsent message follows ---$" ;from AIX mail system - "^ Your message follows:$" ;from MMDF-II - "^Content-Description: Returned Content$" ;1993 KJ sendmail - ))) + (format "^%s$" + (regexp-opt + '("Content-Type: message/rfc822" ;MIME MDN + " ----- Unsent message follows -----" ;from sendmail V5 + " --------Unsent Message below:" ; from sendmail at BU + " ----- Original message follows -----" ;from sendmail V8 + "------- Unsent Draft" ;from MH itself + "---------- Original Message ----------" ;from zmailer + " --- The unsent message follows ---" ;from AIX mail system + " Your message follows:" ;from MMDF-II + "Content-Description: Returned Content" ;1993 KJ sendmail + )))) (defvar mh-new-draft-cleaned-headers "^Date:\\|^Received:\\|^Message-Id:\\|^From:\\|^Sender:\\|^Errors-To:\\|^Delivery-Date:\\|^Return-Path:" @@ -282,7 +452,7 @@ "Keymap for composing mail.") (defvar mh-letter-mode-syntax-table nil - "Syntax table used by mh-e while in MH-Letter mode.") + "Syntax table used by MH-E while in MH-Letter mode.") (if mh-letter-mode-syntax-table () @@ -290,11 +460,25 @@ (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.") + +(defvar mh-annotate-char nil + "Character to use to annotate `mh-sent-from-msg'.") + +(defvar mh-annotate-field nil + "Field name for message annotation.") ;;;###autoload (defun mh-smail () "Compose and send mail with the MH mail system. -This function is an entry point to mh-e, the Emacs front end +This function is an entry point to MH-E, the Emacs front end to the MH mail system. See documentation of `\\[mh-send]' for more details on composing mail." @@ -302,20 +486,18 @@ (mh-find-path) (call-interactively 'mh-send)) - (defvar mh-error-if-no-draft nil) ;raise error over using old draft - ;;;###autoload (defun mh-smail-batch (&optional to subject other-headers &rest ignored) "Set up a mail composition draft with the MH mail system. -This function is an entry point to mh-e, the Emacs front end +This function is an entry point to MH-E, the Emacs front end to the MH mail system. This function does not prompt the user for any header fields, and thus is suitable for use by programs that want to create a mail buffer. Users should use `\\[mh-smail]' to compose mail. Optional arguments for setting certain fields include TO, SUBJECT, and -OTHER-HEADERS." +OTHER-HEADERS. Additional arguments are IGNORED." (mh-find-path) (let ((mh-error-if-no-draft t)) (mh-send (or to "") "" (or subject "")))) @@ -326,7 +508,7 @@ switch-function yank-action send-actions) "Set up mail composition draft with the MH mail system. -This is `mail-user-agent' entry point to mh-e. +This is `mail-user-agent' entry point to MH-E. The optional arguments TO and SUBJECT specify recipients and the initial Subject field, respectively. @@ -356,6 +538,13 @@ (cond ((and mh-draft-folder (equal from-folder mh-draft-folder)) (pop-to-buffer (find-file-noselect (mh-msg-filename msg)) t) (rename-buffer (format "draft-%d" msg)) + ;; Make buffer writable... + (setq buffer-read-only nil) + ;; If buffer was being used to display the message reinsert + ;; from file... + (when (eq major-mode 'mh-show-mode) + (erase-buffer) + (insert-file-contents buffer-file-name)) (buffer-name)) (t (mh-read-draft "clean-up" (mh-msg-filename msg) nil))))) @@ -364,8 +553,8 @@ (goto-char (point-min)) (save-buffer) (mh-compose-and-send-mail draft "" from-folder nil nil nil nil nil nil - config))) - + config) + (mh-letter-mode-message))) (defun mh-extract-rejected-mail (msg) "Extract message MSG returned by the mail system and make it resendable. @@ -390,32 +579,40 @@ (mh-get-header-field "To:") (mh-get-header-field "From:") (mh-get-header-field "Cc:") - nil nil config))) - + nil nil config) + (mh-letter-mode-message))) (defun mh-forward (to cc &optional msg-or-seq) - "Forward displayed message to recipients TO and CC. -If optional prefix argument MSG-OR-SEQ provided, then prompt for the message -sequence. See also documentation for `\\[mh-send]' function." +"Forward one or more messages to the recipients TO and CC. + +Use the optional MSG-OR-SEQ to specify a message or sequence to forward. + +Default is the displayed message. If optional prefix argument is given then +prompt for the message sequence. If variable `transient-mark-mode' is non-nil +and the mark is active, then the selected region is forwarded. +See also documentation for `\\[mh-send]' function." (interactive (list (mh-read-address "To: ") (mh-read-address "Cc: ") - (if current-prefix-arg - (mh-read-seq-default "Forward" t) - (mh-get-msg-num t)))) - (or msg-or-seq - (setq msg-or-seq (mh-get-msg-num t))) + (cond + ((mh-mark-active-p t) + (mh-region-to-sequence (region-beginning) (region-end)) + 'region) + (current-prefix-arg + (mh-read-seq-default "Forward" t)) + (t + (mh-get-msg-num t))))) (let* ((folder mh-current-folder) + (msgs (if (numberp msg-or-seq) + (list msg-or-seq) + (mh-seq-to-msgs msg-or-seq))) (config (current-window-configuration)) - (fwd-msg-file (mh-msg-filename (if (numberp msg-or-seq) - msg-or-seq - (car (mh-seq-to-msgs msg-or-seq))) - folder)) + (fwd-msg-file (mh-msg-filename (car msgs) folder)) ;; forw always leaves file in "draft" since it doesn't have -draft (draft-name (expand-file-name "draft" mh-user-path)) (draft (cond ((or (not (file-exists-p draft-name)) (y-or-n-p "The file 'draft' exists. Discard it? ")) - (mh-exec-cmd "forw" "-build" - mh-current-folder msg-or-seq) + (mh-exec-cmd "forw" "-build" (if mh-nmh-flag "-mime") + mh-current-folder msgs) (prog1 (mh-read-draft "" draft-name t) (mh-insert-fields "To:" to "Cc:" cc) @@ -432,25 +629,45 @@ (setq orig-subject (mh-get-header-field "Subject:"))) (let ((forw-subject (mh-forwarded-letter-subject orig-from orig-subject)) - (mail-header-separator mh-mail-header-separator)) + (mail-header-separator mh-mail-header-separator) + (compose)) (mh-insert-fields "Subject:" forw-subject) (goto-char (point-min)) + ;; If using MML, translate mhn + (if (equal mh-compose-insertion 'gnus) + (save-excursion + (setq compose t) + (re-search-forward (format "^\\(%s\\)?$" mail-header-separator)) + (while + (re-search-forward "^#forw \\[\\([^]]+\\)\\] \\(+\\S-+\\) \\(.*\\)$" (point-max) t) + (let ((description (if (equal (match-string 1) "forwarded messages") + "forwarded message %d" + (match-string 1))) + (msgs (split-string (match-string 3))) + (i 0)) + (beginning-of-line) + (delete-region (point)(progn (forward-line 1)(point))) + (dolist (msg msgs) + (setq i (1+ i)) + (mh-mml-forward-message (format description i) folder msg)))))) + ;; Postition just before forwarded message (if (re-search-forward "^------- Forwarded Message" nil t) (forward-line -1) - (re-search-forward mail-header-separator) + (re-search-forward (format "^\\(%s\\)?$" mail-header-separator)) (forward-line 1)) (delete-other-windows) - (if (numberp msg-or-seq) - (mh-add-msgs-to-seq msg-or-seq 'forwarded t) - (mh-add-msgs-to-seq (mh-seq-to-msgs msg-or-seq) 'forwarded t)) + (mh-add-msgs-to-seq msgs 'forwarded t) (mh-compose-and-send-mail draft "" folder msg-or-seq to forw-subject cc mh-note-forw "Forwarded:" - config))))) + config) + (if compose + (setq mh-mml-compose-insert-flag t)) + (mh-letter-mode-message))))) (defun mh-forwarded-letter-subject (from subject) - ;; Return a Subject suitable for a forwarded message. - ;; Original message has headers FROM and SUBJECT. + "Return a Subject suitable for a forwarded message. +Original message has headers FROM and SUBJECT." (let ((addr-start (string-match "<" from)) (comment (string-match "(" from))) (cond ((and addr-start (> addr-start 0)) @@ -461,11 +678,10 @@ (setq from (substring from (1+ comment) (1- (length from))))))) (format mh-forward-subject-format from subject)) - ;;;###autoload (defun mh-smail-other-window () "Compose and send mail in other window with the MH mail system. -This function is an entry point to mh-e, the Emacs front end +This function is an entry point to MH-E, the Emacs front end to the MH mail system. See documentation of `\\[mh-send]' for more details on composing mail." @@ -473,7 +689,6 @@ (mh-find-path) (call-interactively 'mh-send-other-window)) - (defun mh-redistribute (to cc &optional msg) "Redistribute displayed message to recipients TO and CC. Use optional argument MSG to redistribute another message. @@ -528,73 +743,108 @@ (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 (search "/" buffer-file-name :from-end t))) + (car (read-from-string (subseq 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-reply (message &optional includep) +(defun mh-reply (message &optional reply-to includep) "Reply to MESSAGE (default: current message). -If optional prefix argument INCLUDEP provided, then include the message -in the reply using filter `mhl.reply' in your MH directory. -Prompts for type of addresses to reply to: +If the optional argument REPLY-TO is not given, prompts for type of addresses +to reply to: from sender only, to sender and primary recipients, cc/all sender and all recipients. +If optional prefix argument INCLUDEP provided, then include the message +in the reply using filter `mhl.reply' in your MH directory. If the file named by `mh-repl-formfile' exists, it is used as a skeleton for the reply. See also documentation for `\\[mh-send]' function." - (interactive (list (mh-get-msg-num t) current-prefix-arg)) - (let ((minibuffer-help-form - "from => Sender only\nto => Sender and primary recipients\ncc or all => Sender and all recipients")) - (let* ((reply-to (or mh-reply-default-reply-to - (completing-read "Reply to whom: " - '(("from") ("to") ("cc") ("all")) - nil - t))) - (folder mh-current-folder) - (show-buffer mh-show-buffer) - (config (current-window-configuration)) - (group-reply (or (equal reply-to "cc") (equal reply-to "all"))) - (form-file (cond ((and mh-nmh-p group-reply - (stringp mh-repl-group-formfile)) - mh-repl-group-formfile) - ((stringp mh-repl-formfile) mh-repl-formfile) - (t nil)))) - (message "Composing a reply...") - (mh-exec-cmd "repl" "-build" "-noquery" "-nodraftfolder" - (if form-file - (list "-form" form-file)) - mh-current-folder message - (cond ((or (equal reply-to "from") (equal reply-to "")) - '("-nocc" "all")) - ((equal reply-to "to") - '("-cc" "to")) - (group-reply (if mh-nmh-p - '("-group" "-nocc" "me") - '("-cc" "all" "-nocc" "me")))) - (if includep - '("-filter" "mhl.reply"))) - (let ((draft (mh-read-draft "reply" - (expand-file-name "reply" mh-user-path) - t))) - (delete-other-windows) - (save-buffer) - - (let ((to (mh-get-header-field "To:")) - (subject (mh-get-header-field "Subject:")) - (cc (mh-get-header-field "Cc:"))) - (goto-char (point-min)) - (mh-goto-header-end 1) - (or includep - (not mh-reply-show-message-p) - (mh-in-show-buffer (show-buffer) - (mh-display-msg message folder))) - (mh-add-msgs-to-seq message 'answered t) - (message "Composing a reply...done") - (mh-compose-and-send-mail draft "" folder message to subject cc - mh-note-repl "Replied:" config)))))) - + (interactive (list + (mh-get-msg-num t) + (let ((minibuffer-help-form + "from => Sender only\nto => Sender and primary recipients\ncc or all => Sender and all recipients")) + (or mh-reply-default-reply-to + (completing-read "Reply to whom? (from, to, all) [from]: " + '(("from") ("to") ("cc") ("all")) + nil + t))) + current-prefix-arg)) + (let* ((folder mh-current-folder) + (show-buffer mh-show-buffer) + (config (current-window-configuration)) + (group-reply (or (equal reply-to "cc") (equal reply-to "all"))) + (form-file (cond ((and mh-nmh-flag group-reply + (stringp mh-repl-group-formfile)) + mh-repl-group-formfile) + ((stringp mh-repl-formfile) mh-repl-formfile) + (t nil)))) + (message "Composing a reply...") + (mh-exec-cmd "repl" "-build" "-noquery" "-nodraftfolder" + (if form-file + (list "-form" form-file)) + mh-current-folder message + (cond ((or (equal reply-to "from") (equal reply-to "")) + '("-nocc" "all")) + ((equal reply-to "to") + '("-cc" "to")) + (group-reply (if mh-nmh-flag + '("-group" "-nocc" "me") + '("-cc" "all" "-nocc" "me")))) + (cond ((or (eq mh-yank-from-start-of-msg 'autosupercite) + (eq mh-yank-from-start-of-msg 'autoattrib)) + '("-noformat")) + (includep '("-filter" "mhl.reply")) + (t '()))) + (let ((draft (mh-read-draft "reply" + (expand-file-name "reply" mh-user-path) + t))) + (delete-other-windows) + (save-buffer) + + (let ((to (mh-get-header-field "To:")) + (subject (mh-get-header-field "Subject:")) + (cc (mh-get-header-field "Cc:"))) + (goto-char (point-min)) + (mh-goto-header-end 1) + (or includep + (not mh-reply-show-message-flag) + (mh-in-show-buffer (show-buffer) + (mh-display-msg message folder))) + (mh-add-msgs-to-seq message 'answered t) + (message "Composing a reply...done") + (mh-compose-and-send-mail draft "" folder message to subject cc + mh-note-repl "Replied:" config)) + (when (and (or (eq 'autosupercite mh-yank-from-start-of-msg) + (eq 'autoattrib mh-yank-from-start-of-msg)) + (eq (mh-show-buffer-message-number) mh-sent-from-msg)) + (undo-boundary) + (mh-yank-cur-msg)) + (mh-letter-mode-message)))) (defun mh-send (to cc subject) "Compose and send a letter. -Do not call this function from outside mh-e; use \\[mh-smail] instead. +Do not call this function from outside MH-E; use \\[mh-smail] instead. The file named by `mh-comp-formfile' will be used as the form. The letter is composed in `mh-letter-mode'; see its documentation for more @@ -609,11 +859,10 @@ (delete-other-windows) (mh-send-sub to cc subject config))) - (defun mh-send-other-window (to cc subject) "Compose and send a letter in another window. -Do not call this function from outside mh-e; use \\[mh-smail-other-window] +Do not call this function from outside MH-E; use \\[mh-smail-other-window] instead. The file named by `mh-comp-formfile' will be used as the form. @@ -628,11 +877,10 @@ (let ((pop-up-windows t)) (mh-send-sub to cc subject (current-window-configuration)))) - (defun mh-send-sub (to cc subject config) - ;; Do the real work of composing and sending a letter. - ;; Expects the TO, CC, and SUBJECT fields as arguments. - ;; CONFIG is the window configuration before sending mail. + "Do the real work of composing and sending a letter. +Expects the TO, CC, and SUBJECT fields as arguments. +CONFIG is the window configuration before sending mail." (let ((folder mh-current-folder) (msg-num (mh-get-msg-num nil))) (message "Composing a message...") @@ -652,7 +900,10 @@ (setq components (expand-file-name mh-comp-formfile ;; What is this mh-etc ?? -sm - (and (boundp 'mh-etc) mh-etc)))) + ;; This is dead code, so + ;; remove it. + ;(and (boundp 'mh-etc) mh-etc) + ))) components) (t (error (format "Can't find components file \"%s\"" @@ -660,22 +911,21 @@ nil))) (mh-insert-fields "To:" to "Subject:" subject "Cc:" cc) (goto-char (point-max)) - (message "Composing a message...done") (mh-compose-and-send-mail draft "" folder msg-num to subject cc - nil nil config)))) - + nil nil config) + (mh-letter-mode-message)))) (defun mh-read-draft (use initial-contents delete-contents-file) - ;; Read draft file into a draft buffer and make that buffer the current one. - ;; USE is a message used for prompting about the intended use of the message. - ;; INITIAL-CONTENTS is filename that is read into an empty buffer, or NIL - ;; if buffer should not be modified. Delete the initial-contents file if - ;; DELETE-CONTENTS-FILE flag is set. - ;; Returns the draft folder's name. - ;; If the draft folder facility is enabled in ~/.mh_profile, a new buffer is - ;; used each time and saved in the draft folder. The draft file can then be - ;; reused. + "Read draft file into a draft buffer and make that buffer the current one. +USE is a message used for prompting about the intended use of the message. +INITIAL-CONTENTS is filename that is read into an empty buffer, or nil +if buffer should not be modified. Delete the initial-contents file if +DELETE-CONTENTS-FILE flag is set. +Returns the draft folder's name. +If the draft folder facility is enabled in ~/.mh_profile, a new buffer is +used each time and saved in the draft folder. The draft file can then be +reused." (cond (mh-draft-folder (let ((orig-default-dir default-directory) (draft-file-name (mh-new-draft-name))) @@ -715,17 +965,14 @@ (save-buffer)) ; Do not reuse draft name (buffer-name)) - (defun mh-new-draft-name () - ;; Returns the pathname of folder for draft messages. + "Return the pathname of folder for draft messages." (save-excursion (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 the MESSAGE in BUFFER listing with the character NOTE and annotate - ;; the saved message with ARGS. + "Mark MSG in BUFFER with character NOTE and annotate message with ARGS." (apply 'mh-exec-cmd "anno" buffer msg args) (save-excursion (cond ((get-buffer buffer) ; Buffer may be deleted @@ -734,11 +981,10 @@ (mh-notate-seq msg note (1+ mh-cmd-note)) (mh-notate msg note (1+ mh-cmd-note))))))) - (defun mh-insert-fields (&rest name-values) - ;; Insert the NAME-VALUE pairs in the current buffer. - ;; If field NAME exists, append VALUE to it. - ;; Do not insert any pairs whose value is the empty string. + "Insert the NAME-VALUES pairs in the current buffer. +If the field exists, append the value to it. +Do not insert any pairs whose value is the empty string." (let ((case-fold-search t)) (while name-values (let ((field-name (car name-values)) @@ -751,23 +997,21 @@ (insert field-name " " value "\n"))) (setq name-values (cdr (cdr name-values))))))) - -(defun mh-position-on-field (field &optional ignore) - ;; 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. +(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))) - (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. + "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 @@ -776,12 +1020,12 @@ (buffer-substring start (point)))) "")) -(fset 'mh-get-field 'mh-get-header-field) ;mh-e 4 compatibility +(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. + "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 @@ -790,42 +1034,126 @@ (re-search-forward (format "^%s" field) headers-end t))) (defun mh-goto-header-end (arg) - ;; Find the end of the message header in the current buffer and position - ;; the cursor at the ARG'th newline after the header. + "Move the cursor ARG lines after the header." (if (re-search-forward "^-*$" nil nil) (forward-line arg))) (defun mh-read-address (prompt) - ;; Read a To: or Cc: address, prompting in the minibuffer with PROMPT. - ;; May someday do completion on aliases. + "Read a To: or Cc: address, prompting in the minibuffer with PROMPT. +May someday do completion on aliases." (read-string prompt)) ;;; Mode for composing and sending a draft message. -(defvar mh-sent-from-folder nil) ;Folder of msg assoc with this letter. +(put 'mh-letter-mode 'mode-class 'special) -(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. +;;; Support for emacs21 toolbar using gnus/message.el icons (and code). +(eval-when-compile (defvar tool-bar-map)) +(defvar mh-letter-tool-bar-map nil) +(when (and (fboundp 'tool-bar-add-item) + tool-bar-mode) + (setq mh-letter-tool-bar-map + (let ((tool-bar-map (make-sparse-keymap))) + (tool-bar-add-item "mail_send" 'mh-send-letter 'mh-lettertoolbar-send + :help "Send this letter") + (tool-bar-add-item "attach" 'mh-compose-insertion + 'mh-lettertoolbar-compose + :help "Insert attachment") + (tool-bar-add-item "spell" 'ispell-message 'mh-lettertoolbar-ispell + :help "Check spelling") + (tool-bar-add-item-from-menu 'save-buffer "save") + (tool-bar-add-item-from-menu 'undo "undo") + (tool-bar-add-item-from-menu 'kill-region "cut") + (tool-bar-add-item-from-menu 'menu-bar-kill-ring-save "copy") + (tool-bar-add-item "close" 'mh-fully-kill-draft 'mh-lettertoolbar-kill + :help "Kill this draft") + (tool-bar-add-item "preferences" (lambda () + (interactive) + (customize-group "mh-compose")) + 'mh-lettertoolbar-customize + :help "MH-E composition preferences") + (tool-bar-add-item "help" (lambda () + (interactive) + (Info-goto-node "(mh-e)Draft Editing")) + 'mh-lettertoolbar-help :help "Help") + tool-bar-map))) -(defvar mh-annotate-char nil) ;Character to use to annotate mh-sent-from-msg. +;;; Menu extracted from mh-menubar.el V1.1 (31 July 2001) +(eval-when-compile (defvar mh-letter-menu nil)) +(cond + ((fboundp 'easy-menu-define) + (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] + ["GPG Sign message" mh-mml-secure-message-sign-pgpmime mh-gnus-pgp-support-flag] + ["GPG Encrypt message" mh-mml-secure-message-encrypt-pgpmime mh-gnus-pgp-support-flag] + ["Compose Insertion (MIME)..." mh-compose-insertion t] +;; ["Compose Compressed tar (MIME)..." mh-mhn-compose-external-compressed-tar t] +;; ["Compose Anon FTP (MIME)..." mh-mhn-compose-anon-ftp t] + ["Compose Forward (MIME)..." mh-compose-forward t] +;; The next two will have to be merged. But I also need to make sure the user +;; can't mix directives of both types. + ["Pull in All Compositions (mhn)" mh-edit-mhn mh-mhn-compose-insert-flag] + ["Pull in All Compositions (gnus)" mh-mml-to-mime mh-mml-compose-insert-flag] + ["Revert to Non-MIME Edit (mhn)" mh-revert-mhn-edit (equal mh-compose-insertion 'mhn)] + ["Kill This Draft" mh-fully-kill-draft t])))) -(defvar mh-annotate-field nil) ;Field name for message annotation. +;;; 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" + "Encrypt message: \\[mh-mml-secure-message-encrypt-pgpmime]" + "\t\t Attachment: \\[mh-compose-insertion]\n" + "Sign message: \\[mh-mml-secure-message-sign-pgpmime]" + "\t\t Message to forward: \\[mh-compose-forward]\n" + " " + "\t\t Signature: \\[mh-insert-signature]")) + "Key binding cheat sheet. -(put 'mh-letter-mode 'mode-class 'special) +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.") + + +(defun mh-fill-paragraph-function (arg) + "Fill paragraph at or after point. +Prefix ARG means justify as well. This function enables `fill-paragraph' to +work better in MH-Letter mode." + (interactive "P") + (let ((fill-paragraph-function) (fill-prefix)) + (if (mh-in-header-p) + (mail-mode-fill-paragraph arg) + (fill-paragraph arg)))) ;;;###autoload (define-derived-mode mh-letter-mode text-mode "MH-Letter" - "Mode for composing letters in mh-e.\\<mh-letter-mode-map> + "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. If MH MIME directives are added manually, you must first run \\[mh-edit-mhn] -before sending the message. MIME directives that are added by mh-e commands +before sending the message. MIME directives that are added by MH-E commands such as \\[mh-mhn-compose-insertion] are processed automatically when the message is sent. @@ -846,13 +1174,15 @@ (make-local-variable 'mh-sent-from-msg) (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) ;; From sendmail.el for proper paragraph fill ;; sendmail.el also sets a normal-auto-fill-function (not done here) (make-local-variable 'paragraph-separate) (make-local-variable 'paragraph-start) (make-local-variable 'fill-paragraph-function) - (setq fill-paragraph-function 'mail-mode-fill-paragraph) + (setq fill-paragraph-function 'mh-fill-paragraph-function) (make-local-variable 'adaptive-fill-regexp) (setq adaptive-fill-regexp (concat adaptive-fill-regexp @@ -877,41 +1207,42 @@ (set (make-local-variable 'tool-bar-map) mh-letter-tool-bar-map)) (make-local-variable 'font-lock-defaults) (cond - ((equal mh-highlight-citation-p 'font-lock) + ((or (equal mh-highlight-citation-p 'font-lock) + (equal mh-highlight-citation-p '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-show-font-lock-keywords-with-cite t))) - ((equal mh-highlight-citation-p 'gnus) - (setq font-lock-defaults '(mh-show-font-lock-keywords t)) - (mh-gnus-article-highlight-citation)) (t + ;; ...or the header only (setq font-lock-defaults '(mh-show-font-lock-keywords t)))) (easy-menu-add mh-letter-menu) ;; See if a "forw: -mime" message containing a MIME composition. ;; mode clears local vars, so can't do this in mh-forward. (save-excursion (goto-char (point-min)) - (when (and (re-search-forward mail-header-separator nil t) + (when (and (re-search-forward (format "^\\(%s\\)?$" mail-header-separator) nil t) (= 0 (forward-line 1)) (looking-at "^#forw")) - (require 'mh-mime) ;Need mh-mhn-compose-insert-p local var - (setq mh-mhn-compose-insert-p t))) + (require 'mh-mime) ;Need mh-mhn-compose-insert-flag local var + (setq mh-mhn-compose-insert-flag t))) (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-auto-fill-for-letter () - ;; Auto-fill in letters treats the header specially by inserting a tab - ;; before continuation line. + "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 () - ;; Inserts `mh-mail-header-separator', if absent. + "Insert `mh-mail-header-separator', if absent." (save-excursion (goto-char (point-min)) (rfc822-goto-eoh) @@ -947,7 +1278,6 @@ (insert (format "%s \n" target)) (backward-char 1))))) - (defun mh-to-fcc (&optional folder) "Insert an Fcc: FOLDER field in the current message. Prompt for the field name with a completion list of the current folders." @@ -969,14 +1299,17 @@ (substring folder 1) folder))))) - (defun mh-insert-signature () - "Insert the file named by `mh-signature-file-name' at point." + "Insert the file named by `mh-signature-file-name' at point. +The value of `mh-letter-insert-signature-hook' is a list of functions to be +called, with no arguments, before the signature is actually inserted." (interactive) - (insert-file-contents mh-signature-file-name) + (let ((mh-signature-file-name mh-signature-file-name)) + (run-hooks 'mh-letter-insert-signature-hook) + (if mh-signature-file-name + (insert-file-contents mh-signature-file-name))) (force-mode-line-update)) - (defun mh-check-whom () "Verify recipients of the current letter, showing expansion of any aliases." (interactive) @@ -993,22 +1326,37 @@ ;;; Routines to compose and send a letter. +(defun mh-insert-x-face () + "Append X-Face 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 + (when (null (mh-position-on-field "X-Face")) + (insert "X-Face: ") + (goto-char (+ (point) (cadr (insert-file-contents mh-x-face-file)))) + (if (not (looking-at "^")) + (insert "\n")))))) + (defun mh-insert-x-mailer () - ;; Appends an X-Mailer field to the header. - ;; The versions of mh-e, Emacs, and MH are shown. + "Append an X-Mailer field to the header. +The versions of MH-E, Emacs, and MH are shown." ;; Lazily initialize mh-x-mailer-string. (when (null mh-x-mailer-string) (save-window-excursion (mh-version) (set-buffer mh-temp-buffer) - (if mh-nmh-p + (if mh-nmh-flag (search-forward-regexp "^nmh-\\(\\S +\\)") (search-forward-regexp "^MH \\(\\S +\\)" nil t)) (let ((x-mailer-mh (buffer-substring (match-beginning 1) (match-end 1)))) (setq mh-x-mailer-string - (format "mh-e %s; %s %s; Emacs %d.%d" - mh-version (if mh-nmh-p "nmh" "MH") x-mailer-mh + (format "MH-E %s; %s %s; %s %d.%d" + mh-version (if mh-nmh-flag "nmh" "MH") x-mailer-mh + (if mh-xemacs-flag + "XEmacs" + "Emacs") emacs-major-version emacs-minor-version))) (kill-buffer mh-temp-buffer))) ;; Insert X-Mailer, but only if it doesn't already exist. @@ -1016,24 +1364,55 @@ (when (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." + (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-insert-mail-followup-to () + "Insert Mail-Followup-To: if To or Cc match `mh-insert-mail-followup-to-list'." + (save-excursion + (if (and (or (mh-goto-header-field "To:")(mh-goto-header-field "cc:")) + (not (mh-goto-header-field "Mail-Followup-To: "))) + (let ((list mh-insert-mail-followup-to-list)) + (while list + (let ((regexp (nth 0 (car list))) + (entry (nth 1 (car list)))) + (when (mh-regexp-in-field-p regexp "To:" "cc:") + (if (mh-goto-header-field "Mail-Followup-To: ") + (insert entry ", ") + (mh-goto-header-end 0) + (insert "Mail-Followup-To: " entry "\n"))) + (setq list (cdr list)))))))) (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. - ;; 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. - ;; SEND-ARGS is an optional argument passed to the send command. - ;; 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. + "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) + (if mh-insert-mail-followup-to-flag (mh-insert-mail-followup-to)) (mh-letter-mode) (setq mh-sent-from-folder sent-from-folder) (setq mh-sent-from-msg sent-from-msg) @@ -1052,18 +1431,30 @@ (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-send-letter (&optional arg) "Send the draft letter in the current buffer. If optional prefix argument ARG is provided, monitor delivery. -Run `mh-before-send-letter-hook' before actually doing anything. -Run `\\[mh-edit-mhn]' if variable `mh-mhn-compose-insert-p' is set." +The value of `mh-before-send-letter-hook' is a list of functions to be called, +with no arguments, before doing anything. +Run `\\[mh-edit-mhn]' if variable `mh-mhn-compose-insert-flag' is set." (interactive "P") (run-hooks 'mh-before-send-letter-hook) - (if (and (boundp 'mh-mhn-compose-insert-p) - mh-mhn-compose-insert-p) - (mh-edit-mhn)) - (if mh-insert-x-mailer-p (mh-insert-x-mailer)) + (cond + ((and (boundp 'mh-mhn-compose-insert-flag) + mh-mhn-compose-insert-flag) + (mh-edit-mhn)) + ((and (boundp 'mh-mml-compose-insert-flag) + mh-mml-compose-insert-flag) + (mh-mml-to-mime))) + (if mh-insert-x-mailer-flag (mh-insert-x-mailer)) + (mh-insert-x-face) (save-buffer) (message "Sending...") (let ((draft-buffer (current-buffer)) @@ -1081,6 +1472,12 @@ (and (boundp 'default-buffer-file-coding-system ) default-buffer-file-coding-system) 'iso-latin-1)))) + ;; The default BCC encapsulation will make a MIME message unreadable. + ;; With nmh use the -mime arg to prevent this. + (if (and mh-nmh-flag + (mh-goto-header-field "Bcc:") + (mh-goto-header-field "Content-Type:")) + (setq mh-send-args (format "-mime %s" mh-send-args))) (cond (arg (pop-to-buffer "MH mail delivery") (erase-buffer) @@ -1110,13 +1507,14 @@ (message "Sending...done") (message "Sending...backgrounded")))) - (defun mh-insert-letter (folder message verbatim) "Insert a message into the current letter. -Removes the message's headers using `mh-invisible-headers'. Prefixes -each non-blank line with `mh-ins-buf-prefix'. Prompts for FOLDER and -MESSAGE. If prefix argument VERBATIM provided, do not indent and do -not delete headers. Leaves the mark before the letter and point after it." +Removes the message's headers using `mh-invisible-headers'. Prefixes each +non-blank line with `mh-ins-buf-prefix', unless `mh-yank-from-start-of-msg' +is set for supercite and then use it to format the message. +Prompts for FOLDER and MESSAGE. If prefix argument VERBATIM provided, do +not indent and do not delete headers. Leaves the mark before the letter +and point after it." (interactive (list (mh-prompt-for-folder "Message from" mh-sent-from-folder nil) (read-input (format "Message number%s: " @@ -1128,14 +1526,32 @@ (narrow-to-region (point) (point)) (let ((start (point-min))) (if (equal message "") (setq message (int-to-string mh-sent-from-msg))) - (mh-exec-lib-cmd-output "mhl" "-nobell" "-noclear" - (expand-file-name message - (mh-expand-file-name folder))) - (cond ((not verbatim) - (mh-clean-msg-header start mh-invisible-headers mh-visible-headers) - (set-mark start) ; since mh-clean-msg-header moves it - (mh-insert-prefix-string mh-ins-buf-prefix)))))) + (insert-file-contents + (expand-file-name message (mh-expand-file-name folder))) + (when (not verbatim) + (mh-clean-msg-header start mh-invisible-headers mh-visible-headers) + (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 %s" (match-string 1)(match-string 2) + mh-extract-from-attribution-verb)) + ((looking-at "\\([^<\n]+<.+>\\)$") + (format "%s %s" (match-string 1) mh-extract-from-attribution-verb)) + ((looking-at "\\([^ ]+@[^ ]+\\) +(\\(.+\\))$") + (format "%s <%s> %s" (match-string 2)(match-string 1) + mh-extract-from-attribution-verb)) + ((looking-at " *\\(.+\\)$") + (format "%s %s" (match-string 1) mh-extract-from-attribution-verb)))))) (defun mh-yank-cur-msg () "Insert the current message into the draft buffer. @@ -1144,58 +1560,118 @@ only the region will be inserted. Otherwise, the entire message will be inserted if `mh-yank-from-start-of-msg' is non-nil. If this variable is nil, the portion of the message following the point will be yanked. -If `mh-delete-yanked-msg-window' is non-nil, any window displaying the +If `mh-delete-yanked-msg-window-flag' is non-nil, any window displaying the yanked message will be deleted." (interactive) - (if (and mh-sent-from-folder mh-sent-from-msg) + (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 + (if mh-delete-yanked-msg-window-flag (delete-windows-on mh-show-buffer)) (set-buffer mh-show-buffer) ; Find displayed message - (let ((mh-ins-str (cond ((if (boundp 'mark-active) - mark-active ;Emacs 19 - (mark)) ;Emacs 18 - (buffer-substring (region-beginning) - (region-end))) - ((eq 'body mh-yank-from-start-of-msg) - (buffer-substring - (save-excursion - (goto-char (point-min)) - (mh-goto-header-end 1) - (point)) - (point-max))) - (mh-yank-from-start-of-msg - (buffer-substring (point-min) (point-max))) - (t - (buffer-substring (point) (point-max)))))) + (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-from-start-of-msg) + (eq 'autosupercite mh-yank-from-start-of-msg) + (eq t mh-yank-from-start-of-msg))) + ;; supercite needs the full header + (concat + (buffer-substring (point-min) (mail-header-end)) + "\n" + (buffer-substring (region-beginning) (region-end)))) + (yank-region + (buffer-substring (region-beginning) (region-end))) + ((or (eq 'body mh-yank-from-start-of-msg) + (eq 'attribution + mh-yank-from-start-of-msg) + (eq 'autoattrib + mh-yank-from-start-of-msg)) + (buffer-substring + (save-excursion + (goto-char (point-min)) + (mh-goto-header-end 1) + (point)) + (point-max))) + ((or (eq 'supercite mh-yank-from-start-of-msg) + (eq 'autosupercite mh-yank-from-start-of-msg) + (eq t mh-yank-from-start-of-msg)) + (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) + (if (or (eq 'attribution mh-yank-from-start-of-msg) + (eq 'autoattrib mh-yank-from-start-of-msg)) + (insert from-attr "\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) - (insert mh-ins-str) - (mh-insert-prefix-string mh-ins-buf-prefix) - (insert "\n")))) + (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 (save-excursion (forward-line -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) - ;; Run mail-citation-hook to insert a prefix string before each line - ;; in the buffer. Generality for supercite users. - (set-mark (point-max)) + "Insert prefix string before each line in buffer. +The inserted letter is cited using `sc-cite-original' if +`mh-yank-from-start-of-msg' is one of 'supercite or 'autosupercite. Otherwise, +simply insert MH-INS-STRING before each line." (goto-char (point-min)) - (cond (mail-citation-hook + (cond ((or (eq mh-yank-from-start-of-msg 'supercite) + (eq mh-yank-from-start-of-msg '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)) - (let ((zmacs-regions nil)) ;so "(mark)" works in XEmacs - (while (< (point) (mark)) - (insert mh-ins-string) - (forward-line 1)))))) - + (while (< (point) (point-max)) + (insert mh-ins-string) + (forward-line 1)) + (goto-char (point-min))))) ;leave point like sc-cite-original (defun mh-fully-kill-draft () "Kill the draft message file and the draft message buffer. @@ -1212,9 +1688,8 @@ (set-window-configuration config))) (error "Message not killed"))) - (defun mh-current-fill-prefix () - ;; Return the fill-prefix on the current line as a string. + "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 @@ -1225,14 +1700,12 @@ (match-string 0) ""))) - (defun mh-open-line () "Insert a newline and leave point after it. In addition, insert newline and quoting characters before text after point. This is useful in breaking up paragraphs in replies." (interactive) (let ((column (current-column)) - (point (point)) (prefix (mh-current-fill-prefix))) (if (> (length prefix) column) (message "Sorry, point seems to be within the line prefix") @@ -1242,9 +1715,12 @@ (insert " ")) (forward-line -1)))) - ;;; Build the letter-mode keymap: +;;; If this changes, modify mh-letter-mode-help-messages accordingly, above. (gnus-define-keys mh-letter-mode-map + "\C-c?" mh-help + "\C-c\C-c" mh-send-letter + "\C-c\C-e" mh-edit-mhn "\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 @@ -1260,75 +1736,37 @@ "\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-pgpmime + "\C-c\C-m\C-f" mh-compose-forward + "\C-c\C-m\C-i" mh-compose-insertion + "\C-c\C-m\C-m" mh-mml-to-mime + "\C-c\C-m\C-s" mh-mml-secure-message-sign-pgpmime + "\C-c\C-m\C-u" mh-revert-mhn-edit + "\C-c\C-me" mh-mml-secure-message-encrypt-pgpmime + "\C-c\C-mf" mh-compose-forward + "\C-c\C-mi" mh-compose-insertion + "\C-c\C-mm" mh-mml-to-mime + "\C-c\C-ms" mh-mml-secure-message-sign-pgpmime + "\C-c\C-mu" mh-revert-mhn-edit "\C-c\C-o" mh-open-line "\C-c\C-q" mh-fully-kill-draft "\C-c\C-\\" mh-fully-kill-draft ;if no C-q "\C-c\C-s" mh-insert-signature "\C-c\C-^" mh-insert-signature ;if no C-s "\C-c\C-w" mh-check-whom - "\C-c\C-y" mh-yank-cur-msg - "\C-c\C-c" mh-send-letter - "\C-c\C-m\C-f" mh-mhn-compose-forw - "\C-c\C-m\C-e" mh-mhn-compose-anon-ftp - "\C-c\C-m\C-t" mh-mhn-compose-external-compressed-tar - "\C-c\C-m\C-i" mh-mhn-compose-insertion - "\C-c\C-e" mh-edit-mhn - "\C-c\C-m\C-u" mh-revert-mhn-edit) + "\C-c\C-y" mh-yank-cur-msg) ;; "C-c /" prefix is used in mh-letter-mode by pgp.el and mailcrypt.el. -;;; Menu extracted from mh-menubar.el V1.1 (31 July 2001) -(cond - ((fboundp 'easy-menu-define) - (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] - ["Compose Insertion (MIME)..." mh-mhn-compose-insertion t] - ["Compose Compressed tar (MIME)..." mh-mhn-compose-external-compressed-tar t] - ["Compose Anon FTP (MIME)..." mh-mhn-compose-anon-ftp t] - ["Compose Forward (MIME)..." mh-mhn-compose-forw t] - ["Pull in All Compositions (MIME)" mh-edit-mhn t] - ["Revert to Non-MIME Edit" mh-revert-mhn-edit t] - ["Kill This Draft" mh-fully-kill-draft t])))) - (defun mh-customize () - "Customize mh-e variables." + "Customize MH-E variables." (interactive) (customize-group 'mh)) -;;; Support for emacs21 toolbar using gnus/message.el icons (and code). -(eval-when-compile (defvar tool-bar-map)) -(when (and (fboundp 'tool-bar-add-item) - tool-bar-mode) - (defvar mh-letter-tool-bar-map - (let ((tool-bar-map (make-sparse-keymap))) - (tool-bar-add-item "mail_send" 'mh-send-letter 'mh-letter-send - :help "Send this letter") - (tool-bar-add-item "attach" 'mh-mhn-compose-insertion 'mh-letter-compose - :help "Insert attachment") - (tool-bar-add-item "spell" 'ispell-message 'mh-letter-ispell - :help "Check spelling") - (tool-bar-add-item-from-menu 'save-buffer "save") - (tool-bar-add-item-from-menu 'undo "undo") - (tool-bar-add-item-from-menu 'kill-region "cut") - (tool-bar-add-item-from-menu 'menu-bar-kill-ring-save "copy") - (tool-bar-add-item "close" 'mh-fully-kill-draft 'mh-letter-kill - :help "Kill this draft") - (tool-bar-add-item "preferences" (lambda () - (interactive) - (customize-group "mh-compose")) - 'mh-letter-customize - :help "mh-e composition preferences") - (tool-bar-add-item "help" (lambda () - (interactive) - (Info-goto-node "(mh-e)Draft Editing")) - 'mh-letter-help :help "Help") - tool-bar-map))) +(provide 'mh-comp) + +;;; Local Variables: +;;; sentence-end-double-space: nil +;;; End: ;;; mh-comp.el ends here
--- a/lisp/mail/mh-e.el Fri Nov 29 18:02:52 2002 +0000 +++ b/lisp/mail/mh-e.el Fri Nov 29 18:15:21 2002 +0000 @@ -4,7 +4,7 @@ ;; Author: Bill Wohler <wohler@newt.com> ;; Maintainer: Bill Wohler <wohler@newt.com> -;; Version: 6.1.1 +;; Version: 7.0 ;; Keywords: mail ;; This file is part of GNU Emacs. @@ -40,16 +40,16 @@ ;; The MH newsgroup is comp.mail.mh; the mailing list is mh-users@ics.uci.edu ;; (send to mh-users-request to be added). See the monthly Frequently Asked -;; Questions posting there for information on getting MH and mh-e: +;; Questions posting there for information on getting MH and MH-E: ;; http://www.faqs.org/faqs/mail/mh-faq/part1/preamble.html ;; N.B. MH must have been compiled with the MHE compiler flag or several -;; features necessary for mh-e will be missing from MH commands, specifically +;; features necessary for MH-E will be missing from MH commands, specifically ;; the -build switch to repl and forw. -;; mh-e is an Emacs interface to the MH mail system. +;; MH-E is an Emacs interface to the MH mail system. -;; mh-e is supported in GNU Emacs 20 and 21, with MH 6.8.4 and nmh 1.0.4. +;; MH-E is supported in GNU Emacs 20 and 21, with MH 6.8.4 and nmh 1.0.4. ;; Mailing Lists: ;; mh-e-users@lists.sourceforge.net @@ -79,25 +79,56 @@ ;; Maintenance picked up by Bill Wohler <wohler@newt.com> and the ;; SourceForge Crew <http://mh-e.sourceforge.net/>. 2001. -;; $Id: mh-e.el,v 1.99.1.1 2002/10/01 19:41:43 wohler Exp $ +;; $Id: mh-e.el,v 1.198 2002/11/29 15:33:37 wohler Exp $ ;;; Code: -(provide 'mh-e) +(require 'cl) (require 'mh-utils) (require 'gnus-util) (require 'easymenu) -(if (save-match-data (string-match "XEmacs\\|Lucid" emacs-version)) +(if mh-xemacs-flag (require 'mh-xemacs-compat)) -(eval-when-compile (require 'cl)) -(defconst mh-version "6.1.1" "Version number of mh-e.") +;; Shush the byte-compiler +(defvar font-lock-auto-fontify) +(defvar font-lock-defaults) +(defvar tool-bar-mode) + +(defconst mh-version "7.0" "Version number of MH-E.") ;;; Initial Autoloads +;;; The autoloads for mh-undo-folder, mh-widen and mh-reply are needed before +;;; they are used to avoid compiler warnings. +(autoload 'mh-undo-folder "mh-funcs" + "Undo all commands in current folder." t) +(autoload 'mh-widen "mh-seq" + "Remove restrictions from current folder, thereby showing all messages." t) +(autoload 'mh-reply "mh-comp" + "Reply to a MESSAGE (default: displayed message). +If optional prefix argument INCLUDEP provided, then include the message +in the reply using filter mhl.reply in your MH directory. +Prompts for type of addresses to reply to: + from sender only, + to sender and primary recipients, + cc/all sender and all recipients. +If the file named by `mh-repl-formfile' exists, it is used as a skeleton +for the reply. See also documentation for `\\[mh-send]' function." t) +(autoload 'mh-map-to-seq-msgs "mh-seq") +(autoload 'mh-notate-seq "mh-seq") +(autoload 'mh-destroy-postponed-handles "mh-mime") +(autoload 'mh-press-button "mh-mime") +(autoload 'mh-mime-save-part "mh-mime") +(autoload 'mh-mime-inline-part "mh-mime") +(autoload 'mh-mime-save-parts "mh-mime") +(autoload 'mh-thread-inc "mh-seq") +(autoload 'mh-thread-forget-message "mh-seq") +(autoload 'mh-thread-add-spaces "mh-seq") (autoload 'Info-goto-node "info") + ;;; Hooks: (defgroup mh nil @@ -105,12 +136,12 @@ :group 'mail) (defgroup mh-hook nil - "Hooks to mh-e mode." + "Hooks to MH-E mode." :prefix "mh-" :group 'mh) (defcustom mh-folder-mode-hook nil - "Invoked in MH-Folder mode on a new folder." + "Invoked in `mh-folder-mode' on a new folder." :type 'hook :group 'mh-hook) @@ -127,16 +158,6 @@ :type 'hook :group 'mh-hook) -(defcustom mh-show-hook nil - "Invoked after \\<mh-folder-mode-map>`\\[mh-show]' shows a message." - :type 'hook - :group 'mh-hook) - -(defcustom mh-show-mode-hook nil - "Invoked in MH-Show mode on each message." - :type 'hook - :group 'mh-hook) - (defcustom mh-delete-msg-hook nil "Invoked after marking each message for deletion." :type 'hook @@ -147,14 +168,19 @@ :type 'hook :group 'mh-hook) +(defcustom mh-folder-list-change-hook nil + "Invoked whenever the cached folder list `mh-folder-list' is changed." + :type 'hook + :group 'mh-hook) + (defcustom mh-before-quit-hook nil - "Invoked by \\<mh-folder-mode-map>`\\[mh-quit]' before quitting mh-e. + "Invoked by \\<mh-folder-mode-map>`\\[mh-quit]' before quitting MH-E. See also `mh-quit-hook'." :type 'hook :group 'mh-hook) (defcustom mh-quit-hook nil - "Invoked after \\<mh-folder-mode-map>`\\[mh-quit]' quits mh-e. + "Invoked after \\<mh-folder-mode-map>`\\[mh-quit]' quits MH-E. See also `mh-before-quit-hook'." :type 'hook :group 'mh-hook) @@ -191,19 +217,21 @@ :type 'string :group 'mh) -(defcustom mh-print-background nil - "*Print messages in the background if non-nil. +(defcustom mh-print-background-flag nil + "*Non-nil means messages should be printed in the background. WARNING: do not delete the messages until printing is finished; otherwise, your output may be truncated." :type 'boolean :group 'mh) -(defcustom mh-recenter-summary-p nil - "*Recenter summary window when the show window is toggled off if non-nil." +(defcustom mh-recenter-summary-flag nil + "*Non-nil means to recenter the summary window. + +Recenter the summary window when the show window is toggled off if non-nil." :type 'boolean :group 'mh) -(defcustom mh-do-not-confirm nil +(defcustom mh-do-not-confirm-flag nil "*Non-nil means do not prompt for confirmation. Commands such as `mh-pack-folder' prompt to confirm whether to process outstanding moves and deletes or not before continuing. A non-nil setting will @@ -230,9 +258,9 @@ (defvar mh-partial-folder-mode-line-annotation "select" "Annotation when displaying part of a folder. -The string is displayed after the folder's name. NIL for no annotation.") +The string is displayed after the folder's name. nil for no annotation.") -;;; Parameterize mh-e to work with different scan formats. The defaults work +;;; Parameterize MH-E to work with different scan formats. The defaults work ;;; with the standard MH scan listings, in which the first 4 characters on ;;; the line are the message number, followed by two places for notations. @@ -243,9 +271,11 @@ If nil, the default scan output will be used. If you customize the scan format, you may need to modify a few variables -containing regexps that mh-e uses to identify specific portions of the output. -Use `M-x apropos RET mh-scan.*regexp' to obtain a list of these variables." - :type '(choice (const :tag "Use mh-e scan format" t) +containing regexps that MH-E uses to identify specific portions of the output. +Use `M-x apropos RET mh-scan.*regexp' to obtain a list of these variables. You +may also have to call `mh-set-cmd-note' with the width of your message +numbers. See also `mh-adaptive-cmd-note-flag'." + :type '(choice (const :tag "Use MH-E scan format" t) (const :tag "Use default scan format" nil) (file :tag "Specify a scan format file")) :group 'mh) @@ -253,7 +283,8 @@ ;; The following scan formats are passed to the scan program if the ;; setting of `mh-scan-format-file' above is nil. They are identical ;; except the later one makes use of the nmh `decode' function to -;; decode RFC 2047 encodings. +;; decode RFC 2047 encodings. If you just want to change the width of +;; the msg number, use the `mh-set-cmd-note' function. (defvar mh-scan-format-mh (concat @@ -271,9 +302,10 @@ "%{subject}%<{body}<<%{body}%>") "*Scan format string for MH, provided to the scan program via the -format arg. This format is identical to the default except that additional hints for -fontification have been added to the sixth column. +fontification have been added to the fifth column (remember that in Emacs, the +first column is 0). -The values of the sixth column, in priority order, are: `-' if the +The values of the fifth column, in priority order, are: `-' if the message has been replied to, t if an address on the To: line matches one of the mailboxes of the current user, `c' if the Cc: line matches, `b' if the Bcc: line matches, and `n' if a non-empty Newsgroups: header @@ -293,27 +325,29 @@ "%<(mymbox{from})%<{to}To:%14(decode(friendly{to}))%>%>" "%<(zero)%17(decode(friendly{from}))%> " "%(decode{subject})%<{body}<<%{body}%>") - "*Scan format string for nmh, provided to the scan program via the -format arg. + "*Scan format string for nmh. +This string is passed to the scan program via the -format arg. This format is identical to the default except that additional hints for -fontification have been added to the sixth column. +fontification have been added to the fifth column (remember that in Emacs, the +first column is 0). -The values of the sixth column, in priority order, are: `-' if the +The values of the fifth column, in priority order, are: `-' if the message has been replied to, t if an address on the To: line matches one of the mailboxes of the current user, `c' if the Cc: line matches, `b' if the Bcc: line matches, and `n' if a non-empty Newsgroups: header is present.") -(defvar mh-scan-good-msg-regexp "^\\(....\\)[^D^]" +(defvar mh-scan-good-msg-regexp "^\\( *[0-9]+\\)[^D^0-9]" "Regexp specifying the scan lines that are 'good' messages. The default `mh-folder-font-lock-keywords' expects this expression to contain at least one parenthesized expression which matches the message number.") -(defvar mh-scan-deleted-msg-regexp "^\\(....\\)D" +(defvar mh-scan-deleted-msg-regexp "^\\( *[0-9]+\\)D" "Regexp matching scan lines of deleted messages. The default `mh-folder-font-lock-keywords' expects this expression to contain at least one parenthesized expression which matches the message number.") -(defvar mh-scan-refiled-msg-regexp "^\\(....\\)\\^" +(defvar mh-scan-refiled-msg-regexp "^\\( *[0-9]+\\)\\^" "Regexp matching scan lines of refiled messages. The default `mh-folder-font-lock-keywords' expects this expression to contain at least one parenthesized expression which matches the message number.") @@ -321,13 +355,13 @@ (defvar mh-scan-valid-regexp "^ *[0-9]" "Regexp matching scan lines for messages (not error messages).") -(defvar mh-scan-cur-msg-number-regexp "^\\(....\\+\\).*" +(defvar mh-scan-cur-msg-number-regexp "^\\( *[0-9]+\\+\\).*" "Regexp matching scan line for the current message. The default `mh-folder-font-lock-keywords' expects this expression to contain at least one parenthesized expression which matches the message number. Don't disable this regexp as it's needed by non fontifying functions.") -(defvar mh-scan-cur-msg-regexp "^\\(....\\+DISABLED.*\\)" +(defvar mh-scan-cur-msg-regexp "^\\( *[0-9]+\\+DISABLED.*\\)" "Regexp matching scan line for the current message. The default `mh-folder-font-lock-keywords' expects this expression to contain at least one parenthesized expression which matches the whole line. @@ -352,15 +386,19 @@ at least one parenthesized expression which matches the body text.") (defvar mh-scan-subject-regexp - "^...............................\\([Rr][Ee]:\\s-*\\)*\\([^<\n]*\\)" +;;"^ *[0-9]+........[ ]*...................\\([Rr][Ee]:\\s-*\\)*\\([^<\n]*\\)" + "^ *[0-9]+........[ ]*...................\\([Rr][Ee]\\(\\[[0-9]+\\]\\)?:\\s-*\\)*\\([^<\n]*\\)" "*Regexp matching the subject string in MH folder mode. The default `mh-folder-font-lock-keywords' expects this expression to contain -at least two parenthesized expressions. The first is expected to match the Re: -string, if any. The second is expected to match the subject line itself.") +at least tree parenthesized expressions. The first is expected to match the Re: +string, if any. The second matches an optional bracketed number after Re, +such as in Re[2]: and the third is expected to match the subject line itself.") (defvar mh-scan-format-regexp - (concat "\\([bct]\\)" mh-scan-date-regexp " \\(..................\\)") - "Regexp matching the output of scan using `mh-scan-format-mh' or `mh-scan-format-nmh'. + (concat "\\([bct]\\)" mh-scan-date-regexp " *\\(..................\\)") + "Regexp matching the output of scan. +The default value is based upon the default values of either +`mh-scan-format-mh' or `mh-scan-format-nmh'. The default `mh-folder-font-lock-keywords' expects this expression to contain at least three parenthesized expressions. The first should match the fontification hint, the second is found in `mh-scan-date-regexp', and the @@ -430,68 +468,161 @@ ;;mh-folder-subject-face is defined in mh-utils since it's needed there ;;for mh-show-subject-face. -(eval-after-load "font-lock" - '(progn - (defvar mh-folder-refiled-face 'mh-folder-refiled-face - "Face for highlighting refiled messages in MH-Folder buffers.") - (copy-face 'font-lock-variable-name-face 'mh-folder-refiled-face) - (defvar mh-folder-cur-msg-number-face 'mh-folder-cur-msg-number-face - "Face for highlighting the current message in MH-Folder buffers.") - (copy-face 'font-lock-keyword-face 'mh-folder-cur-msg-number-face) - (defvar mh-folder-to-face 'mh-folder-to-face - "Face for highlighting the To: string in MH-Folder buffers.") - (copy-face 'font-lock-string-face 'mh-folder-to-face) - (defvar mh-folder-body-face 'mh-folder-body-face - "Face for highlighting body text in MH-Folder buffers.") - (copy-face 'font-lock-string-face 'mh-folder-body-face) +(defvar mh-folder-refiled-face 'mh-folder-refiled-face + "Face for highlighting refiled messages in MH-Folder buffers.") +(defface mh-folder-refiled-face + '((((type tty) (class color)) (:foreground "yellow" :weight light)) + (((class grayscale) (background light)) + (:foreground "Gray90" :bold t :italic t)) + (((class grayscale) (background dark)) + (:foreground "DimGray" :bold t :italic t)) + (((class color) (background light)) (:foreground "DarkGoldenrod")) + (((class color) (background dark)) (:foreground "LightGoldenrod")) + (t (:bold t :italic t))) + "Face for highlighting refiled messages in MH-Folder buffers." + :group 'mh) + +(defvar mh-folder-cur-msg-number-face 'mh-folder-cur-msg-number-face + "Face for highlighting the current message in MH-Folder buffers.") +(defface mh-folder-cur-msg-number-face + '((((type tty) (class color)) (:foreground "cyan" :weight bold)) + (((class grayscale) (background light)) (:foreground "LightGray" :bold t)) + (((class grayscale) (background dark)) (:foreground "DimGray" :bold t)) + (((class color) (background light)) (:foreground "Purple")) + (((class color) (background dark)) (:foreground "Cyan")) + (t (:bold t))) + "Face for highlighting the current message in MH-Folder buffers." + :group 'mh) + +(defvar mh-folder-to-face 'mh-folder-to-face + "Face for highlighting the To: string in MH-Folder buffers.") +(defface mh-folder-to-face + '((((type tty) (class color)) (:foreground "green")) + (((class grayscale) (background light)) (:foreground "DimGray" :italic t)) + (((class grayscale) (background dark)) (:foreground "LightGray" :italic t)) + (((class color) (background light)) (:foreground "RosyBrown")) + (((class color) (background dark)) (:foreground "LightSalmon")) + (t (:italic t))) + "Face for highlighting the To: string in MH-Folder buffers." + :group 'mh) + +(defvar mh-folder-body-face 'mh-folder-body-face + "Face for highlighting body text in MH-Folder buffers.") +(defface mh-folder-body-face + '((((type tty) (class color)) (:foreground "green")) + (((class grayscale) (background light)) (:foreground "DimGray" :italic t)) + (((class grayscale) (background dark)) (:foreground "LightGray" :italic t)) + (((class color) (background light)) (:foreground "RosyBrown")) + (((class color) (background dark)) (:foreground "LightSalmon")) + (t (:italic t))) + "Face for highlighting body text in MH-Folder buffers." + :group 'mh) - (defvar mh-folder-font-lock-keywords - (list - ;; Marked for deletion - (list (concat mh-scan-deleted-msg-regexp ".*") - '(0 mh-folder-deleted-face)) - ;; Marked for refile - (list (concat mh-scan-refiled-msg-regexp ".*") - '(0 mh-folder-refiled-face)) - ;;after subj - (list mh-scan-body-regexp '(1 mh-folder-body-face nil t)) - '(mh-folder-font-lock-subject - (1 mh-folder-followup-face append t) - (2 mh-folder-subject-face append t)) - ;;current msg - (list mh-scan-cur-msg-number-regexp - '(1 mh-folder-cur-msg-number-face)) - (list mh-scan-good-msg-regexp - '(1 mh-folder-msg-number-face)) ;; Msg number - (list mh-scan-date-regexp '(1 mh-folder-date-face)) ;; Date - (list mh-scan-rcpt-regexp - '(1 mh-folder-to-face) ;; To: - '(2 mh-folder-address-face)) ;; address - ;; scan font-lock name - (list mh-scan-format-regexp - '(1 mh-folder-date-face) - '(3 mh-folder-scan-format-face)) - ;; Current message line - (list mh-scan-cur-msg-regexp - '(1 mh-folder-cur-msg-face prepend t)) - ;; Unseen messages in bold - '(mh-folder-font-lock-unseen (1 'bold append t)) - ) - "Regexp keywords used to fontify the MH-Folder buffer.") - )) +(defvar mh-folder-font-lock-keywords + (list + ;; Marked for deletion + (list (concat mh-scan-deleted-msg-regexp ".*") + '(0 mh-folder-deleted-face)) + ;; Marked for refile + (list (concat mh-scan-refiled-msg-regexp ".*") + '(0 mh-folder-refiled-face)) + ;;after subj + (list mh-scan-body-regexp '(1 mh-folder-body-face nil t)) + '(mh-folder-font-lock-subject + (1 mh-folder-followup-face append t) + (2 mh-folder-subject-face append t)) + ;;current msg + (list mh-scan-cur-msg-number-regexp + '(1 mh-folder-cur-msg-number-face)) + (list mh-scan-good-msg-regexp + '(1 mh-folder-msg-number-face)) ;; Msg number + (list mh-scan-date-regexp '(1 mh-folder-date-face)) ;; Date + (list mh-scan-rcpt-regexp + '(1 mh-folder-to-face) ;; To: + '(2 mh-folder-address-face)) ;; address + ;; scan font-lock name + (list mh-scan-format-regexp + '(1 mh-folder-date-face) + '(3 mh-folder-scan-format-face)) + ;; Current message line + (list mh-scan-cur-msg-regexp + '(1 mh-folder-cur-msg-face prepend t)) + ;; Unseen messages in bold + '(mh-folder-font-lock-unseen (1 'bold append t)) + ) + "Regexp keywords used to fontify the MH-Folder buffer.") + +(defvar mh-scan-cmd-note-width 1 + "Number of columns consumed by the cmd-note field in `mh-scan-format'. +This column will have one of the values: ` ', `D', `^', `+' and where +` ' is the default value, +`D' is the `mh-note-deleted' character, +`^' is the `mh-note-refiled' character, and +`+' is the `mh-note-cur' character.") + +(defvar mh-scan-destination-width 1 + "Number of columns consumed by the destination field in `mh-scan-format'. +This column will have one of ' ', '%', '-', 't', 'c', 'b', or `n' in it. +A ' ' blank space is the default character. +A '%' indicates that the message in in a named MH sequence. +A '-' indicates that the message has been annotated with a replied field. +A 't' indicates that the message contains mymbox in the To: field. +A 'c' indicates that the message contains mymbox in the Cc: field. +A 'b' indicates that the message contains mymbox in the Bcc: field. +A 'n' indicates that the message contains a Newsgroups: field.") + +(defvar mh-scan-date-width 5 + "Number of columns consumed by the date field in `mh-scan-format'. +This column will typically be of the form mm/dd.") + +(defvar mh-scan-date-flag-width 1 + "Number of columns consumed to flag (in)valid dates in `mh-scan-format'. +This column will have ` ' for valid and `*' for invalid or missing dates.") + +(defvar mh-scan-from-mbox-width 17 + "Number of columns consumed with the \"From:\" line in `mh-scan-format'. +This column will have a friendly name or e-mail address of the +originator, or a \"To: address\" for outgoing e-mail messages.") + +(defvar mh-scan-from-mbox-sep-width 2 + "Number of columns consumed by whitespace after from-mbox in `mh-scan-format'. +This column will only ever have spaces in it.") + +(defvar mh-scan-field-from-start-offset + (+ mh-scan-cmd-note-width + mh-scan-destination-width + mh-scan-date-width + mh-scan-date-flag-width) + "The offset from the `mh-cmd-note' to find the start of \"From:\" address.") + +(defvar mh-scan-field-from-end-offset + (+ mh-scan-field-from-start-offset mh-scan-from-mbox-width) + "The offset from the `mh-cmd-note' to find the end of \"From:\" address.") + +(defvar mh-scan-field-subject-start-offset + (+ mh-scan-cmd-note-width + mh-scan-destination-width + mh-scan-date-width + mh-scan-date-flag-width + mh-scan-from-mbox-width + mh-scan-from-mbox-sep-width) + "The offset from the `mh-cmd-note' to find the start of the subject.") (defun mh-folder-font-lock-subject (limit) - "Return mh-e scan subject strings to font-lock between point and LIMIT." + "Return MH-E scan subject strings to font-lock between point and LIMIT." (if (not (re-search-forward mh-scan-subject-regexp limit t)) nil (if (match-beginning 1) - (set-match-data (list (match-beginning 1) (match-end 2) - (match-beginning 1) (match-end 2) nil nil)) - (set-match-data (list (match-beginning 2) (match-end 2) - nil nil (match-beginning 2) (match-end 2)))) + (set-match-data (list (match-beginning 1) (match-end 3) + (match-beginning 1) (match-end 3) nil nil)) + (set-match-data (list (match-beginning 3) (match-end 3) + nil nil (match-beginning 3) (match-end 3)))) t)) -;; Fontifify unseen mesages in bold. - Peter S Galbraith <psg@debian.org> + + +;; Fontifify unseen mesages in bold. + (defvar mh-folder-unseen-seq-name nil "Name of unseen sequence. The default for this is provided by the function `mh-folder-unseen-seq-name' @@ -501,17 +632,15 @@ "Provide name of unseen sequence from mhparam." (or mh-progs (mh-find-path)) (save-excursion - (let ((tmp-buffer (get-buffer-create mh-temp-buffer)) - (unseen-seq-name "unseen")) - (set-buffer tmp-buffer) - (unwind-protect - (progn - (call-process (expand-file-name "mhparam" mh-progs) - nil '(t t) nil "-component" "Unseen-Sequence") - (goto-char (point-min)) - (if (re-search-forward "Unseen-Sequence: \\(.*\\)$" nil t) - (setq unseen-seq-name (match-string 1)))) - (kill-buffer tmp-buffer)) + (let ((unseen-seq-name "unseen")) + (with-temp-buffer + (unwind-protect + (progn + (call-process (expand-file-name "mhparam" mh-progs) + nil '(t t) nil "-component" "Unseen-Sequence") + (goto-char (point-min)) + (if (re-search-forward "Unseen-Sequence: \\(.*\\)$" nil t) + (setq unseen-seq-name (match-string 1)))))) unseen-seq-name))) (defun mh-folder-unseen-seq-list () @@ -524,20 +653,18 @@ (t (let ((folder mh-current-folder)) (save-excursion - (let ((tmp-buffer (get-buffer-create mh-temp-buffer))) - (set-buffer tmp-buffer) + (with-temp-buffer (unwind-protect (progn (call-process (expand-file-name "mark" mh-progs) - nil '(t t) nil + nil '(t t) nil folder "-seq" mh-folder-unseen-seq-name "-list") (goto-char (point-min)) - (sort (mh-read-msg-list) '<)) - (kill-buffer tmp-buffer)))))))) + (sort (mh-read-msg-list) '<))))))))) (defvar mh-folder-unseen-seq-cache nil - "Internal cache variable used for font-lock in mh-e. + "Internal cache variable used for font-lock in MH-E. Should only be non-nil through font-lock stepping, and nil once font-lock is done highlighting.") (make-variable-buffer-local 'mh-folder-unseen-seq-cache) @@ -581,11 +708,15 @@ (setq mh-folder-unseen-seq-cache nil)) (set-match-data (list bpoint epoint bpoint epoint)) t)))))))) -;; fontifify unseen mesages in bold. - end + + ;;; Internal variables: -(defvar mh-last-destination nil) ;Destination of last refile or write command. +(defvar mh-last-destination nil) ;Destination of last refile or write + ;command. +(defvar mh-last-destination-folder nil) ;Destination of last refile command. +(defvar mh-last-destination-write nil) ;Destination of last write command. (defvar mh-folder-mode-map (make-keymap) "Keymap for MH folders.") @@ -596,7 +727,11 @@ (defvar mh-next-direction 'forward) ;Direction to move to next message. -(defvar mh-narrowed-to-seq nil) ;Sequence display is narrowed to or nil if not narrowed. +(defvar mh-narrowed-to-seq nil) ;Sequence display is narrowed to or + ;nil if not narrowed. + +(defvar mh-view-ops ()) ;Stack of ops that change the folder + ;view (such as narrowing or threading). (defvar mh-first-msg-num nil) ;Number of first msg in buffer. @@ -606,19 +741,22 @@ ;;; Macros and generic functions: -(defun mh-mapc (func list) +(defun mh-mapc (function list) + "Apply FUNCTION to each element of LIST for side effects only." (while list - (funcall func (car list)) + (funcall function (car list)) (setq list (cdr list)))) (defun mh-scan-format () - "Generate arguments to the scan program to specify which format string should be used." + "Return \"-format\" argument for the scan program." (if (equal mh-scan-format-file t) - (list "-format" (if mh-nmh-p - (list mh-scan-format-nmh) - (list mh-scan-format-mh))) + (list "-format" (if mh-nmh-flag + (list (mh-update-scan-format + mh-scan-format-nmh mh-cmd-note)) + (list (mh-update-scan-format + mh-scan-format-mh mh-cmd-note)))) (if (not (equal mh-scan-format-file nil)) - (list "-form" mh-scan-format-file)))) + (list "-format" mh-scan-format-file)))) @@ -627,7 +765,7 @@ ;;;###autoload (defun mh-rmail (&optional arg) "Inc(orporate) new mail with MH. -Scan an MH folder if ARG is non-nil. This function is an entry point to mh-e, +Scan an MH folder if ARG is non-nil. This function is an entry point to MH-E, the Emacs front end to the MH mail system." (interactive "P") (mh-find-path) @@ -638,7 +776,7 @@ ;;;###autoload (defun mh-nmail (&optional arg) "Check for new mail in inbox folder. -Scan an MH folder if ARG is non-nil. This function is an entry point to mh-e, +Scan an MH folder if ARG is non-nil. This function is an entry point to MH-E, the Emacs front end to the MH mail system." (interactive "P") (mh-find-path) ; init mh-inbox @@ -648,7 +786,7 @@ -;;; User executable mh-e commands: +;;; User executable MH-E commands: (defun mh-delete-msg (msg-or-seq) @@ -658,9 +796,8 @@ prompt for the message sequence. If variable `transient-mark-mode' is non-nil and the mark is active, then the selected region is marked for deletion." (interactive (list (cond - ((and (boundp 'transient-mark-mode) - transient-mark-mode mark-active) - (mh-region-to-sequence (region-beginning)(region-end)) + ((mh-mark-active-p t) + (mh-region-to-sequence (region-beginning) (region-end)) 'region) (current-prefix-arg (mh-read-seq-default "Delete" t)) @@ -669,11 +806,10 @@ (mh-delete-msg-no-motion msg-or-seq) (mh-next-msg)) - (defun mh-delete-msg-no-motion (msg-or-seq) "Mark the specified MSG-OR-SEQ for subsequent deletion. -Default is the displayed message. If optional prefix argument is -provided, then prompt for the message sequence." +Default is the displayed message. If optional prefix argument is provided, +then prompt for the message sequence." (interactive (list (if current-prefix-arg (mh-read-seq-default "Delete" t) (mh-get-msg-num t)))) @@ -681,7 +817,6 @@ (mh-delete-a-msg msg-or-seq) (mh-map-to-seq-msgs 'mh-delete-a-msg msg-or-seq))) - (defun mh-execute-commands () "Process outstanding delete and refile requests." (interactive) @@ -690,8 +825,7 @@ (mh-set-scan-mode) (mh-goto-cur-msg) ; after mh-set-scan-mode for efficiency (mh-make-folder-mode-line) - t) ; return t for [local-]write-file-hooks - + t) ; return t for write-file-functions (defun mh-first-msg () "Move to the first message." @@ -700,33 +834,33 @@ (while (and (not (eobp)) (not (looking-at mh-scan-valid-regexp))) (forward-line 1))) - (defun mh-header-display () "Show the current message with all its headers. Displays headers that might have been suppressed by setting the -variables `mh-clean-message-header' or `mhl-formfile', or by the fallback +variables `mh-clean-message-header-flag' or `mhl-formfile', or by the fallback behavior of scrolling uninteresting headers off the top of the window. Type \"\\[mh-show]\" to show the message normally again." (interactive) (and (not mh-showing-with-headers) - (or mhl-formfile mh-clean-message-header) + (or mhl-formfile mh-clean-message-header-flag) (mh-invalidate-show-buffer)) - (let ((mhl-formfile nil) - (mh-clean-message-header nil)) + (let ((mh-decode-mime-flag nil) + (mhl-formfile nil) + (mh-clean-message-header-flag nil)) (mh-show-msg nil) (mh-in-show-buffer (mh-show-buffer) (goto-char (point-min)) (mh-recenter 0)) (setq mh-showing-with-headers t))) - (defun mh-inc-folder (&optional maildrop-name) "Inc(orporate)s new mail into the Inbox folder. Optional argument MAILDROP-NAME specifies an alternate maildrop from the default. If the prefix argument is given, incorporates mail into the current folder, otherwise uses the folder named by `mh-inbox'. -Runs `mh-inc-folder-hook' after incorporating new mail. -Do not call this function from outside mh-e; use \\[mh-rmail] instead." +The value of `mh-inc-folder-hook' is a list of functions to be called, with no +arguments, after incorporating new mail. +Do not call this function from outside MH-E; use \\[mh-rmail] instead." (interactive (list (if current-prefix-arg (expand-file-name (read-file-name "inc mail from file: " @@ -743,28 +877,24 @@ (if mh-showing-mode (mh-show)) (run-hooks 'mh-inc-folder-hook)) - (defun mh-last-msg () "Move to the last message." (interactive) (goto-char (point-max)) (while (and (not (bobp)) (looking-at "^$")) - (forward-line -1))) - + (forward-line -1)) + (mh-recenter nil)) (defun mh-next-undeleted-msg (&optional arg) "Move to the next undeleted message ARG in window." (interactive "p") (setq mh-next-direction 'forward) (forward-line 1) - (cond ((re-search-forward mh-scan-good-msg-regexp nil 0 arg) + (cond ((re-search-forward mh-scan-good-msg-regexp nil t arg) (beginning-of-line) (mh-maybe-show)) - (t - (forward-line -1) - (if (get-buffer mh-show-buffer) - (delete-windows-on mh-show-buffer))))) - + (t (forward-line -1) + (message "No more undeleted messages")))) (defun mh-refile-msg (msg-or-seq folder) "Refile MSG-OR-SEQ (default: displayed message) into FOLDER. @@ -773,8 +903,8 @@ selected region is marked for refiling." (interactive (list (cond - ((and (boundp 'transient-mark-mode) transient-mark-mode mark-active) - (mh-region-to-sequence (region-beginning)(region-end)) + ((mh-mark-active-p t) + (mh-region-to-sequence (region-beginning) (region-end)) 'region) (current-prefix-arg (mh-read-seq-default "Refile" t)) @@ -791,21 +921,21 @@ (insert-file-contents refile-file) (let ((buffer-file-name refile-file)) (funcall mh-default-folder-for-message-function))))) - (and (eq 'refile (car mh-last-destination)) - (symbol-name (cdr mh-last-destination))) + (and (eq 'refile (car mh-last-destination-folder)) + (symbol-name (cdr mh-last-destination-folder))) "") t)))) - (setq mh-last-destination (cons 'refile folder)) + (setq mh-last-destination (cons 'refile folder) + mh-last-destination-folder mh-last-destination) (if (numberp msg-or-seq) (mh-refile-a-msg msg-or-seq folder) (mh-map-to-seq-msgs 'mh-refile-a-msg msg-or-seq folder)) (mh-next-msg)) - (defun mh-refile-or-write-again (message) "Re-execute the last refile or write command on the given MESSAGE. -Default is the displayed message. Use the same folder or file as the -previous refile or write command." +Default is the displayed message. Use the same folder or file as the previous +refile or write command." (interactive (list (mh-get-msg-num t))) (if (null mh-last-destination) (error "No previous refile or write")) @@ -818,16 +948,20 @@ (mh-next-msg)) (defun mh-quit () - "Quit the current mh-e folder. -Start by running `mh-before-quit-hook'. Restore the previous window -configuration, if one exists. Finish by running `mh-quit-hook'." + "Quit the current MH-E folder. +Restore the previous window configuration, if one exists. +The value of `mh-before-quit-hook' is a list of functions to be called, with +no arguments, immediately upon entry to this function. +The value of `mh-quit-hook' is a list of functions to be called, with no +arguments, upon exit of this function." (interactive) (run-hooks 'mh-before-quit-hook) + (let ((show-buffer (get-buffer mh-show-buffer))) + (when show-buffer + (kill-buffer show-buffer))) (mh-update-sequences) - (mh-invalidate-show-buffer) + (mh-destroy-postponed-handles) (bury-buffer (current-buffer)) - (if (get-buffer mh-show-buffer) - (bury-buffer mh-show-buffer)) (if (get-buffer mh-temp-buffer) (kill-buffer mh-temp-buffer)) (if (get-buffer mh-temp-folders-buffer) @@ -845,7 +979,7 @@ bottom of the current message." (interactive "P") (if mh-showing-mode - (if mh-page-to-next-msg-p + (if mh-page-to-next-msg-flag (if (equal mh-next-direction 'backward) (mh-previous-undeleted-msg) (mh-next-undeleted-msg)) @@ -858,11 +992,10 @@ (if (equal mh-next-direction 'backward) "previous" "next"))) - (setq mh-page-to-next-msg-p t)) + (setq mh-page-to-next-msg-flag t)) (scroll-other-window arg))) (mh-show))) - (defun mh-previous-page (&optional arg) "Page the displayed message backwards. Scrolls ARG lines or a full screen if no argument is supplied." @@ -870,29 +1003,161 @@ (mh-in-show-buffer (mh-show-buffer) (scroll-down arg))) - (defun mh-previous-undeleted-msg (&optional arg) "Move to the previous undeleted message ARG in window." (interactive "p") (setq mh-next-direction 'backward) (beginning-of-line) - (cond ((re-search-backward mh-scan-good-msg-regexp nil 0 arg) + (cond ((re-search-backward mh-scan-good-msg-regexp nil t arg) (mh-maybe-show)) - (t - (if (get-buffer mh-show-buffer) - (delete-windows-on mh-show-buffer))))) + (t (message "No previous undeleted message")))) + +(defun mh-goto-next-button (backward-flag &optional criterion) + "Search for next button satisfying criterion. +If BACKWARD-FLAG is non-nil search backward in the buffer for a mime button. If +CRITERION is a function or a symbol which has a function binding then that +function must return non-nil at the button we stop." + (unless (or (and (symbolp criterion) (fboundp criterion)) + (functionp criterion)) + (setq criterion (lambda (x) t))) + ;; Move to the next button in the buffer satisfying criterion + (goto-char (or (save-excursion + (beginning-of-line) + ;; Find point before current button + (let ((point-before-current-button + (save-excursion + (while (get-text-property (point) 'mh-data) + (unless (= (forward-line + (if backward-flag 1 -1)) + 0) + (if backward-flag + (goto-char (point-min)) + (goto-char (point-max))))) + (point)))) + ;; Skip over current button + (while (and (get-text-property (point) 'mh-data) + (not (if backward-flag (bobp) (eobp)))) + (forward-line (if backward-flag -1 1))) + ;; Stop at next MIME button if any exists. + (block loop + (while (/= (progn + (unless (= (forward-line + (if backward-flag -1 1)) + 0) + (if backward-flag + (goto-char (point-max)) + (goto-char (point-min))) + (beginning-of-line)) + (point)) + point-before-current-button) + (when (and (get-text-property (point) 'mh-data) + (funcall criterion (point))) + (return-from loop (point)))) + nil))) + (point)))) + +(defun mh-next-button (&optional backward-flag) + "Go to the next MIME button. +Advance point to the next MIME button in the show buffer. If the end +of buffer is reached then the search wraps over to the start of the +buffer. With prefix argument, BACKWARD-FLAG the point will move to the +previous MIME button." + (interactive (list current-prefix-arg)) + (unless mh-showing-mode + (mh-show)) + (mh-in-show-buffer (mh-show-buffer) + (mh-goto-next-button backward-flag))) + +(defun mh-prev-button () + "Go to the prev MIME button. +Move point to the previous MIME button in the show buffer. If the beginning +of the buffer is reached then the search wraps over to the end of the +buffer." + (interactive) + (mh-next-button t)) +(defun mh-folder-mime-action (part-index action include-security-flag) + "Go to PART-INDEX and carry out ACTION. +If PART-INDEX is nil then go to the next part in the buffer. The search for +the next buffer wraps around if end of buffer is reached. If argument +INCLUDE-SECURITY-FLAG is non-nil then include security info buttons when +searching for a suitable parts." + (unless mh-showing-mode + (mh-show)) + (mh-in-show-buffer (mh-show-buffer) + (let ((criterion + (cond (part-index + (lambda (p) + (let ((part (get-text-property p 'mh-part))) + (and (integerp part) (= part part-index))))) + (t (lambda (p) + (if include-security-flag + (get-text-property p 'mh-data) + (integerp (get-text-property p 'mh-part))))))) + (point (point))) + (cond ((and (get-text-property point 'mh-part) + (or (null part-index) + (= (get-text-property point 'mh-part) part-index))) + (funcall action)) + ((and (get-text-property point 'mh-data) + include-security-flag + (null part-index)) + (funcall action)) + (t + (mh-goto-next-button nil criterion) + (if (= (point) point) + (message "No matching MIME part found") + (funcall action))))))) -(defun mh-rescan-folder (&optional range) +(defun mh-folder-toggle-mime-part (part-index) + "Toggle display of button. +If point in show buffer is at a button then that part is toggled. +If not at a button and PART-INDEX is non-nil point is moved to that part. +With nil PART-INDEX find the first button after point (search wraps around if +end of buffer is reached) and toggle it." + (interactive "P") + (when (consp part-index) (setq part-index (car part-index))) + (mh-folder-mime-action part-index #'mh-press-button t)) + +(defun mh-folder-inline-mime-part (part-index) + "Show the raw bytes of MIME part inline. +If point in show buffer is at a mime part then that part is inlined. +If not at a mime-part and PART-INDEX is non-nil point is moved to that part. +With nil PART-INDEX find the first button after point (search wraps around if +end of buffer is reached) and inline it." + (interactive "P") + (when (consp part-index) (setq part-index (car part-index))) + (mh-folder-mime-action part-index #'mh-mime-inline-part nil)) + +(defun mh-folder-save-mime-part (part-index) + "Save MIME part. +If point in show buffer is at a mime part then that part is saved. +If not at a mime-part and PART-INDEX is non-nil point is moved to that part. +With nil PART-INDEX find the first button after point (search wraps around if +end of buffer is reached) and save it." + (interactive "P") + (when (consp part-index) (setq part-index (car part-index))) + (mh-folder-mime-action part-index #'mh-mime-save-part nil)) + +(defun mh-reset-threads-and-narrowing () + "Reset all variables pertaining to threads and narrowing. +Also removes all content from the folder buffer." + (setq mh-view-ops ()) + (setq mh-narrowed-to-seq nil) + (let ((buffer-read-only nil)) (erase-buffer))) + +(defun mh-rescan-folder (&optional range dont-exec-pending) "Rescan a folder after optionally processing the outstanding commands. If optional prefix argument RANGE is provided, prompt for the range of -messages to display. Otherwise show the entire folder." +messages to display. Otherwise show the entire folder. +If optional argument DONT-EXEC-PENDING is non-nil then pending deletes and +refiles aren't carried out." (interactive (list (if current-prefix-arg (mh-read-msg-range "Range to scan [all]? ") nil))) (setq mh-next-direction 'forward) - (mh-scan-folder mh-current-folder (or range "all"))) - + (mh-reset-threads-and-narrowing) + (mh-scan-folder mh-current-folder (or range "all") dont-exec-pending)) (defun mh-write-msg-to-file (msg file no-headers) "Append MSG to the end of a FILE. @@ -900,19 +1165,21 @@ Otherwise send the entire message including the headers." (interactive (list (mh-get-msg-num t) - (let ((default-dir (if (eq 'write (car mh-last-destination)) - (file-name-directory (car (cdr mh-last-destination))) + (let ((default-dir (if (eq 'write (car mh-last-destination-write)) + (file-name-directory + (car (cdr mh-last-destination-write))) default-directory))) (read-file-name (format "Save message%s in file: " (if current-prefix-arg " body" "")) default-dir - (if (eq 'write (car mh-last-destination)) - (car (cdr mh-last-destination)) + (if (eq 'write (car mh-last-destination-write)) + (car (cdr mh-last-destination-write)) (expand-file-name "mail.out" default-dir)))) current-prefix-arg)) (let ((msg-file-to-output (mh-msg-filename msg)) (output-file (mh-expand-file-name file))) - (setq mh-last-destination (list 'write file (if no-headers 'no-headers))) + (setq mh-last-destination (list 'write file (if no-headers 'no-headers)) + mh-last-destination-write mh-last-destination) (save-excursion (set-buffer (get-buffer-create mh-temp-buffer)) (erase-buffer) @@ -921,7 +1188,6 @@ (if no-headers (search-forward "\n\n")) (append-to-file (point) (point-max) output-file)))) - (defun mh-toggle-showing () "Toggle the scanning mode/showing mode of displaying messages." (interactive) @@ -929,17 +1195,15 @@ (mh-set-scan-mode) (mh-show))) - (defun mh-undo (msg-or-seq) "Undo the pending deletion or refile of the specified MSG-OR-SEQ. -Default is the displayed message. If optional prefix argument is -provided, then prompt for the message sequence. +Default is the displayed message. +If optional prefix argument is provided, then prompt for the message sequence. If variable `transient-mark-mode' is non-nil and the mark is active, then the selected region is unmarked." (interactive (list (cond - ((and (boundp 'transient-mark-mode) - transient-mark-mode mark-active) - (mh-region-to-sequence (region-beginning)(region-end)) + ((mh-mark-active-p t) + (mh-region-to-sequence (region-beginning) (region-end)) 'region) (current-prefix-arg (mh-read-seq-default "Undo" t)) @@ -963,32 +1227,25 @@ (error "Nothing to undo")))) (t (mh-map-to-seq-msgs 'mh-undo-msg msg-or-seq))) - ;; update the mh-refile-list so mh-outstanding-commands-p will work - (mh-mapc (function - (lambda (elt) - (if (not (mh-seq-to-msgs elt)) - (setq mh-refile-list (delq elt mh-refile-list))))) - mh-refile-list) (if (not (mh-outstanding-commands-p)) (mh-set-folder-modified-p nil))) - ;;;###autoload (defun mh-version () - "Display version information about mh-e and the MH mail handling system." + "Display version information about MH-E and the MH mail handling system." (interactive) (mh-find-progs) (set-buffer (get-buffer-create mh-temp-buffer)) (erase-buffer) - ;; mh-e and Emacs versions. - (insert "mh-e " mh-version "\n\n" (emacs-version) "\n\n") + ;; MH-E and Emacs versions. + (insert "MH-E " mh-version "\n\n" (emacs-version) "\n\n") ;; MH version. (let ((help-start (point))) (condition-case err-data - (mh-exec-cmd-output "inc" nil (if mh-nmh-p "-version" "-help")) + (mh-exec-cmd-output "inc" nil (if mh-nmh-flag "-version" "-help")) (file-error (insert (mapconcat 'concat (cdr err-data) ": ") "\n"))) (goto-char help-start) - (if mh-nmh-p + (if mh-nmh-flag (search-forward "inc -- " nil t) (search-forward "version: " nil t)) (delete-region help-start (point))) @@ -1003,10 +1260,9 @@ (goto-char (point-min)) (display-buffer mh-temp-buffer)) - (defun mh-visit-folder (folder &optional range) "Visit FOLDER and display RANGE of messages. -Do not call this function from outside mh-e; see \\[mh-rmail] instead." +Do not call this function from outside MH-E; see \\[mh-rmail] instead." (interactive (list (mh-prompt-for-folder "Visit" mh-inbox t) (mh-read-msg-range "Range [all]? "))) (let ((config (current-window-configuration))) @@ -1014,13 +1270,12 @@ (setq mh-previous-window-config config)) nil) - (defun mh-update-sequences () - "Update MH's Unseen sequence and current folder and message. -Flush mh-e's state out to MH. The message at the cursor becomes current." + "Update MH's Unseen-Sequence and current folder and message. +Flush MH-E's state out to MH. The message at the cursor becomes current." (interactive) ;; mh-update-sequences is the opposite of mh-read-folder-sequences, - ;; which updates mh-e's state from MH. + ;; which updates MH-E's state from MH. (let ((folder-set (mh-update-unseen)) (new-cur (mh-get-msg-num nil))) (if new-cur @@ -1039,13 +1294,14 @@ (mh-exec-cmd-quiet t "folder" mh-current-folder "-fast") (mh-exec-cmd-quiet t "folder" "-fast"))))))) - ;;; Support routines. (defun mh-delete-a-msg (msg) - ;; Delete the MESSAGE. + "Delete the MSG. +The value of `mh-delete-msg-hook' is a list of functions to be called, with no +arguments, after the message has been deleted." (save-excursion (mh-goto-msg msg nil t) (if (looking-at mh-scan-refiled-msg-regexp) @@ -1054,12 +1310,14 @@ nil (mh-set-folder-modified-p t) (setq mh-delete-list (cons msg mh-delete-list)) - (mh-add-msgs-to-seq msg 'deleted t) (mh-notate msg mh-note-deleted mh-cmd-note) (run-hooks 'mh-delete-msg-hook)))) -(defun mh-refile-a-msg (msg destination) - ;; Refile MESSAGE in FOLDER. FOLDER is a symbol, not a string. +(defun mh-refile-a-msg (msg folder) + "Refile MSG in FOLDER. +Folder is a symbol, not a string. +The value of `mh-refile-msg-hook' is a list of functions to be called, with no +arguments, after the message has been refiled." (save-excursion (mh-goto-msg msg nil t) (cond ((looking-at mh-scan-deleted-msg-regexp) @@ -1067,72 +1325,257 @@ ((looking-at mh-scan-refiled-msg-regexp) (if (y-or-n-p (format "Message %d already refiled. Copy to %s as well? " - msg destination)) + msg folder)) (mh-exec-cmd "refile" (mh-get-msg-num t) "-link" "-src" mh-current-folder - (symbol-name destination)) + (symbol-name folder)) (message "Message not copied."))) (t (mh-set-folder-modified-p t) - (if (not (memq destination mh-refile-list)) - (setq mh-refile-list (cons destination mh-refile-list))) - (if (not (memq msg (mh-seq-to-msgs destination))) - (mh-add-msgs-to-seq msg destination t)) + (if (null (assoc folder mh-refile-list)) + (push (list folder msg) mh-refile-list) + (pushnew msg (cdr (assoc folder mh-refile-list)))) (mh-notate msg mh-note-refiled mh-cmd-note) (run-hooks 'mh-refile-msg-hook))))) - (defun mh-next-msg () - ;; Move backward or forward to the next undeleted message in the buffer. + "Move backward or forward to the next undeleted message in the buffer." (if (eq mh-next-direction 'forward) (mh-next-undeleted-msg 1) (mh-previous-undeleted-msg 1))) - (defun mh-set-scan-mode () - ;; Display the scan listing buffer, but do not show a message. + "Display the scan listing buffer, but do not show a message." (if (get-buffer mh-show-buffer) (delete-windows-on mh-show-buffer)) (mh-showing-mode 0) (force-mode-line-update) - (if mh-recenter-summary-p + (if mh-recenter-summary-flag (mh-recenter nil))) - (defun mh-undo-msg (msg) - ;; Undo the deletion or refile of one MESSAGE. + "Undo the deletion or refile of one MSG." (cond ((memq msg mh-delete-list) - (setq mh-delete-list (delq msg mh-delete-list)) - (mh-delete-msg-from-seq msg 'deleted t)) + (setq mh-delete-list (delq msg mh-delete-list))) (t - (mh-mapc (function (lambda (dest) - (mh-delete-msg-from-seq msg dest t))) - mh-refile-list))) + (dolist (folder-msg-list mh-refile-list) + (setf (cdr folder-msg-list) (remove msg (cdr folder-msg-list)))) + (setq mh-refile-list (remove-if #'(lambda (x) (null (cdr x))) + mh-refile-list)))) (mh-notate msg ? mh-cmd-note)) - ;;; The folder data abstraction. (defun mh-make-folder (name) - ;; Create and initialize a new mail folder called NAME and make it the - ;; current folder. + "Create a new mail folder called NAME. +Make it the current folder." (switch-to-buffer name) (setq buffer-read-only nil) (erase-buffer) + (if mh-adaptive-cmd-note-flag + (mh-set-cmd-note (mh-message-number-width name))) (setq buffer-read-only t) (mh-folder-mode) (mh-set-folder-modified-p nil) (setq buffer-file-name mh-folder-filename) (mh-make-folder-mode-line)) - ;;; Ensure new buffers won't get this mode if default-major-mode is nil. (put 'mh-folder-mode 'mode-class 'special) + + +;;; Menu extracted from mh-menubar.el V1.1 (31 July 2001) +;;; Menus for folder mode: folder, message, sequence (in that order) +;;; folder-mode "Sequence" menu +(easy-menu-define + mh-folder-sequence-menu mh-folder-mode-map "Menu for MH-E folder-sequence." + '("Sequence" + ["Add Message to Sequence..." mh-put-msg-in-seq (mh-get-msg-num nil)] + ["List Sequences for Message" mh-msg-is-in-seq (mh-get-msg-num nil)] + ["Delete Message from Sequence..." mh-delete-msg-from-seq + (mh-get-msg-num nil)] + ["List Sequences in Folder..." mh-list-sequences t] + ["Delete Sequence..." mh-delete-seq t] + ["Narrow to Sequence..." mh-narrow-to-seq t] + ["Widen from Sequence" mh-widen mh-narrowed-to-seq] + "--" + ["Narrow to Subject Sequence" mh-narrow-to-subject t] + ["Delete Rest of Same Subject" mh-delete-subject t] + "--" + ["Push State Out to MH" mh-update-sequences t])) + +;;; folder-mode "Message" menu +(easy-menu-define + mh-folder-message-menu mh-folder-mode-map "Menu for MH-E folder-message." + '("Message" + ["Show Message" mh-show (mh-get-msg-num nil)] + ["Show Message with Header" mh-header-display (mh-get-msg-num nil)] + ["Next Message" mh-next-undeleted-msg t] + ["Previous Message" mh-previous-undeleted-msg t] + ["Go to First Message" mh-first-msg t] + ["Go to Last Message" mh-last-msg t] + ["Go to Message by Number..." mh-goto-msg t] + ["Modify Message" mh-modify] + ["Delete Message" mh-delete-msg (mh-get-msg-num nil)] + ["Refile Message" mh-refile-msg (mh-get-msg-num nil)] + ["Undo Delete/Refile" mh-undo t] + ["Process Delete/Refile" mh-execute-commands + (or mh-refile-list mh-delete-list)] + "--" + ["Compose a New Message" mh-send t] + ["Reply to Message..." mh-reply (mh-get-msg-num nil)] + ["Forward Message..." mh-forward (mh-get-msg-num nil)] + ["Redistribute Message..." mh-redistribute (mh-get-msg-num nil)] + ["Edit Message Again" mh-edit-again (mh-get-msg-num nil)] + ["Re-edit a Bounced Message" mh-extract-rejected-mail t] + "--" + ["Copy Message to Folder..." mh-copy-msg (mh-get-msg-num nil)] + ["Print Message" mh-print-msg (mh-get-msg-num nil)] + ["Write Message to File..." mh-write-msg-to-file + (mh-get-msg-num nil)] + ["Pipe Message to Command..." mh-pipe-msg (mh-get-msg-num nil)] + ["Unpack Uuencoded Message..." mh-store-msg (mh-get-msg-num nil)] + ["Burst Digest Message" mh-burst-digest (mh-get-msg-num nil)])) + +;;; folder-mode "Folder" menu +(easy-menu-define + mh-folder-folder-menu mh-folder-mode-map "Menu for MH-E folder." + '("Folder" + ["Incorporate New Mail" mh-inc-folder t] + ["Toggle Show/Folder" mh-toggle-showing t] + ["Execute Delete/Refile" mh-execute-commands + (or mh-refile-list mh-delete-list)] + ["Rescan Folder" mh-rescan-folder t] + ["Thread Folder" mh-toggle-threads + (not (memq 'unthread mh-view-ops))] + ["Pack Folder" mh-pack-folder t] + ["Sort Folder" mh-sort-folder t] + "--" + ["List Folders" mh-list-folders t] + ["Visit a Folder..." mh-visit-folder t] + ["Search a Folder..." mh-search-folder t] + ["Indexed Search..." mh-index-search t] + "--" + ["Quit MH-E" mh-quit t])) + + + +;;; Support for emacs21 toolbar using gnus/message.el icons (and code). +(eval-when-compile (defvar tool-bar-map)) +(defvar mh-folder-tool-bar-map nil) +(defvar mh-folder-seq-tool-bar-map nil + "Tool-bar to use when narrowed to a sequence in MH-Folder buffers.") +(when (and (fboundp 'tool-bar-add-item) + tool-bar-mode) + (setq mh-folder-tool-bar-map + (let ((tool-bar-map (make-sparse-keymap))) + (tool-bar-add-item "mail" 'mh-inc-folder 'mh-foldertoolbar-inc-folder + :help "Incorporate new mail in Inbox") + (tool-bar-add-item "attach" 'mh-mime-save-parts + 'mh-foldertoolbar-mime-save-parts + :help "Save MIME parts") + + (tool-bar-add-item "left_arrow" 'mh-previous-undeleted-msg + 'mh-foldertoolbar-prev :help "Previous message") + (tool-bar-add-item "page-down" 'mh-page-msg 'mh-foldertoolbar-page + :help "Page this message") + (tool-bar-add-item "right_arrow" 'mh-next-undeleted-msg + 'mh-foldertoolbar-next :help "Next message") + + (tool-bar-add-item "close" 'mh-delete-msg 'mh-foldertoolbar-delete + :help "Mark for deletion") + (tool-bar-add-item "refile" 'mh-refile-msg 'mh-foldertoolbar-refile + :help "Refile this message") + (tool-bar-add-item "undo" 'mh-undo 'mh-foldertoolbar-undo + :help "Undo this mark") + (tool-bar-add-item "execute" 'mh-execute-commands 'mh-foldertoolbar-exec + :help "Perform moves and deletes") + + (tool-bar-add-item "show" 'mh-toggle-showing + 'mh-foldertoolbar-toggle-show + :help "Toggle showing message") + + (cond + (mh-tool-bar-reply-3-buttons-flag + (tool-bar-add-item "reply-from" (lambda (&optional arg) + (interactive "P") + (mh-reply (mh-get-msg-num nil) + "from" arg)) + 'mh-foldertoolbar-reply-from + :help "Reply to \"from\"") + (tool-bar-add-item "reply-to" (lambda (&optional arg) + (interactive "P") + (mh-reply (mh-get-msg-num nil) + "to" arg)) + 'mh-foldertoolbar-reply-to + :help "Reply to \"to\"") + (tool-bar-add-item "reply-all" (lambda (&optional arg) + (interactive "P") + (mh-reply (mh-get-msg-num nil) + "all" arg)) + 'mh-foldertoolbar-reply-all + :help "Reply to \"all\"")) + (t + (tool-bar-add-item "mail/reply2" 'mh-reply 'mh-foldertoolbar-reply + :help "Reply to this message"))) + (tool-bar-add-item "mail_compose" 'mh-send 'mh-foldertoolbar-compose + :help "Compose new message") + + (tool-bar-add-item "rescan" 'mh-rescan-folder 'mh-foldertoolbar-rescan + :help "Rescan this folder") + (tool-bar-add-item "repack" 'mh-pack-folder 'mh-foldertoolbar-pack + :help "Repack this folder") + + (tool-bar-add-item "search" + (lambda (&optional arg) + (interactive "P") + (call-interactively mh-tool-bar-search-function)) + 'mh-foldertoolbar-search :help "Search") + (tool-bar-add-item "fld_open" 'mh-visit-folder 'mh-foldertoolbar-visit + :help "Visit other folder") + + (tool-bar-add-item "preferences" (lambda () + (interactive) + (customize-group "mh")) + 'mh-foldertoolbar-customize + :help "mh-e preferences") + (tool-bar-add-item "help" (lambda () + (interactive) + (Info-goto-node "(mh-e)Top")) + 'mh-foldertoolbar-help :help "Help") + tool-bar-map)) + + (setq mh-folder-seq-tool-bar-map + (let ((tool-bar-map (copy-keymap mh-folder-tool-bar-map))) + (tool-bar-add-item "widen" 'mh-widen 'mh-foldertoolbar-widen + :help "Widen from this sequence") + tool-bar-map)) + ) + + + +(defmacro mh-remove-xemacs-horizontal-scrollbar () + "Get rid of the horizontal scrollbar that XEmacs insists on putting in." + (when mh-xemacs-flag + `(if (and (featurep 'scrollbar) + (fboundp 'set-specifier)) + (set-specifier horizontal-scrollbar-visible-p nil + (cons (current-buffer) nil))))) + +(defmacro mh-write-file-functions-compat () + "Return `write-file-functions' if it exists. +Otherwise return `local-write-file-hooks'. This macro exists purely for +compatibility. The former symbol is used in Emacs 21.4 onward while the latter +is used in previous versions and XEmacs." + (if (boundp 'write-file-functions) + ''write-file-functions ;Emacs 21.4 + ''local-write-file-hooks)) ;<Emacs 21.4, XEmacs + (define-derived-mode mh-folder-mode fundamental-mode "MH-Folder" - "Major mh-e mode for \"editing\" an MH folder scan listing.\\<mh-folder-mode-map> + "Major MH-E mode for \"editing\" an MH folder scan listing.\\<mh-folder-mode-map> You can show the message the cursor is pointing to, and step through the messages. Messages can be marked for deletion or refiling into another @@ -1164,18 +1607,19 @@ 'mh-seen-list nil ; List of displayed messages 'mh-next-direction 'forward ; Direction to move to next message 'mh-narrowed-to-seq nil ; Sequence display is narrowed to + 'mh-view-ops () ; Stack that keeps track of the order + ; in which narrowing/threading has been + ; carried out. 'mh-first-msg-num nil ; Number of first msg in buffer 'mh-last-msg-num nil ; Number of last msg in buffer 'mh-msg-count nil ; Number of msgs in buffer 'mh-mode-line-annotation nil ; Indiction this is not the full folder 'mh-previous-window-config nil) ; Previous window configuration + (mh-remove-xemacs-horizontal-scrollbar) (setq truncate-lines t) (auto-save-mode -1) (setq buffer-offer-save t) - (if (boundp 'local-write-file-hooks) - (setq local-write-file-hooks '(mh-execute-commands)) ;Emacs 19 - (make-local-variable 'write-file-hooks) - (setq write-file-hooks '(mh-execute-commands))) ;Emacs 18 + (add-hook (mh-write-file-functions-compat) 'mh-execute-commands nil t) (make-local-variable 'revert-buffer-function) (make-local-variable 'hl-line-mode) ; avoid pollution (if (fboundp 'hl-line-mode) @@ -1188,48 +1632,64 @@ (easy-menu-add mh-folder-message-menu) (easy-menu-add mh-folder-folder-menu) (if (and (boundp 'tool-bar-mode) tool-bar-mode) - (set (make-local-variable 'tool-bar-map) mh-folder-tool-bar-map))) - + (set (make-local-variable 'tool-bar-map) mh-folder-tool-bar-map)) + (if (and mh-xemacs-flag + font-lock-auto-fontify) + (turn-on-font-lock))) ; Force font-lock in XEmacs. (defun mh-make-local-vars (&rest pairs) - ;; Take VARIABLE-VALUE pairs and make local variables initialized to the - ;; value. + "Initialize local variables according to the variable-value PAIRS." + (while pairs (set (make-local-variable (car pairs)) (car (cdr pairs))) (setq pairs (cdr (cdr pairs))))) - -(defun mh-scan-folder (folder range) - ;; Scan the FOLDER over the RANGE. Return in the folder's buffer. +(defun mh-scan-folder (folder range &optional dont-exec-pending) + "Scan the FOLDER over the RANGE. +If the optional argument DONT-EXEC-PENDING is non-nil then pending deletes and +refiles aren't carried out. +Return in the folder's buffer." (cond ((null (get-buffer folder)) (mh-make-folder folder)) (t - (mh-process-or-undo-commands folder) + (or dont-exec-pending (mh-process-or-undo-commands folder)) (switch-to-buffer folder))) (mh-regenerate-headers range) (if (zerop (buffer-size)) - (if (equal range "all") - (message "Folder %s is empty" folder) - (message "No messages in %s, range %s" folder range)) - (mh-goto-cur-msg))) - + (if (equal range "all") + (message "Folder %s is empty" folder) + (message "No messages in %s, range %s" folder range)) + (mh-goto-cur-msg)) + (save-excursion + (when dont-exec-pending + ;; Re-annotate messages to be refiled... + (dolist (folder-msg-list mh-refile-list) + (dolist (msg (cdr folder-msg-list)) + (mh-notate msg mh-note-refiled mh-cmd-note))) + ;; Re-annotate messages to be deleted... + (dolist (msg mh-delete-list) + (mh-notate msg mh-note-deleted mh-cmd-note))))) (defun mh-regenerate-headers (range &optional update) - ;; scan folder over range RANGE. - ;; If UPDATE, append the scan lines, otherwise replace. + "Scan folder over range RANGE. +If UPDATE, append the scan lines, otherwise replace." (let ((folder mh-current-folder) + (range (if (and range (atom range)) (list range) range)) scan-start) (message "Scanning %s..." folder) (with-mh-folder-updating (nil) (if update (goto-char (point-max)) - (erase-buffer)) + (delete-region (point-min) (point-max)) + (if mh-adaptive-cmd-note-flag + (mh-set-cmd-note (mh-message-number-width folder)))) (setq scan-start (point)) - (mh-exec-cmd-output mh-scan-prog nil - (mh-scan-format) - "-noclear" "-noheader" - "-width" (window-width) - folder range) + (apply #'mh-exec-cmd-output + mh-scan-prog nil + (mh-scan-format) + "-noclear" "-noheader" + "-width" (window-width) + folder range) (goto-char scan-start) (cond ((looking-at "scan: no messages in") (keep-lines mh-scan-valid-regexp)) ; Flush random scan lines @@ -1242,19 +1702,66 @@ (mh-notate-user-sequences) (or update (setq mh-mode-line-annotation - (if (equal range "all") + (if (equal range '("all")) nil mh-partial-folder-mode-line-annotation))) (mh-make-folder-mode-line)) (message "Scanning %s...done" folder))) +(defun mh-generate-new-cmd-note (folder) + "Fix the `mh-cmd-note' value for this FOLDER. + +After doing an `mh-get-new-mail' operation in this FOLDER, at least +one line that looks like a truncated message number was found. + +Remove the text added by the last `mh-inc' command. It should be the +messages cur-last. Call `mh-set-cmd-note' with the widest message number +in FOLDER. + +Reformat the message number width on each line in the buffer and trim +the line length to fit in the window. + +Rescan the FOLDER in the range cur-last in order to display the +messages that were removed earlier. They should all fit in the scan +line now with no message truncation." + (save-excursion + (let ((maxcol (1- (window-width))) + (old-cmd-note mh-cmd-note) + mh-cmd-note-fmt + msgnum) + ;; Nuke all of the lines just added by the last inc + (delete-char (- (point-max) (point))) + ;; Update the current buffer to reflect the new mh-cmd-note + ;; value needed to display messages. + (mh-set-cmd-note (mh-message-number-width folder)) + (setq mh-cmd-note-fmt (concat "%" (format "%d" mh-cmd-note) "d")) + ;; Cleanup the messages that are in the buffer right now + (goto-char (point-min)) + (cond ((memq 'unthread mh-view-ops) + (mh-thread-add-spaces (- mh-cmd-note old-cmd-note))) + (t (while (re-search-forward mh-scan-msg-number-regexp nil 0 1) + ;; reformat the number to fix in mh-cmd-note columns + (setq msgnum (string-to-number + (buffer-substring + (match-beginning 1) (match-end 1)))) + (replace-match (format mh-cmd-note-fmt msgnum)) + ;; trim the line to fix in the window + (end-of-line) + (let ((eol (point))) + (move-to-column maxcol) + (if (<= (point) eol) + (delete-char (- eol (point)))))))) + ;; now re-read the lost messages + (goto-char (point-max)) + (prog1 (point) + (mh-regenerate-headers "cur-last" t))))) (defun mh-get-new-mail (maildrop-name) - ;; Read new mail from a maildrop into the current buffer. - ;; Return in the current buffer. + "Read new mail from MAILDROP-NAME into the current buffer. +Return in the current buffer." (let ((point-before-inc (point)) (folder mh-current-folder) - (new-mail-p nil)) + (new-mail-flag nil)) (with-mh-folder-updating (t) (if maildrop-name (message "inc %s -file %s..." folder maildrop-name) @@ -1262,6 +1769,7 @@ (setq mh-next-direction 'forward) (goto-char (point-max)) (let ((start-of-inc (point))) + (mh-remove-cur-notation) (if maildrop-name ;; I think MH 5 used "-ms-file" instead of "-file", ;; which would make inc'ing from maildrops fail. @@ -1270,9 +1778,9 @@ "-file" (expand-file-name maildrop-name) "-width" (window-width) "-truncate") - (mh-exec-cmd-output mh-inc-prog nil - (mh-scan-format) - "-width" (window-width))) + (mh-exec-cmd-output mh-inc-prog nil + (mh-scan-format) + "-width" (window-width))) (if maildrop-name (message "inc %s -file %s...done" folder maildrop-name) (message "inc %s...done" folder)) @@ -1281,55 +1789,83 @@ (re-search-forward "^inc: no mail" nil t)) (message "No new mail%s%s" (if maildrop-name " in " "") (if maildrop-name maildrop-name ""))) - ((re-search-forward "^inc:" nil t) ; Error messages + ((and (when mh-narrowed-to-seq + (let ((saved-text (buffer-substring-no-properties + start-of-inc (point-max)))) + (delete-region start-of-inc (point-max)) + (unwind-protect (mh-widen) + (goto-char (point-max)) + (setq start-of-inc (point)) + (insert saved-text) + (goto-char start-of-inc)))) + nil)) + ((re-search-forward "^inc:" nil t) ; Error messages (error "Error incorporating mail")) + ((and + (equal mh-scan-format-file t) + mh-adaptive-cmd-note-flag + ;; Have we reached an edge condition? + (save-excursion + (re-search-forward mh-scan-msg-overflow-regexp nil 0 1)) + (setq start-of-inc (mh-generate-new-cmd-note folder)) + nil)) (t - (mh-remove-cur-notation) - (setq new-mail-p t))) + (setq new-mail-flag t))) (keep-lines mh-scan-valid-regexp) ; Flush random scan lines - (setq mh-seq-list (mh-read-folder-sequences folder t)) + (setq mh-seq-list (mh-read-folder-sequences folder t)) (mh-notate-user-sequences) - (if new-mail-p + (if new-mail-flag (progn (mh-make-folder-mode-line) + (when (memq 'unthread mh-view-ops) + (mh-thread-inc folder start-of-inc)) (mh-goto-cur-msg)) (goto-char point-before-inc)))))) - (defun mh-make-folder-mode-line (&optional ignored) - ;; Set the fields of the mode line for a folder buffer. - ;; The optional argument is now obsolete. It used to be used to pass - ;; in what is now stored in the buffer-local variable - ;; mh-mode-line-annotation. + "Set the fields of the mode line for a folder buffer. +The optional argument is now obsolete and IGNORED. It used to be used to pass +in what is now stored in the buffer-local variable `mh-mode-line-annotation'." (save-excursion - (mh-first-msg) - (setq mh-first-msg-num (mh-get-msg-num nil)) - (mh-last-msg) - (setq mh-last-msg-num (mh-get-msg-num nil)) - (setq mh-msg-count (if mh-first-msg-num - (count-lines (point-min) (point-max)) - 0)) - (setq mode-line-buffer-identification - (list (format "{%%b%s} %s msg%s" - (if mh-mode-line-annotation - (format "/%s" mh-mode-line-annotation) - "") - (if (zerop mh-msg-count) - "no" - (format "%d" mh-msg-count)) - (if (zerop mh-msg-count) - "s" - (cond ((> mh-msg-count 1) - (format "s (%d-%d)" mh-first-msg-num - mh-last-msg-num)) - (mh-first-msg-num - (format " (%d)" mh-first-msg-num)) - ("")))))))) + (save-window-excursion + (mh-first-msg) + (let ((new-first-msg-num (mh-get-msg-num nil))) + (when (or (not (memq 'unthread mh-view-ops)) + (null mh-first-msg-num) + (null new-first-msg-num) + (< new-first-msg-num mh-first-msg-num)) + (setq mh-first-msg-num new-first-msg-num))) + (mh-last-msg) + (let ((new-last-msg-num (mh-get-msg-num nil))) + (when (or (not (memq 'unthread mh-view-ops)) + (null mh-last-msg-num) + (null new-last-msg-num) + (> new-last-msg-num mh-last-msg-num)) + (setq mh-last-msg-num new-last-msg-num))) + (setq mh-msg-count (if mh-first-msg-num + (count-lines (point-min) (point-max)) + 0)) + (setq mode-line-buffer-identification + (list (format "{%%b%s} %s msg%s" + (if mh-mode-line-annotation + (format "/%s" mh-mode-line-annotation) + "") + (if (zerop mh-msg-count) + "no" + (format "%d" mh-msg-count)) + (if (zerop mh-msg-count) + "s" + (cond ((> mh-msg-count 1) + (format "s (%d-%d)" mh-first-msg-num + mh-last-msg-num)) + (mh-first-msg-num + (format " (%d)" mh-first-msg-num)) + (""))))))))) (defun mh-unmark-all-headers (remove-all-flags) - ;; Remove all '+' flags from the headers, and if called with a non-nil - ;; argument, remove all 'D', '^' and '%' flags too. - ;; Optimized for speed (i.e., no regular expressions). + "Remove all '+' flags from the folder listing. +With non-nil argument REMOVE-ALL-FLAGS, remove all 'D', '^' and '%' flags too. +Optimized for speed (i.e., no regular expressions)." (save-excursion (let ((case-fold-search nil) (last-line (1- (point-max))) @@ -1354,9 +1890,8 @@ (insert " "))))) (forward-line))))) - (defun mh-remove-cur-notation () - ;; Remove old cur notation (cf mh-goto-cur-msg code). + "Remove old cur notation." (let ((cur-msg (car (mh-seq-to-msgs 'cur)))) (save-excursion (and cur-msg @@ -1364,25 +1899,36 @@ (looking-at mh-scan-cur-msg-number-regexp) (mh-notate nil ? mh-cmd-note))))) -(defun mh-goto-cur-msg () - ;; Position the cursor at the current message. +(defun mh-remove-all-notation () + "Remove all notations on all scan lines that MH-E introduces." + (save-excursion + (goto-char (point-min)) + (while (not (eobp)) + (mh-notate nil ? mh-cmd-note) + (when (eq (char-after (+ (point) mh-cmd-note 1)) (elt mh-note-seq 0)) + (mh-notate nil ? (1+ mh-cmd-note))) + (forward-line)))) + +(defun mh-goto-cur-msg (&optional minimal-changes-flag) + "Position the cursor at the current message. +When optional argument MINIMAL-CHANGES-FLAG is non-nil, the function doesn't +recenter the folder buffer." (let ((cur-msg (car (mh-seq-to-msgs 'cur)))) (cond ((and cur-msg (mh-goto-msg cur-msg t t)) - (mh-notate nil mh-note-cur mh-cmd-note) - (mh-recenter 0) - (mh-maybe-show cur-msg)) + (unless minimal-changes-flag + (mh-notate nil mh-note-cur mh-cmd-note) + (mh-recenter 0) + (mh-maybe-show cur-msg))) (t - (mh-last-msg) (message "No current message"))))) - (defun mh-process-or-undo-commands (folder) - ;; If FOLDER has outstanding commands, then either process or discard them. - ;; Called by functions like mh-sort-folder, so also invalidate show buffer. + "If FOLDER has outstanding commands, then either process or discard them. +Called by functions like `mh-sort-folder', so also invalidate show buffer." (set-buffer folder) (if (mh-outstanding-commands-p) - (if (or mh-do-not-confirm + (if (or mh-do-not-confirm-flag (y-or-n-p "Process outstanding deletes and refiles (or lose them)? ")) (mh-process-commands folder) @@ -1390,9 +1936,10 @@ (mh-update-unseen) (mh-invalidate-show-buffer)) - (defun mh-process-commands (folder) - ;; Process outstanding commands for the folder FOLDER. + "Process outstanding commands for FOLDER. +The value of `mh-folder-updated-hook' is a list of functions to be called, +with no arguments, before the commands are processed." (message "Processing deletes and refiles for %s..." folder) (set-buffer folder) (with-mh-folder-updating (nil) @@ -1402,31 +1949,35 @@ ;; Update the unseen sequence if it exists (mh-update-unseen) - ;; Then refile messages - (mh-mapc - (function - (lambda (dest) - (let ((msgs (mh-seq-to-msgs dest))) - (cond (msgs - (apply 'mh-exec-cmd "refile" - "-src" folder (symbol-name dest) - (mh-coalesce-msg-list msgs)) - (mh-delete-scan-msgs msgs)))))) - mh-refile-list) - (setq mh-refile-list nil) + (let ((redraw-needed-flag nil)) + ;; Then refile messages + (mh-mapc #'(lambda (folder-msg-list) + (let ((dest-folder (symbol-name (car folder-msg-list))) + (msgs (cdr folder-msg-list))) + (setq redraw-needed-flag t) + (apply #'mh-exec-cmd + "refile" "-src" folder dest-folder + (mh-coalesce-msg-list msgs)) + (mh-delete-scan-msgs msgs))) + mh-refile-list) + (setq mh-refile-list ()) - ;; Now delete messages - (cond (mh-delete-list - (apply 'mh-exec-cmd "rmm" folder - (mh-coalesce-msg-list mh-delete-list)) - (mh-delete-scan-msgs mh-delete-list) - (setq mh-delete-list nil))) + ;; Now delete messages + (cond (mh-delete-list + (setq redraw-needed-flag t) + (apply 'mh-exec-cmd "rmm" folder + (mh-coalesce-msg-list mh-delete-list)) + (mh-delete-scan-msgs mh-delete-list) + (setq mh-delete-list nil))) - ;; Don't need to remove sequences since delete and refile do so. + ;; Don't need to remove sequences since delete and refile do so. + ;; Mark cur message + (if (> (buffer-size) 0) + (mh-define-sequence 'cur (list (or (mh-get-msg-num nil) "last")))) - ;; Mark cur message - (if (> (buffer-size) 0) - (mh-define-sequence 'cur (list (or (mh-get-msg-num nil) "last")))) + ;; Redraw folder window if needed + (when (and (memq 'unthread mh-view-ops) redraw-needed-flag) + (mh-thread-inc folder (point-max)))) (and (buffer-file-name (get-buffer mh-show-buffer)) (not (file-exists-p (buffer-file-name (get-buffer mh-show-buffer)))) @@ -1439,10 +1990,11 @@ (mh-notate-user-sequences) (message "Processing deletes and refiles for %s...done" folder))) - (defun mh-update-unseen () - ;; Flush updates to the Unseen sequence out to MH. - ;; Return non-NIL iff set the MH folder. + "Synchronize the unseen sequence with MH. +Return non-nil iff the MH folder was set. +The value of `mh-unseen-updated-hook' is a list of functions to be called, +with no arguments, after the unseen sequence is updated." (if mh-seen-list (let* ((unseen-seq (mh-find-seq mh-unseen-seq)) (unseen-msgs (mh-seq-msgs unseen-seq))) @@ -1457,26 +2009,25 @@ t) ;since we set the folder (setq mh-seen-list nil))))) - (defun mh-delete-scan-msgs (msgs) - ;; Delete the scan listing lines for each of the msgs in the LIST. + "Delete the scan listing lines for MSGS." (save-excursion (while msgs - (if (mh-goto-msg (car msgs) t t) - (mh-delete-line 1)) + (when (mh-goto-msg (car msgs) t t) + (when (memq 'unthread mh-view-ops) + (mh-thread-forget-message (car msgs))) + (mh-delete-line 1)) (setq msgs (cdr msgs))))) - (defun mh-outstanding-commands-p () - ;; Returns non-nil if there are outstanding deletes or refiles. + "Return non-nil if there are outstanding deletes or refiles." (or mh-delete-list mh-refile-list)) - (defun mh-coalesce-msg-list (messages) - ;; Give a list of MESSAGES, return a list of message number ranges. - ;; Sort of the opposite of mh-read-msg-list, which expands ranges. - ;; Message lists passed to MH programs go through this so - ;; command line arguments won't exceed system limits. + "Give a list of MESSAGES, return a list of message number ranges. +Sort of the opposite of `mh-read-msg-list', which expands ranges. +Message lists passed to MH programs go through this so +command line arguments won't exceed system limits." (let ((msgs (sort (copy-sequence messages) 'mh-greaterp)) (range-high nil) (prev -1) @@ -1497,8 +2048,9 @@ ranges)) (defun mh-greaterp (msg1 msg2) - ;; Sort two message indicators. Strings are "smaller" than numbers. - ;; Legal values are things like "cur", "last", 1, and 1820. + "Return the greater of two message indicators MSG1 and MSG2. +Strings are \"smaller\" than numbers. +Legal values are things like \"cur\", \"last\", 1, and 1820." (if (numberp msg1) (if (numberp msg2) (> msg1 msg2) @@ -1508,20 +2060,24 @@ (string-lessp msg2 msg1)))) (defun mh-lessp (msg1 msg2) + "Return the lesser of two message indicators MSG1 and MSG2. +Strings are \"smaller\" than numbers. +Legal values are things like \"cur\", \"last\", 1, and 1820." (not (mh-greaterp msg1 msg2))) + ;;; Basic sequence handling (defun mh-delete-seq-locally (seq) - ;; Remove mh-e's record of SEQUENCE. + "Remove MH-E's record of SEQ." (let ((entry (mh-find-seq seq))) (setq mh-seq-list (delq entry mh-seq-list)))) (defun mh-read-folder-sequences (folder save-refiles) - ;; Read and return the predefined sequences for a FOLDER. - ;; If SAVE-REFILES is non-nil, then keep the sequences - ;; that note messages to be refiled. + "Read and return the predefined sequences for a FOLDER. +If SAVE-REFILES is non-nil, then keep the sequences +that note messages to be refiled." (let ((seqs ())) (cond (save-refiles (mh-mapc (function (lambda (seq) ; Save the refiling sequences @@ -1538,12 +2094,13 @@ (match-end 0))) (mh-read-msg-list)) seqs))) - (delete-region (point-min) (point))))) ; avoid race with mh-process-daemon + (delete-region (point-min) (point))))) ; avoid race with + ; mh-process-daemon seqs)) (defun mh-read-msg-list () - ;; Return a list of message numbers from the current point to the end of - ;; the line. Expands ranges into set of individual numbers. + "Return a list of message numbers from point to the end of the line. +Expands ranges into set of individual numbers." (let ((msgs ()) (end-of-line (save-excursion (end-of-line) (point))) num) @@ -1565,7 +2122,7 @@ msgs)) (defun mh-notate-user-sequences () - ;; Mark the scan listing of all messages in user-defined sequences. + "Mark the scan listing of all messages in user-defined sequences." (let ((seqs mh-seq-list) name) (while seqs @@ -1574,15 +2131,13 @@ (mh-notate-seq name mh-note-seq (1+ mh-cmd-note))) (setq seqs (cdr seqs))))) - (defun mh-internal-seq (name) - ;; Return non-NIL if NAME is the name of an internal mh-e sequence. + "Return non-nil if NAME is the name of an internal MH-E sequence." (or (memq name '(answered cur deleted forwarded printed)) (eq name mh-unseen-seq) (eq name mh-previous-seq) (mh-folder-name-p name))) - (defun mh-delete-msg-from-seq (message sequence &optional internal-flag) "Delete MESSAGE from SEQUENCE. MESSAGE defaults to displayed message. From Lisp, optional third arg @@ -1597,18 +2152,16 @@ (mh-undefine-sequence sequence (list message))) (setcdr entry (delq message (mh-seq-msgs entry))))))) - (defun mh-undefine-sequence (seq msgs) - ;; Remove from the SEQUENCE the list of MSGS. + "Remove from the SEQ the list of MSGS." (mh-exec-cmd "mark" mh-current-folder "-delete" "-sequence" (symbol-name seq) (mh-coalesce-msg-list msgs))) - (defun mh-define-sequence (seq msgs) - ;; Define the SEQUENCE to contain the list of MSGS. - ;; Do not mark pseudo-sequences or empty sequences. - ;; Signals an error if SEQUENCE is an illegal name. + "Define the SEQ to contain the list of MSGS. +Do not mark pseudo-sequences or empty sequences. +Signals an error if SEQ is an illegal name." (if (and msgs (not (mh-folder-name-p seq))) (save-excursion @@ -1616,45 +2169,42 @@ "-sequence" (symbol-name seq) (mh-coalesce-msg-list msgs))))) - -(defun mh-map-over-seqs (func seq-list) - ;; Apply the FUNCTION to each element in the list of SEQUENCES, - ;; passing the sequence name and the list of messages as arguments. +(defun mh-map-over-seqs (function seq-list) + "Apply FUNCTION to each sequence in SEQ-LIST. +The sequence name and the list of messages are passed as arguments." (while seq-list - (funcall func (mh-seq-name (car seq-list)) (mh-seq-msgs (car seq-list))) + (funcall function + (mh-seq-name (car seq-list)) + (mh-seq-msgs (car seq-list))) (setq seq-list (cdr seq-list)))) - -(defun mh-notate-if-in-one-seq (msg notation offset seq) - ;; If the MESSAGE is in only the SEQUENCE, then mark the scan listing of the - ;; message with the CHARACTER at the given OFFSET from the beginning of the - ;; listing line. +(defun mh-notate-if-in-one-seq (msg character offset seq) + "Notate MSG. +The CHARACTER is placed at the given OFFSET from the beginning of the listing. +The notation is performed if the MSG is only in SEQ." (let ((in-seqs (mh-seq-containing-msg msg nil))) (if (and (eq seq (car in-seqs)) (null (cdr in-seqs))) - (mh-notate msg notation offset)))) - + (mh-notate msg character offset)))) -(defun mh-seq-containing-msg (msg &optional include-internal-p) - ;; Return a list of the sequences containing MESSAGE. - ;; If INCLUDE-INTERNAL-P non-nil, include mh-e internal sequences in list. +(defun mh-seq-containing-msg (msg &optional include-internal-flag) + "Return a list of the sequences containing MSG. +If INCLUDE-INTERNAL-FLAG non-nil, include MH-E internal sequences in list." (let ((l mh-seq-list) (seqs ())) (while l (and (memq msg (mh-seq-msgs (car l))) - (or include-internal-p + (or include-internal-flag (not (mh-internal-seq (mh-seq-name (car l))))) (setq seqs (cons (mh-seq-name (car l)) seqs))) (setq l (cdr l))) seqs)) - ;;; User prompting commands. - (defun mh-read-msg-range (prompt) - ;; Read a list of blank-separated items. + "Read a list of blank-separated messages using the given PROMPT." (let* ((buf (read-string prompt)) (buf-size (length buf)) (start 0) @@ -1671,30 +2221,42 @@ (suppress-keymap mh-folder-mode-map) +;; Use defalias to make sure the documented primary key bindings +;; appear in menu lists. +(defalias 'mh-alt-show 'mh-show) +(defalias 'mh-alt-refile-msg 'mh-refile-msg) +(defalias 'mh-alt-send 'mh-send) +(defalias 'mh-alt-visit-folder 'mh-visit-folder) + ;; Save the `b' binding for a future `back'. Maybe? (gnus-define-keys mh-folder-mode-map " " mh-page-msg "!" mh-refile-or-write-again "," mh-header-display - "." mh-show ;alias + "." mh-alt-show ">" mh-write-msg-to-file + "?" mh-help "E" mh-extract-rejected-mail + "M" mh-modify "\177" mh-previous-page "\C-d" mh-delete-msg-no-motion + "\t" mh-next-button + [backtab] mh-prev-button + "\M-\t" mh-prev-button "\e<" mh-first-msg "\e>" mh-last-msg "\ed" mh-redistribute "\r" mh-show - "^" mh-refile-msg ;alias + "^" mh-alt-refile-msg "c" mh-copy-msg "d" mh-delete-msg "e" mh-edit-again "f" mh-forward "g" mh-goto-msg "i" mh-inc-folder - "k" mh-delete-subject-thread + "k" mh-delete-subject "l" mh-print-msg - "m" mh-send ;alias + "m" mh-alt-send "n" mh-next-undeleted-msg "o" mh-refile-msg "p" mh-previous-undeleted-msg @@ -1707,11 +2269,13 @@ "|" mh-pipe-msg) (gnus-define-keys (mh-folder-map "F" mh-folder-mode-map) + "?" mh-prefix-help "S" mh-sort-folder - "f" mh-visit-folder ;alias + "f" mh-alt-visit-folder + "i" mh-index-search "k" mh-kill-folder "l" mh-list-folders - "o" mh-visit-folder ;alias + "o" mh-alt-visit-folder "p" mh-pack-folder "r" mh-rescan-folder "s" mh-search-folder @@ -1719,6 +2283,7 @@ "v" mh-visit-folder) (gnus-define-keys (mh-sequence-map "S" mh-folder-mode-map) + "?" mh-prefix-help "d" mh-delete-msg-from-seq "k" mh-delete-seq "l" mh-list-sequences @@ -1728,175 +2293,101 @@ "w" mh-widen) (gnus-define-keys (mh-thread-map "T" mh-folder-mode-map) - "d" mh-delete-subject-thread - "k" mh-delete-subject-thread - "s" mh-narrow-to-subject-thread - "t" mh-toggle-subject-thread - "u" mh-next-unseen-subject-thread) + "?" mh-prefix-help + "t" mh-toggle-threads) + +(gnus-define-keys (mh-limit-map "/" mh-folder-mode-map) + "?" mh-prefix-help + "s" mh-narrow-to-subject + "w" mh-widen) (gnus-define-keys (mh-extract-map "X" mh-folder-mode-map) + "?" mh-prefix-help "s" mh-store-msg ;shar "u" mh-store-msg) ;uuencode (gnus-define-keys (mh-digest-map "D" mh-folder-mode-map) " " mh-page-digest + "?" mh-prefix-help "\177" mh-page-digest-backwards "b" mh-burst-digest) +(gnus-define-keys (mh-mime-map "K" mh-folder-mode-map) + "?" mh-prefix-help + "a" mh-mime-save-parts + "i" mh-folder-inline-mime-part + "o" mh-folder-save-mime-part + "v" mh-folder-toggle-mime-part + "\t" mh-next-button + [backtab] mh-prev-button + "\M-\t" mh-prev-button) + (cond - ((not (null (save-match-data (string-match "XEmacs\\|Lucid" emacs-version)))) + (mh-xemacs-flag (define-key mh-folder-mode-map [button2] 'mh-show-mouse)) (t (define-key mh-folder-mode-map [mouse-2] 'mh-show-mouse))) ;; "C-c /" prefix is used in mh-folder-mode by pgp.el and mailcrypt -;;; Menu extracted from mh-menubar.el V1.1 (31 July 2001) -;;; Menus for folder mode: folder, message, sequence (in that order) -;;; folder-mode "Sequence" menu -(easy-menu-define - mh-folder-sequence-menu mh-folder-mode-map "Menu for mh-e folder-sequence." - '("Sequence" - ["Add Msg to Seq..." mh-put-msg-in-seq (mh-get-msg-num nil)] - ["List Seq's for Msg" mh-msg-is-in-seq (mh-get-msg-num nil)] - ["Delete Msg from Seq..." mh-delete-msg-from-seq (mh-get-msg-num nil)] - ["List Seq's in Folder..." mh-list-sequences t] - ["Delete Seq..." mh-delete-seq t] - ["Show Only Msgs in Seq..." mh-narrow-to-seq t] - ["Show All Msgs in Folder" mh-widen mh-narrowed-to-seq] - "--" - ["Toggle Subject Thread" mh-toggle-subject-thread t] - ["Narrow to Subject Thread" mh-narrow-to-subject-thread t] - ["Delete Rest of Subject Thread" mh-delete-subject-thread t] - ["Next Unseen Subject Thread" mh-next-unseen-subject-thread t] - "--" - ["Push State Out to MH" mh-update-sequences t])) - -;;; folder-mode "Message" menu -(easy-menu-define - mh-folder-message-menu mh-folder-mode-map "Menu for mh-e folder-message." - '("Message" - ["Show Msg" mh-show (mh-get-msg-num nil)] - ["Next Msg" mh-next-undeleted-msg t] - ["Previous Msg" mh-previous-undeleted-msg t] - ["Go to First Msg" mh-first-msg t] - ["Go to Last Msg" mh-last-msg t] - ["Go to Msg by Number..." mh-goto-msg t] - ["Delete Msg" mh-delete-msg (mh-get-msg-num nil)] - ["Refile Msg" mh-refile-msg (mh-get-msg-num nil)] - ["Undo Delete/Refile" mh-undo t] - ["Process Delete/Refile" mh-execute-commands - (or mh-refile-list mh-delete-list)] - "--" - ["Compose a New Msg" mh-send t] - ["Reply to Msg..." mh-reply (mh-get-msg-num nil)] - ["Forward Msg..." mh-forward (mh-get-msg-num nil)] - ["Redistribute Msg..." mh-redistribute (mh-get-msg-num nil)] - ["Edit Msg Again" mh-edit-again (mh-get-msg-num nil)] - ["Re-edit a Bounced Msg" mh-extract-rejected-mail t] - "--" - ["Refile Msg in Folder..." mh-refile-msg (mh-get-msg-num nil)] - ["Copy Msg to Folder..." mh-copy-msg (mh-get-msg-num nil)] - ["Print Msg" mh-print-msg (mh-get-msg-num nil)] - ["Write Msg to File..." mh-write-msg-to-file (mh-get-msg-num nil)] - ["Pipe Msg to Command..." mh-pipe-msg (mh-get-msg-num nil)] - ["Unpack Uuencoded Msg..." mh-store-msg (mh-get-msg-num nil)] - ["Show Msg with Header" mh-header-display (mh-get-msg-num nil)] - ["Burst Digest Msg" mh-burst-digest (mh-get-msg-num nil)])) - -;;; folder-mode "Folder" menu -(easy-menu-define - mh-folder-folder-menu mh-folder-mode-map "Menu for mh-e folder." - '("Folder" - ["Incorporate New Mail" mh-inc-folder t] - ["Toggle Show/Folder" mh-toggle-showing t] - ["Execute Delete/Refile" mh-execute-commands - (or mh-refile-list mh-delete-list)] - ["Rescan Folder" mh-rescan-folder t] - ["Pack Folder" mh-pack-folder t] - ["Sort Folder" mh-sort-folder t] - "--" - ["Search a Folder..." mh-search-folder t] - ["Visit a Folder..." mh-visit-folder t] - ["List Folders" mh-list-folders t] - ["Quit MH-E" mh-quit t])) -;;; Support for emacs21 toolbar using gnus/message.el icons (and code). -(eval-when-compile (defvar tool-bar-map)) -(when (and (fboundp 'tool-bar-add-item) - tool-bar-mode) - (defvar mh-folder-tool-bar-map - (let ((tool-bar-map (make-sparse-keymap))) - (tool-bar-add-item "mail" 'mh-inc-folder 'mh-folder-inc-folder - :help "Incorporate new mail in Inbox") - - (tool-bar-add-item "left_arrow" 'mh-previous-undeleted-msg - 'mh-folder-prev :help "Previous message") - (tool-bar-add-item "page-down" 'mh-page-msg 'mh-folder-page - :help "Page this message") - (tool-bar-add-item "right_arrow" 'mh-next-undeleted-msg 'mh-folder-next - :help "Next message") +;;; Help Messages - (tool-bar-add-item "close" 'mh-delete-msg 'mh-folder-delete - :help "Mark for deletion") - (tool-bar-add-item "refile" 'mh-refile-msg 'mh-folder-refile - :help "Refile this message") - (tool-bar-add-item "undo" 'mh-undo 'mh-folder-undo - :help "Undo this mark") - (tool-bar-add-item "execute" 'mh-execute-commands 'mh-folder-exec - :help "Perform moves and deletes") - - (tool-bar-add-item "show" 'mh-toggle-showing 'mh-folder-toggle-show - :help "Toggle showing message") +;;; If you add a new prefix, add appropriate text to the nil key. +;;; +;;; In general, messages are grouped logically. Taking the main commands for +;;; example, the first line is "ways to view messages," the second line is +;;; "things you can do with messages", and the third is "composing" messages. +;;; +;;; When adding a new prefix, ensure that the help message contains "what" the +;;; prefix is for. For example, if the word "folder" were not present in the +;;; `F' entry, it would not be clear what these commands operated upon. +(defvar mh-help-messages + '((nil "[i]nc, [.]show, [,]show all, [n]ext, [p]revious,\n" + "[d]elete, [o]refile, e[x]ecute,\n" + "[s]end, [r]eply.\n" + "Prefix characters:\n [F]older, [S]equence, MIME [K]eys, " + "[T]hread, / Limit, e[X]tract, [D]igest.") - (tool-bar-add-item "mail/reply2" 'mh-reply 'mh-folder-reply - :help "Reply to this message") - (tool-bar-add-item "mail_compose" 'mh-send 'mh-folder-compose - :help "Compose new message") - - (tool-bar-add-item "rescan" 'mh-rescan-folder 'mh-folder-rescan - :help "Rescan this folder") - (tool-bar-add-item "repack" 'mh-pack-folder 'mh-folder-pack - :help "Repack this folder") - - (tool-bar-add-item "search" 'mh-search-folder 'mh-folder-search - :help "Search this folder") - (tool-bar-add-item "fld_open" 'mh-visit-folder 'mh-folder-visit - :help "Visit other folder") + (?F "[l]ist, [v]isit folder;\n" + "[t]hread; [s]earch; [i]ndexed search;\n" + "[p]ack; [S]ort; [r]escan; [k]ill") + (?S "[p]ut message in sequence, [n]arrow, [w]iden,\n" + "[s]equences, [l]ist,\n" + "[d]elete message from sequence, [k]ill sequence") + (?T "[t]oggle thread") + (?/ "Limit to [s]ubject; [w]iden") + (?X "un[s]har, [u]udecode message") + (?D "[b]urst digest") + (?K "[v]iew, [i]nline, [o]utput/save MIME part; save [a]ll parts; \n" + "[TAB] next; [SHIFT-TAB] previous")) + "Key binding cheat sheet. - (tool-bar-add-item "preferences" (lambda () - (interactive) - (customize-group "mh")) - 'mh-folder-customize - :help "mh-e preferences") - (tool-bar-add-item "help" (lambda () - (interactive) - (Info-goto-node "(mh-e)Top")) - 'mh-folder-help :help "Help") - tool-bar-map)) +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. - (defvar mh-folder-seq-tool-bar-map - (let ((tool-bar-map (copy-keymap mh-folder-tool-bar-map))) - (tool-bar-add-item "widen" 'mh-widen 'mh-folder-widen - :help "Widen from this sequence") - tool-bar-map) - "Tool-bar to use when narrowed to a sequence in MH-Folder buffers.") - ) +The substitutions described in `substitute-command-keys' are performed as +well.") -;;;autoload the other mh-e parts + + +;;; autoload the other MH-E parts ;;; mh-comp (autoload 'mh-smail "mh-comp" "Compose and send mail with the MH mail system. -This function is an entry point to mh-e, the Emacs front end +This function is an entry point to MH-E, the Emacs front end to the MH mail system. See documentation of `\\[mh-send]' for more details on composing mail." t) (autoload 'mh-smail-other-window "mh-comp" "Compose and send mail in other window with the MH mail system. -This function is an entry point to mh-e, the Emacs front end +This function is an entry point to MH-E, the Emacs front end to the MH mail system. See documentation of `\\[mh-send]' for more details on composing mail." t) @@ -1922,36 +2413,24 @@ Depending on how your copy of MH was compiled, you may need to change the setting of the variable mh-redist-full-contents. See its documentation." t) -(autoload 'mh-reply "mh-comp" - "Reply to a MESSAGE (default: displayed message). -If optional prefix argument INCLUDEP provided, then include the message -in the reply using filter mhl.reply in your MH directory. -Prompts for type of addresses to reply to: - from sender only, - to sender and primary recipients, - cc/all sender and all recipients. -If the file named by `mh-repl-formfile' exists, it is used as a skeleton -for the reply. See also documentation for `\\[mh-send]' function." t) - (autoload 'mh-send "mh-comp" "Compose and send a letter. The file named by `mh-comp-formfile' will be used as the form. -Do not call this function from outside mh-e; use \\[mh-smail] instead. +Do not call this function from outside MH-E; use \\[mh-smail] instead. The letter is composed in mh-letter-mode; see its documentation for more details. If `mh-compose-letter-function' is defined, it is called on the draft and passed three arguments: to, subject, and cc." t) (autoload 'mh-send-other-window "mh-comp" "Compose and send a letter in another window. -Do not call this function from outside mh-e; +Do not call this function from outside MH-E; use \\[mh-smail-other-window] instead. See also documentation for `\\[mh-send]' function." t) (autoload 'mh-letter-mode "mh-comp" - "Mode for composing letters in mh-e. + "Mode for composing letters in MH-E. For more details, type \\[describe-mode] while in MH-Letter mode." t) - ;;; mh-funcs (autoload 'mh-burst-digest "mh-funcs" @@ -1999,9 +2478,6 @@ The arguments in the list mh-sortm-args are passed to sortm if this function is passed an argument." t) -(autoload 'mh-undo-folder "mh-funcs" - "Undo all commands in current folder." t) - (autoload 'mh-store-msg "mh-funcs" "Store the file(s) contained in the current message into DIRECTORY. The message can contain a shar file or uuencoded file. @@ -2014,6 +2490,12 @@ Default directory is the last directory used, or initially the value of `mh-store-default-directory' or the current directory." t) +(autoload 'mh-help "mh-funcs" + "Display cheat sheet for MH-E commands in minibuffer." t) + +(autoload 'mh-prefix-help "mh-funcs" + "Display cheat sheet for the commands of the current prefix in minibuffer." + t) ;;; mh-pick @@ -2037,23 +2519,32 @@ (autoload 'mh-put-msg-in-seq "mh-seq" "Add MESSAGE(s) (default: displayed message) to SEQUENCE. If optional prefix argument provided, then prompt for the message sequence." t) -(autoload 'mh-widen "mh-seq" - "Remove restrictions from current folder, thereby showing all messages." t) (autoload 'mh-rename-seq "mh-seq" "Rename SEQUENCE to have NEW-NAME." t) -(autoload 'mh-narrow-to-subject-thread "mh-seq" +(autoload 'mh-narrow-to-subject "mh-seq" "Narrow to a sequence containing all following messages with same subject." t) -(autoload 'mh-toggle-subject-thread "mh-seq" - "Narrow to or widen from a sequence containing current subject sequence." t) -(autoload 'mh-delete-subject-thread "mh-seq" +(autoload 'mh-toggle-threads "mh-seq" + "Toggle threaded view of folder." t) +(autoload 'mh-delete-subject "mh-seq" "Mark all following messages with same subject to be deleted." t) -(autoload 'mh-next-unseen-subject-thread "mh-seq" - "Get the next unseen subject thread." t) + +;;; mh-speed +(autoload 'mh-folder-speedbar-buttons "mh-speed") +(autoload 'mh-show-speedbar-buttons "mh-speed") +(autoload 'mh-index-folder-speedbar-buttons "mh-speed") +(autoload 'mh-index-show-speedbar-buttons "mh-speed") +(autoload 'mh-letter-speedbar-buttons "mh-speed") (dolist (mess '("^Cursor not pointing to message$" "^There is no other window$")) (add-to-list 'debug-ignored-errors mess)) +(provide 'mh-e) + +;;; Local Variables: +;;; sentence-end-double-space: nil +;;; End: + ;;; mh-e.el ends here
--- a/lisp/mail/mh-funcs.el Fri Nov 29 18:02:52 2002 +0000 +++ b/lisp/mail/mh-funcs.el Fri Nov 29 18:15:21 2002 +0000 @@ -1,4 +1,4 @@ -;;; mh-funcs.el --- mh-e functions not everyone will use right away +;;; mh-funcs.el --- MH-E functions not everyone will use right away ;; Copyright (C) 1993, 1995, 2001, 2002 Free Software Foundation, Inc. @@ -26,19 +26,22 @@ ;;; Commentary: -;; Internal support for mh-e package. -;; Putting these functions in a separate file lets mh-e start up faster, +;; Internal support for MH-E package. +;; Putting these functions in a separate file lets MH-E start up faster, ;; since less Lisp code needs to be loaded all at once. ;;; Change Log: -;; $Id: mh-funcs.el,v 1.12 2002/04/07 19:20:56 wohler Exp $ +;; $Id: mh-funcs.el,v 1.28 2002/11/11 23:01:27 mbaushke Exp $ ;;; Code: -(provide 'mh-funcs) (require 'mh-e) +;;; autoload +(autoload 'mh-notate-seq "mh-seq") +(autoload 'mh-speed-invalidate-map "mh-speed") + ;;; customization (defvar mh-sortm-args nil @@ -54,7 +57,7 @@ (defvar mh-note-printed "P" "String whose first character is used to notate printed messages.") -;;; functions +;;; Functions (defun mh-burst-digest () "Burst apart the current message, which should be a digest. @@ -73,11 +76,10 @@ (mh-goto-cur-msg) (message "Bursting digest...done"))) - (defun mh-copy-msg (msg-or-seq folder) "Copy the specified MSG-OR-SEQ to another FOLDER without deleting them. -Default is the displayed message. If optional prefix argument is -provided, then prompt for the message sequence." +Default is the displayed message. If optional prefix argument is provided, +then prompt for the message sequence." (interactive (list (if current-prefix-arg (mh-read-seq-default "Copy" t) (mh-get-msg-num t)) @@ -90,7 +92,9 @@ (defun mh-kill-folder () "Remove the current folder and all included messages. Removes all of the messages (files) within the specified current folder, -and then removes the folder (directory) itself." +and then removes the folder (directory) itself. +The value of `mh-folder-list-change-hook' is a list of functions to be called, +with no arguments, after the folders has been removed." (interactive) (if (yes-or-no-p (format "Remove folder %s (and all included messages)?" mh-current-folder)) @@ -101,6 +105,8 @@ (mh-exec-cmd-daemon "rmf" folder) (setq mh-folder-list (delq (assoc folder mh-folder-list) mh-folder-list)) + (when (boundp 'mh-speed-folder-map) + (mh-speed-invalidate-map folder)) (run-hooks 'mh-folder-list-change-hook) (message "Folder %s removed" folder) (mh-set-folder-modified-p nil) ; so kill-buffer doesn't complain @@ -110,6 +116,8 @@ (kill-buffer folder))) (message "Folder not removed"))) +;; Avoid compiler warning... +(defvar view-exit-action) (defun mh-list-folders () "List mail folders." @@ -120,7 +128,7 @@ (set-buffer temp-buffer) (erase-buffer) (message "Listing folders...") - (mh-exec-cmd-output "folders" t (if mh-recursive-folders + (mh-exec-cmd-output "folders" t (if mh-recursive-folders-flag "-recurse" "-norecurse")) (goto-char (point-min)) @@ -128,12 +136,11 @@ (setq view-exit-action 'kill-buffer) (message "Listing folders...done"))))) - (defun mh-pack-folder (range) "Renumber the messages of a folder to be 1..n. -First, offer to execute any outstanding commands for the current folder. -If optional prefix argument provided, prompt for the RANGE of messages -to display after packing. Otherwise, show the entire folder." +First, offer to execute any outstanding commands for the current folder. If +optional prefix argument provided, prompt for the RANGE of messages to display +after packing. Otherwise, show the entire folder." (interactive (list (if current-prefix-arg (mh-read-msg-range "Range to scan after packing [all]? ") @@ -142,18 +149,19 @@ (mh-goto-cur-msg) (message "Packing folder...done")) - (defun mh-pack-folder-1 (range) - ;; Close and pack the current folder. + "Close and pack the current folder. +Display the given RANGE of messages after packing. If RANGE is nil, show the +entire folder." (mh-process-or-undo-commands mh-current-folder) (message "Packing folder...") (mh-set-folder-modified-p t) ; lock folder while packing (save-excursion (mh-exec-cmd-quiet t "folder" mh-current-folder "-pack" "-norecurse" "-fast")) + (mh-reset-threads-and-narrowing) (mh-regenerate-headers range)) - (defun mh-pipe-msg (command include-headers) "Pipe the current message through the given shell COMMAND. If INCLUDE-HEADERS (prefix argument) is provided, send the entire message. @@ -171,7 +179,6 @@ (let ((default-directory message-directory)) (shell-command-on-region (point) (point-max) command nil))))) - (defun mh-page-digest () "Advance displayed message to next digested message." (interactive) @@ -188,7 +195,6 @@ (forward-line 2) (mh-recenter 0))) - (defun mh-page-digest-backwards () "Back up displayed message to previous digested message." (interactive) @@ -205,12 +211,11 @@ (forward-line 2)) (mh-recenter 0))) - (defun mh-print-msg (msg-or-seq) "Print MSG-OR-SEQ (default: displayed message) on printer. If optional prefix argument provided, then prompt for the message sequence. The variable `mh-lpr-command-format' is used to generate the print command. -The messages are formatted by mhl. See the variable `mhl-formfile'." +The messages are formatted by mhl. See the variable `mhl-formfile'." (interactive (list (if current-prefix-arg (reverse (mh-seq-to-msgs (mh-read-seq-default "Print" t))) @@ -244,7 +249,7 @@ msg-or-seq) (format "Sequence from %s" mh-current-folder))))))) - (if mh-print-background + (if mh-print-background-flag (mh-exec-cmd-daemon shell-file-name "-c" print-command) (call-process shell-file-name nil nil nil "-c" print-command)) (if (numberp msg-or-seq) @@ -255,17 +260,15 @@ (message "Printing message...done") (message "Printing sequence...done")))) - (defun mh-msg-filenames (msgs &optional folder) - ;; Return a list of file names for MSGS in FOLDER (default current folder). + "Return a list of file names for MSGS in FOLDER (default current folder)." (mapconcat (function (lambda (msg) (mh-msg-filename msg folder))) msgs " ")) - (defun mh-sort-folder (&optional extra-args) "Sort the messages in the current folder by date. Calls the MH program sortm to do the work. -The arguments in the list `mh-sortm-args' are passed to sortm -if the optional argument EXTRA-ARGS is given." +The arguments in the list `mh-sortm-args' are passed to sortm if the optional +argument EXTRA-ARGS is given." (interactive "P") (mh-process-or-undo-commands mh-current-folder) (setq mh-next-direction 'forward) @@ -275,12 +278,11 @@ (message "Sorting folder...done") (mh-scan-folder mh-current-folder "all")) - (defun mh-undo-folder (&rest ignore) "Undo all pending deletes and refiles in current folder. Argument IGNORE is deprecated." (interactive) - (cond ((or mh-do-not-confirm + (cond ((or mh-do-not-confirm-flag (yes-or-no-p "Undo all commands in folder? ")) (setq mh-delete-list nil mh-refile-list nil @@ -292,7 +294,6 @@ (message "Commands not undone.") (sit-for 2)))) - (defun mh-store-msg (directory) "Store the file(s) contained in the current message into DIRECTORY. The message can contain a shar file or uuencoded file. @@ -313,7 +314,8 @@ The buffer can contain a shar file or uuencoded file. Default directory is the last directory used, or initially the value of `mh-store-default-directory' or the current directory." - (interactive (list (let ((udir (or mh-store-default-directory default-directory))) + (interactive (list (let ((udir (or mh-store-default-directory + default-directory))) (read-file-name "Store buffer in directory: " udir udir nil)))) (let ((store-directory (expand-file-name directory)) @@ -362,5 +364,42 @@ (set-buffer log-buffer) (mh-handle-process-error command value)) (insert "\n(mh-store finished)\n"))) + + + +;;; Help Functions + +(defun mh-ephem-message (string) + "Display STRING in the minibuffer momentarily." + (message "%s" string) + (sit-for 5) + (message "")) + +(defun mh-help () + "Display cheat sheet for the MH-Folder commands in minibuffer." + (interactive) + (mh-ephem-message + (substitute-command-keys + (mapconcat 'identity (cdr (assoc nil mh-help-messages)) "")))) +(defun mh-prefix-help () + "Display cheat sheet for the commands of the current prefix in minibuffer." + (interactive) + ;; We got here because the user pressed a `?', but he pressed a prefix key + ;; before that. Since the the key vector starts at index 0, the index of the + ;; last keystroke is length-1 and thus the second to last keystroke is at + ;; length-2. We use that information to obtain a suitable prefix character + ;; from the recent keys. + (let* ((keys (recent-keys)) + (prefix-char (elt keys (- (length keys) 2)))) + (mh-ephem-message + (substitute-command-keys + (mapconcat 'identity (cdr (assoc prefix-char mh-help-messages)) ""))))) + +(provide 'mh-funcs) + +;;; Local Variables: +;;; sentence-end-double-space: nil +;;; End: + ;;; mh-funcs.el ends here
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/mail/mh-index.el Fri Nov 29 18:15:21 2002 +0000 @@ -0,0 +1,1290 @@ +;;; mh-index -- MH-E interface to indexing programs + +;; Copyright (C) 2002 Free Software Foundation, Inc. + +;; Author: Bill Wohler <wohler@newt.com> +;; Maintainer: Bill Wohler <wohler@newt.com> +;; Keywords: mail +;; See: mh-e.el + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Commentary: + +;;; (1) The following search engines are supported: +;;; swish++ +;;; swish-e +;;; namazu +;;; glimpse +;;; grep +;;; +;;; (2) To use this package, you first have to build an index. Please read +;;; the documentation for `mh-index-search' to get started. That +;;; documentation will direct you to the specific instructions for your +;;; particular indexer. +;;; +;;; (3) Right now only viewing messages and moving between messages works in +;;; the index buffer. With a little bit of work more stuff like +;;; replying or forwarding messages can be done. + +;;; Change Log: + +;; $Id: mh-index.el,v 1.51 2002/11/13 18:43:57 satyaki Exp $ + +;;; Code: + +(require 'cl) +(require 'mh-e) +(require 'mh-mime) + +;; Shush the byte-compiler +(defvar font-lock-defaults) + +(autoload 'gnus-local-map-property "gnus-util") +(autoload 'gnus-eval-format "gnus-spec") +(autoload 'widget-convert-button "wid-edit") +(autoload 'executable-find "executable") + +;;; User customizable +(defcustom mh-index-program nil + "Indexing program that MH-E shall use. +The possible choices are swish++, swish-e, namazu, glimpse and grep. By +default this variable is nil which means that the programs are tried in order +and the first one found is used." + :group 'mh + :type '(choice (const :tag "auto-detect" nil) + (const :tag "swish++" swish++) + (const :tag "swish-e" swish) + (const :tag "namazu" namazu) + (const :tag "glimpse" glimpse) + (const :tag "grep" grep))) + +;;; Hooks +(defcustom mh-index-show-hook nil + "Invoked after the message has been displayed." + :type 'hook + :group 'mh-hook) + +;; Support different indexing programs +(defvar mh-indexer-choices + '((swish++ + mh-swish++-binary mh-swish++-execute-search mh-swish++-next-result) + (swish + mh-swish-binary mh-swish-execute-search mh-swish-next-result) + (namazu + mh-namazu-binary mh-namazu-execute-search mh-namazu-next-result) + (glimpse + mh-glimpse-binary mh-glimpse-execute-search mh-glimpse-next-result) + (grep + mh-grep-binary mh-grep-execute-search mh-grep-next-result)) + "List of possible indexer choices.") +(defvar mh-indexer nil + "Chosen index program.") +(defvar mh-index-execute-search-function nil + "Function which executes the search program.") +(defvar mh-index-next-result-function nil + "Function to parse the next line of output.") + +;; Names for the default mh-index-buffers... +(defvar mh-index-buffer "*mh-index*") +(defvar mh-index-show-buffer "*mh-index-show*") + +;; For use with adaptive size setting... +(defvar mh-index-max-msg-index 0) + +;; Buffer locals to allow multiple concurrent search folders. +(defvar mh-index-other-buffer nil + "Keeps track of other buffer associated with current buffer. +The value is the show buffer or the folder-buffer depending on whether we are +in a folder buffer or show buffer respectively.") +(defvar mh-index-matches nil + "Map of folder to messages which match.") +(defvar mh-index-previous-window-configuration nil + "Keep track of previous window configuration that is restored on exit.") +(defvar mh-index-current-msg nil + "Message index of message being shown.") + +;; Make variables buffer local ... +(make-variable-buffer-local 'mh-index-other-buffer) +(make-variable-buffer-local 'mh-index-matches) +(make-variable-buffer-local 'mh-index-previous-window-configuration) +(make-variable-buffer-local 'mh-current-folder) +(make-variable-buffer-local 'mh-index-current-msg) + +;; ... and arrange for them to not get slaughtered by a call to text-mode +;; (text-mode is called by mh-show-mode and mh-folder-mode). +(put 'mh-index-other-buffer 'permanent-local t) +(put 'mh-index-matches 'permanent-local t) +(put 'mh-index-previous-window-configuration 'permanent-local t) +(put 'mh-index-current-msg 'permanent-local t) +(put 'mh-current-folder 'permanent-local t) +(put 'mh-cmd-note 'permanent-local t) + +;; Temporary buffer where search results are output. +(defvar mh-index-temp-buffer " *mh-index-temp*") + +;; Keymaps + +;; N.B. If this map were named mh-index-folder-mode-map, it would inherit the +;; keymap from mh-folder-mode. Since we want our own keymap, we tweak the name +;; to avoid this unwanted inheritance. +(defvar mh-index-folder-mode-keymap (make-sparse-keymap) + "Keymap for MH index folder.") +(suppress-keymap mh-index-folder-mode-keymap) +(gnus-define-keys mh-index-folder-mode-keymap + " " mh-index-page-msg + "," mh-index-header-display + "." mh-index-show + [mouse-2] mh-index-show + "?" mh-help + "\177" mh-index-previous-page + "\M-\t" mh-index-prev-button + [backtab] mh-index-prev-button + "\r" mh-index-show + "\t" mh-index-next-button + "i" mh-inc-folder + "m" mh-send ;alias + "n" mh-index-next + "p" mh-index-prev + "q" mh-index-quit + "s" mh-send) + +(gnus-define-keys (mh-index-folder-map "F" mh-index-folder-mode-keymap) + "?" mh-prefix-help + "f" mh-visit-folder ;alias + "i" mh-index-search-again + "o" mh-visit-folder ;alias + "v" mh-visit-folder) + +(defvar mh-index-button-map (make-sparse-keymap)) +(gnus-define-keys mh-index-button-map + "\r" mh-index-press-button) + + + +;;; Help Messages + +;;; If you add a new prefix, add appropriate text to the nil key. +;;; +;;; In general, messages are grouped logically. Taking the main commands for +;;; example, the first line is "ways to view messages," the second line is +;;; "things you can do with messages", and the third is "composing" messages. +;;; +;;; When adding a new prefix, ensure that the help message contains "what" the +;;; prefix is for. For example, if the word "folder" were not present in the +;;; `F' entry, it would not be clear what these commands operated upon. +(defvar mh-index-folder-mode-help-messages + '((nil "[i]nc, [.]show, [,]show all, [n]ext, [p]revious,\n" + "[s]end, [q]uit") + (?F "[v]isit folder; [i]ndexed search")) + "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.") + + + +(defun mh-index-search (folder search-regexp &optional new-buffer-flag) + "Perform an indexed search in an MH mail folder. + +FOLDER is searched with SEARCH-REGEXP and the results are presented in an MH-E +folder. If FOLDER is \"+\" then mail in all folders are searched. Optional +prefix argument NEW-BUFFER-FLAG decides whether the results are presented in a +new buffer. This allows multiple search results to coexist. + +Four indexing programs are supported; if none of these are present, then grep +is used. This function picks the first program that is available on your +system. If you would prefer to use a different program, set the customization +variable `mh-index-program' accordingly. + +The documentation for the following functions describes how to generate the +index for each program: + + - `mh-swish++-execute-search' + - `mh-swish-execute-search' + - `mh-namazu-execute-search' + - `mh-glimpse-execute-search'" + (interactive + (list (progn + (unless mh-find-path-run (mh-find-path)) + (mh-prompt-for-folder "Search" "+" nil "all")) + (progn + ;; Yes, we do want to call mh-index-choose every time in case the + ;; user has switched the indexer manually. + (unless (mh-index-choose) (error "No indexing program found")) + (read-string (format "%s regexp: " + (upcase-initials (symbol-name mh-indexer))))) + current-prefix-arg)) + (setq mh-index-max-msg-index 0) + (let ((config (current-window-configuration)) + (mh-index-buffer + (cond (new-buffer-flag + (buffer-name (generate-new-buffer mh-index-buffer))) + ((and (eq major-mode 'mh-index-folder-mode)) + (buffer-name (current-buffer))) + (t mh-index-buffer))) + (mh-index-show-buffer + (cond (new-buffer-flag + (buffer-name (generate-new-buffer mh-index-show-buffer))) + ((eq major-mode 'mh-index-folder-mode) + mh-index-other-buffer) + (t mh-index-show-buffer)))) + (when (buffer-live-p (get-buffer mh-index-show-buffer)) + (kill-buffer (get-buffer mh-index-show-buffer))) + (get-buffer-create mh-index-buffer) + (get-buffer-create mh-index-show-buffer) + (save-excursion + (set-buffer mh-index-buffer) + (setq mh-index-other-buffer mh-index-show-buffer)) + (save-excursion + (set-buffer mh-index-show-buffer) + (setq mh-index-other-buffer mh-index-buffer)) + (set-buffer mh-index-buffer) + (setq buffer-read-only nil) + (erase-buffer) + (let* ((folder-path (format "%s%s" mh-user-path (substring folder 1))) + (count 0) + (folder-count 0) + cur-folder last-folder cur-index last-index + parse-results button-start button-end) + (setq mh-index-matches (make-hash-table :test #'equal)) + + ;; Run search program... + (message "%s searching... " (upcase-initials (symbol-name mh-indexer))) + (funcall mh-index-execute-search-function folder-path search-regexp) + + ;; Parse output and generate folder view + (message "Processing %s output... " mh-indexer) + (goto-char (point-min)) + (while (setq parse-results (funcall mh-index-next-result-function)) + (unless (eq parse-results 'error) + (setq cur-folder (car parse-results) + cur-index (cadr parse-results)) + (setq mh-index-max-msg-index (max mh-index-max-msg-index cur-index)) + (cond ((and (equal cur-folder last-folder) + (= cur-index last-index)) + nil) + ((equal cur-folder last-folder) + (save-excursion + (set-buffer mh-index-buffer) + (push cur-index (gethash cur-folder mh-index-matches)))) + (t + (save-excursion + (set-buffer mh-index-buffer) + (unless (gethash cur-folder mh-index-matches) + (setq button-start (point)) + (gnus-eval-format "%T\n" '((?T cur-folder ?s)) + `(,@(gnus-local-map-property + mh-index-button-map) + mh-callback mh-index-callback + mh-data ,cur-folder)) + (setq button-end (point)) + (widget-convert-button + 'link button-start button-end + :button-keymap mh-index-button-map + :action 'mh-index-callback) + (insert "\n")) + (push cur-index (gethash cur-folder mh-index-matches))))) + (setq last-folder cur-folder) + (setq last-index cur-index))) + + ;; Get rid of extra line at end of the buffer if there were any hits. + (set-buffer mh-index-buffer) + (goto-char (point-max)) + (when (and (= (forward-line -1) 0) (bolp) (eolp)) + (delete-char 1)) + + ;; Set mh-cmd-note to a large enough value... + (when mh-adaptive-cmd-note-flag + (mh-set-cmd-note (mh-index-find-max-width mh-index-max-msg-index))) + + ;; Generate scan lines for the hits. + (message "Generating scan lines... ") + (goto-char (point-min)) + (while (not (eobp)) + (let ((folder (get-text-property (point) 'mh-data))) + (when folder + (incf folder-count) + (forward-line) + (incf count (mh-index-insert-scan folder)))) + (forward-line)) + + ;; Go to the first hit (if any). + (goto-char (point-min)) + (forward-line) + + ;; Remember old window configuration + (setq mh-index-previous-window-configuration config) + + ;; Setup folder buffer mode + (when mh-decode-mime-flag + (add-hook 'kill-buffer-hook 'mh-mime-cleanup)) + (mh-index-folder-mode) + (setq mh-show-buffer mh-index-show-buffer) + (setq buffer-read-only t) + (set-buffer-modified-p nil) + (mh-index-configure-one-window) + (setq mh-current-folder nil mh-index-current-msg nil) + (message "%s found %s matches in %s folders" + (upcase-initials (symbol-name mh-indexer)) + count folder-count)))) + +(defun mh-index-find-max-width (max-index) + "Given MAX-INDEX find the number of digits necessary to print it." + (let ((result 1) + (max-int 9)) + (while (< max-int max-index) + (incf result) + (setq max-int (+ (* 10 max-int) 9))) + result)) + +(defun mh-index-search-again () + "Call `mh-index-search' from index search buffer." + (interactive) + (cond ((eq major-mode 'mh-index-show-mode) + (set-buffer mh-index-other-buffer)) + ((not (eq major-mode 'mh-index-folder-mode)) + (error "Should be called from one of the index buffers"))) + (let ((old-buffer (current-buffer)) + (window-config mh-index-previous-window-configuration)) + (unwind-protect (call-interactively 'mh-index-search) + (when (eq old-buffer (current-buffer)) + (setq mh-index-previous-window-configuration window-config))))) + +(defun mh-index-insert-scan (folder) + "Insert scan lines for hits in FOLDER that the indexing program found. +The only twist is to replace the subject/body field with the match (if +possible)." + (save-excursion + (apply #'mh-exec-cmd-output + mh-scan-prog nil (mh-scan-format) + "-noclear" "-noheader" "-width" (window-width) + folder (mh-coalesce-msg-list (gethash folder mh-index-matches)))) + (save-excursion + (let ((window-width (window-width)) + (count 0)) + (while (not (or (get-text-property (point) 'mh-data) (eobp))) + (beginning-of-line) + (unless (and (eolp) (bolp)) + (incf count) + (forward-char mh-cmd-note) + (delete-char 1) + (insert " ")) + (forward-line 1)) + count))) + +(defun mh-index-callback () + "Callback function for buttons in the index buffer." + (let* ((folder (save-excursion + (buffer-substring-no-properties + (progn (beginning-of-line) (point)) + (progn (end-of-line) (point))))) + (data (get-text-property (point) 'mh-data)) + (msg-list (gethash data mh-index-matches))) + (when msg-list + (mh-visit-folder folder msg-list)))) + +(defmacro mh-defun-index (func args &rest body) + "Macro to generate a function callable both from index and show buffer. +FUNC is the function name, ARGS the argument list and BODY the function +body." + (let ((cur (gensym)) + interactive-spec doc-string) + (when (stringp (car body)) + (setq doc-string (car body)) + (setq body (cdr body))) + (when (and (listp (car body)) (eq (caar body) 'interactive)) + (setq interactive-spec (car body)) + (setq body (cdr body))) + `(defun ,func ,args + ,@(if doc-string (list doc-string) ()) + ,interactive-spec + (let* ((mh-index-buffer (if (eq major-mode 'mh-index-folder-mode) + (buffer-name (current-buffer)) + mh-index-other-buffer)) + (mh-index-show-buffer (if (eq major-mode 'mh-index-show-mode) + (buffer-name (current-buffer)) + mh-index-other-buffer)) + (,cur (cond ((eq (get-buffer mh-index-buffer) + (current-buffer)) + mh-index-buffer) + ((eq (get-buffer mh-index-show-buffer) + (current-buffer)) + mh-index-show-buffer) + (t (error "Not called from mh-index buffer"))))) + (flet ((mh-msg-folder (folder) mh-index-buffer) + (mh-msg-filename (msg-num folder) + (format "%s%s/%s" mh-user-path (subseq folder 1) msg-num))) + (cond ((eq ,cur mh-index-buffer) + (mh-index-goto-nearest-msg) + (when (and mh-current-folder mh-index-current-msg) + (mh-index-notate mh-current-folder + mh-index-current-msg " " mh-cmd-note)) + (setq mh-current-folder (mh-index-parse-folder)) + (setq mh-index-current-msg (mh-index-parse-msg-number))) + ((eq ,cur mh-index-show-buffer) + (set-buffer mh-index-buffer) + (mh-index-goto-msg mh-current-folder + mh-index-current-msg) + (mh-index-notate nil nil " " mh-cmd-note)) + (t (error "This can't happen!"))) + (unwind-protect + (progn ,@body) + (save-excursion + (set-buffer mh-index-buffer) + (mh-index-goto-msg mh-current-folder mh-index-current-msg) + (mh-recenter nil)) + (mh-index-configure-windows) + (pop-to-buffer ,cur))))))) + +(defun mh-index-advance (steps) + "Advance STEPS messages in the folder buffer. +If there are less than STEPS messages left then an error message is printed." + (let* ((backward-flag (< steps 0)) + (steps (if backward-flag (- steps) steps)) + point) + (block body + (save-excursion + (while (> steps 0) + (unless (= (forward-line (if backward-flag -1 1)) 0) + (return-from body)) + (cond ((and (eolp) (bolp) (not backward-flag)) + (unless (= (forward-line 2) 0) (return-from body))) + ((and (get-text-property (point) 'mh-data) backward-flag) + (unless (= (forward-line -2) 0) (return-from body))) + ((or (and (eolp) (bolp)) + (get-text-property (point) 'mh-data)) + (error "Mh-index-buffer is inconsistent"))) + (decf steps)) + (setq point (point)))) + (cond (point (goto-char point) t) + (t nil)))) + +;; Details about message at point. These functions assume that we are on a +;; line which contains a message scan line and not on a blank line or a line +;; with a folder name. +(defun mh-index-parse-msg-number () + "Parse message number of message at point." + (save-excursion + (beginning-of-line) + (let* ((b (point)) + (e (progn (forward-char mh-cmd-note) (point))) + (data (ignore-errors + (read-from-string (buffer-substring-no-properties b e))))) + (unless (and (consp data) (integerp (car data))) + (error "Didn't find message number")) + (car data)))) + +(defun mh-index-parse-folder () + "Parse folder of message at point." + (save-excursion + (while (not (get-text-property (point) 'mh-data)) + (unless (eql (forward-line -1) 0) + (error "Reached beginning of buffer without seeing a folder"))) + (buffer-substring-no-properties (progn (beginning-of-line) (point)) + (progn (end-of-line) (point))))) + +(defun mh-index-goto-nearest-msg () + "If point is not at a message go to the closest line with a message on it." + (beginning-of-line) + (cond ((and (eolp) (bolp)) (forward-line -1)) + ((get-text-property (point) 'mh-data) (forward-line 1)))) + +;; Window configuration for mh-index... There should be similar functions +;; in MH-E but I couldn't find them. I got the idea of using next-window, +;; previous-window and minibuffer-window from MH-E code. +(defun mh-index-configure-windows () + "Configure windows." + (cond ((and (buffer-live-p (get-buffer mh-index-show-buffer)) + (buffer-live-p (get-buffer mh-index-buffer)) + (eq (save-excursion (set-buffer mh-index-show-buffer) major-mode) + 'mh-index-show-mode)) + (mh-index-configure-two-windows)) + ((buffer-live-p (get-buffer mh-index-buffer)) + (mh-index-configure-one-window)))) + +(defun mh-count-windows () + "Count the number of windows in the current frame. +The minibuffer window is excluded from the count." + (let* ((start-window (next-window nil t)) + (current-window (next-window start-window t)) + (count 0)) + (while (not (eq current-window start-window)) + (incf count) + (setq current-window (next-window current-window t))) + count)) + +(defun mh-index-configure-two-windows () + "Force a split view like that of MH-E." + (save-excursion + (unless (and (get-buffer mh-index-show-buffer) + (get-buffer mh-index-buffer)) + (error "We don't have both index buffers")) + (let ((window-count (mh-count-windows))) + (unless (and (= window-count 2) + (eq (window-buffer (next-window (minibuffer-window))) + (get-buffer mh-index-buffer)) + (eq (window-buffer (previous-window (minibuffer-window))) + (get-buffer mh-index-show-buffer))) + (unless (= window-count 2) + (delete-other-windows) + (split-window-vertically)) + (set-window-buffer (next-window (minibuffer-window)) + mh-index-buffer) + (set-window-buffer (previous-window (minibuffer-window)) + mh-index-show-buffer)) + (unless (and (get-buffer-window mh-index-buffer) + (= (window-height (get-buffer-window mh-index-buffer)) + mh-summary-height)) + (pop-to-buffer mh-index-buffer) + (shrink-window (- (window-height) mh-summary-height)))) + (set-window-point (previous-window (minibuffer-window)) + (progn (set-buffer mh-index-show-buffer) (point))) + (set-window-point (next-window (minibuffer-window)) + (progn (set-buffer mh-index-buffer) (point))))) + +(defun mh-index-configure-one-window () + "Single window view." + (save-excursion + (unless (buffer-live-p (get-buffer mh-index-buffer)) + (error "Should have mh-index-buffer")) + (switch-to-buffer mh-index-buffer) + (delete-other-windows) + (set-window-point (next-window (minibuffer-window)) + (progn (set-buffer mh-index-buffer) (point))))) + +;; This is slightly more involved than normal MH-E since we may have multiple +;; folders in the same buffer. +(defun mh-index-goto-msg (folder msg) + "Move the cursor to the message specified by FOLDER and MSG." + (block body + (unless (buffer-live-p (get-buffer mh-index-buffer)) + (error "No index buffer to go to")) + (set-buffer mh-index-buffer) + (goto-char (point-min)) + (while (re-search-forward (format "^%s$" folder) nil t) + (forward-line) + (while (not (eolp)) + (when (= (mh-index-parse-msg-number) msg) + (return-from body)) + (forward-line))) + (error "Folder: %s, msg: %s doesn't exist" folder msg))) + +;; Can't use mh-notate directly since we could have more than one folder in +;; the same buffer +(defun mh-index-notate (folder msg notation offset) + "Add notation to scan line. +FOLDER is the message folder and MSG the message index. These arguments +specify the message to be notated. NOTATION is the character to be used to +notate and OFFSET is the number of chars from start of the line where +notation is to be placed." + (save-excursion + (set-buffer mh-index-buffer) + (let ((buffer-read-only nil) + (modified-p (buffer-modified-p)) + (found t)) + (setq found nil) + (when (and (stringp folder) (numberp msg)) + (block nil + (goto-char (point-min)) + (re-search-forward (format "^%s$" folder)) + (forward-line) + (while (not (eolp)) + (when (= (mh-index-parse-msg-number) msg) + (setq found t) + (return)) + (forward-line)))) + (when found + (beginning-of-line) + (forward-char offset) + (delete-char 1) + (insert notation) + (unless modified-p (set-buffer-modified-p nil)))))) + + + +;;; User functions + +(mh-defun-index mh-index-show (display-headers-flag) + "Display message at point. +If there are no messages at point then display the closest message. +The value of `mh-index-show-hook' is a list of functions to be called, +with no arguments, after the message has been displayed. +If DISPLAY-HEADERS-FLAG is non-nil then the raw message is shown." + (interactive (list nil)) + (when (or (and (bolp) (eolp)) (get-text-property (point) 'mh-data)) + (error "No message at point")) + (setq mh-current-folder (mh-index-parse-folder)) + (setq mh-index-current-msg (mh-index-parse-msg-number)) + ;; Do new notation + (when (and mh-current-folder mh-index-current-msg) + (mh-index-notate mh-current-folder mh-index-current-msg + mh-note-cur mh-cmd-note)) + (let ((mh-decode-mime-flag (and (not display-headers-flag) mh-decode-mime-flag)) + (mh-clean-message-header-flag + (and (not display-headers-flag) mh-clean-message-header-flag)) + (mhl-formfile (if display-headers-flag nil mhl-formfile)) + (msg mh-index-current-msg) + (folder mh-current-folder)) + (when (not (eq display-headers-flag mh-showing-with-headers)) + (mh-invalidate-show-buffer)) + (mh-in-show-buffer (mh-index-show-buffer) + (mh-display-msg msg folder)) + ;; Search for match in shown message + (select-window (get-buffer-window mh-index-show-buffer)) + (set-buffer mh-index-show-buffer) + (mh-index-show-mode)) + (run-hooks 'mh-index-show-hook)) + +(defun mh-index-header-display () + "Show the message with full headers." + (interactive) + (mh-index-show t) + (setq mh-showing-with-headers t)) + +(mh-defun-index mh-index-next (steps) + "Display next message. +Prefix argument STEPS specifies the number of messages to skip ahead." + (interactive "p") + (mh-index-goto-nearest-msg) + (if (mh-index-advance steps) + (mh-index-show nil) + (mh-index-show nil) + (message "Not enough messages"))) + +(mh-defun-index mh-index-prev (steps) + "Display previous message. +Prefix argument STEPS specifies the number of messages to skip backward." + (interactive "p") + (mh-index-goto-nearest-msg) + (if (mh-index-advance (- steps)) + (mh-index-show nil) + (mh-index-show nil) + (message "Not enough messages"))) + +(defun mh-index-page-msg (arg) + "Scroll the displayed message upward ARG lines." + (interactive "P") + (save-excursion + (let* ((show-buffer (cond ((eq major-mode 'mh-index-folder-mode) + mh-index-other-buffer) + ((eq major-mode 'mh-index-show-mode) + (buffer-name (current-buffer))) + (t (error "Don't use mh-index-page-msg")))) + (window (get-buffer-window show-buffer)) + (current-window (selected-window))) + (when (window-live-p window) + (select-window window) + (unwind-protect (scroll-up arg) + (select-window current-window)))))) + +(defun mh-index-previous-page (arg) + "Scroll the displayed message downward ARG lines." + (interactive "P") + (save-excursion + (let* ((show-buffer (cond ((eq major-mode 'mh-index-folder-mode) + mh-index-other-buffer) + ((eq major-mode 'mh-index-show-mode) + (buffer-name (current-buffer))) + (t (error "Don't use mh-index-previous-page")))) + (window (get-buffer-window show-buffer)) + (current-window (selected-window))) + (when (window-live-p window) + (select-window window) + (unwind-protect (scroll-down arg) + (select-window current-window)))))) + +(defun mh-index-press-button () + "Press index button." + (interactive) + (let ((function (get-text-property (point) 'mh-callback))) + (when function + (funcall function)))) + +(defun mh-index-quit () + "Quit the index folder. +Restore the previous window configuration, if one exists. +The value of `mh-before-quit-hook' is a list of functions to be called, with +no arguments, immediately upon entry to this function. +The value of `mh-quit-hook' is a list of functions to be called, with no +arguments, upon exit of this function." + (interactive) + (cond ((eq major-mode 'mh-index-show-mode) + (set-buffer mh-index-other-buffer)) + ((not (eq major-mode 'mh-index-folder-mode)) + (error "The function mh-index-quit shouldn't be called"))) + (run-hooks 'mh-before-quit-hook) + (let ((mh-index-buffer (buffer-name (current-buffer))) + (mh-index-show-buffer mh-index-other-buffer) + (window-config mh-index-previous-window-configuration)) + (when (buffer-live-p (get-buffer mh-index-buffer)) + (bury-buffer (get-buffer mh-index-buffer))) + (when (buffer-live-p (get-buffer mh-index-show-buffer)) + (bury-buffer (get-buffer mh-index-show-buffer))) + (when window-config + (set-window-configuration window-config))) + (run-hooks 'mh-quit-hook)) + +;; Can't quite use mh-next-button... This buffer has no concept of +;; folder-buffer or show-buffer. Maybe refactor mh-next-button? +(defun mh-index-next-button (&optional backward-flag) + "Go to the next button. +Advance point to the next button in the show buffer. If the end of buffer is +reached then the search wraps over to the start of the buffer. With optional +argument BACKWARD-FLAG the point will move to the previous button." + (interactive current-prefix-arg) + (mh-goto-next-button backward-flag)) + +(defun mh-index-prev-button () + "Go to the next button. +Move point to the previous button in the show buffer. If the beginning of +the buffer is reached then the search wraps over to the end." + (interactive) + (mh-index-next-button t)) + + + +;; Glimpse interface + +(defvar mh-glimpse-binary (executable-find "glimpse")) +(defvar mh-glimpse-directory ".glimpse") + +(defun mh-glimpse-execute-search (folder-path search-regexp) + "Execute glimpse and read the results. + +In the examples below, replace /home/user/Mail with the path to your MH +directory. + +First create the directory /home/user/Mail/.glimpse. Then create the file +/home/user/Mail/.glimpse/.glimpse_exclude with the following contents: + + */.* + */#* + */,* + */*~ + ^/home/user/Mail/.glimpse + +If there are any directories you would like to ignore, append lines like the +following to .glimpse_exclude: + + ^/home/user/Mail/scripts + +Use the following command line to generate the glimpse index. Run this +daily from cron: + + glimpseindex -H /home/user/Mail/.glimpse /home/user/Mail + +FOLDER-PATH is the directory in which SEARCH-REGEXP is used to search." + (set-buffer (get-buffer-create mh-index-temp-buffer)) + (erase-buffer) + (call-process mh-glimpse-binary nil '(t nil) nil + ;(format "-%s" fuzz) + "-i" "-y" + "-H" (format "%s%s" mh-user-path mh-glimpse-directory) + "-F" (format "^%s" folder-path) + search-regexp) + (goto-char (point-min))) + +(defun mh-glimpse-next-result () + "Read the next result. +Parse it and return the message folder, message index and the match. If no +other matches left then return nil. If the current record is invalid return +'error." + (prog1 + (block nil + (when (eobp) + (return nil)) + (let ((eol-pos (line-end-position)) + (bol-pos (line-beginning-position)) + folder-start msg-end) + (goto-char bol-pos) + (unless (search-forward mh-user-path eol-pos t) + (return 'error)) + (setq folder-start (point)) + (unless (search-forward ": " eol-pos t) + (return 'error)) + (let ((match (buffer-substring-no-properties (point) eol-pos))) + (forward-char -2) + (setq msg-end (point)) + (unless (search-backward "/" folder-start t) + (return 'error)) + (list (format "+%s" (buffer-substring-no-properties + folder-start (point))) + (let ((val (ignore-errors (read-from-string + (buffer-substring-no-properties + (1+ (point)) msg-end))))) + (if (and (consp val) (integerp (car val))) + (car val) + (return 'error))) + match)))) + (forward-line))) + + + +;; Grep interface + +(defvar mh-grep-binary (executable-find "grep")) + +(defun mh-grep-execute-search (folder-path search-regexp) + "Execute grep and read the results. +FOLDER-PATH is the directory in which SEARCH-REGEXP is used to search." + (set-buffer (get-buffer-create mh-index-temp-buffer)) + (erase-buffer) + (call-process mh-grep-binary nil '(t nil) nil + "-i" "-r" search-regexp folder-path) + (goto-char (point-min))) + +(defun mh-grep-next-result () + "Read the next result. +Parse it and return the message folder, message index and the match. If no +other matches left then return nil. If the current record is invalid return +'error." + (prog1 + (block nil + (when (eobp) + (return nil)) + (let ((eol-pos (line-end-position)) + (bol-pos (line-beginning-position)) + folder-start msg-end) + (goto-char bol-pos) + (unless (search-forward mh-user-path eol-pos t) + (return 'error)) + (setq folder-start (point)) + (unless (search-forward ":" eol-pos t) + (return 'error)) + (let ((match (buffer-substring-no-properties (point) eol-pos))) + (forward-char -1) + (setq msg-end (point)) + (unless (search-backward "/" folder-start t) + (return 'error)) + (list (format "+%s" (buffer-substring-no-properties + folder-start (point))) + (let ((val (ignore-errors (read-from-string + (buffer-substring-no-properties + (1+ (point)) msg-end))))) + (if (and (consp val) (integerp (car val))) + (car val) + (return 'error))) + match)))) + (forward-line))) + + + +;; Swish interface + +(defvar mh-swish-binary (executable-find "swish-e")) +(defvar mh-swish-directory ".swish") +(defvar mh-swish-folder nil) + +(defun mh-swish-execute-search (folder-path search-regexp) + "Execute swish-e and read the results. + +In the examples below, replace /home/user/Mail with the path to your MH +directory. + +First create the directory /home/user/Mail/.swish. Then create the file +/home/user/Mail/.swish/config with the following contents: + + IndexDir /home/user/Mail + IndexFile /home/user/Mail/.swish/index + IndexName \"Mail Index\" + IndexDescription \"Mail Index\" + IndexPointer \"http://nowhere\" + IndexAdmin \"nobody\" + #MetaNames automatic + IndexReport 3 + FollowSymLinks no + UseStemming no + IgnoreTotalWordCountWhenRanking yes + WordCharacters abcdefghijklmnopqrstuvwxyz0123456789- + BeginCharacters abcdefghijklmnopqrstuvwxyz + EndCharacters abcdefghijklmnopqrstuvwxyz0123456789 + IgnoreLimit 50 1000 + IndexComments 0 + FileRules pathname contains /home/user/Mail/.swish + FileRules filename is index + FileRules filename is \..* + FileRules filename is #.* + FileRules filename is ,.* + FileRules filename is .*~ + +If there are any directories you would like to ignore, append lines like the +following to config: + + FileRules pathname contains /home/user/Mail/scripts + +Use the following command line to generate the swish index. Run this +daily from cron: + + swish-e -c /home/user/Mail/.swish/config + +FOLDER-PATH is the directory in which SEARCH-REGEXP is used to search." + (set-buffer (get-buffer-create mh-index-temp-buffer)) + (erase-buffer) + (unless mh-swish-binary + (error "Set mh-swish-binary appropriately")) + (call-process mh-swish-binary nil '(t nil) nil + "-w" search-regexp + "-f" (format "%s%s/index" mh-user-path mh-swish-directory)) + (goto-char (point-min)) + (setq mh-swish-folder + (let ((last-char (substring folder-path (1- (length folder-path))))) + (if (equal last-char "/") + folder-path + (format "%s/" folder-path))))) + +(defun mh-swish-next-result () + "Get the next result from swish output." + (prog1 + (block nil + (when (or (eobp) (equal (char-after (point)) ?.)) + (return nil)) + (when (equal (char-after (point)) ?#) + (return 'error)) + (let* ((start (search-forward " " (line-end-position) t)) + (end (search-forward " " (line-end-position) t))) + (unless (and start end) + (return 'error)) + (setq end (1- end)) + (unless (file-exists-p (buffer-substring-no-properties start end)) + (return 'error)) + (unless (search-backward "/" start t) + (return 'error)) + (list (let* ((s (buffer-substring-no-properties start (1+ (point))))) + (unless (string-match mh-swish-folder s) + (return 'error)) + (if (string-match mh-user-path s) + (format "+%s" + (substring s (match-end 0) (1- (length s)))) + (return 'error))) + (let* ((s (buffer-substring-no-properties (1+ (point)) end)) + (val (ignore-errors (read-from-string s)))) + (if (and (consp val) (numberp (car val))) + (car val) + (return 'error))) + nil))) + (forward-line))) + + + +;; Swish++ interface + +(defvar mh-swish++-binary (or (executable-find "search++") + (executable-find "search"))) +(defvar mh-swish++-directory ".swish++") + +(defun mh-swish++-execute-search (folder-path search-regexp) + "Execute swish++ and read the results. + +In the examples below, replace /home/user/Mail with the path to your MH +directory. + +First create the directory /home/user/Mail/.swish++. Then create the file +/home/user/Mail/.swish++/swish++.conf with the following contents: + + IncludeMeta Bcc Cc Comments Content-Description From Keywords + IncludeMeta Newsgroups Resent-To Subject To + IncludeFile Mail [0-9]* + IndexFile /home/user/Mail/.swish++/swish++.index + +Use the following command line to generate the swish index. Run this +daily from cron: + + index -c /home/user/Mail/.swish++/swish++.conf /home/user/Mail + +On some systems (Debian GNU/Linux, for example), use index++ instead of index. + +FOLDER-PATH is the directory in which SEARCH-REGEXP is used to search." + (set-buffer (get-buffer-create mh-index-temp-buffer)) + (erase-buffer) + (unless mh-swish++-binary + (error "Set mh-swish++-binary appropriately")) + (call-process mh-swish++-binary nil '(t nil) nil + "-m" "10000" + (format "-i%s%s/swish++.index" + mh-user-path mh-swish++-directory) + search-regexp) + (goto-char (point-min)) + (setq mh-swish-folder + (let ((last-char (substring folder-path (1- (length folder-path))))) + (if (equal last-char "/") + folder-path + (format "%s/" folder-path))))) + +(defalias 'mh-swish++-next-result 'mh-swish-next-result) + + + +;; Namazu interface + +(defvar mh-namazu-binary (executable-find "namazu")) +(defvar mh-namazu-directory ".namazu") +(defvar mh-namazu-folder nil) + +(defun mh-namazu-execute-search (folder-path search-regexp) + "Execute namazu and read the results. + +In the examples below, replace /home/user/Mail with the path to your MH +directory. + +First create the directory /home/user/Mail/.namazu. Then create the file +/home/user/Mail/.namazu/mknmzrc with the following contents: + + package conf; # Don't remove this line! + $ADDRESS = 'user@localhost'; + $ALLOW_FILE = \"[0-9]*\"; + +Use the following command line to generate the namazu index. Run this +daily from cron: + + mknmz -f /home/user/Mail/.namazu/mknmzrc -O /home/user/Mail/.namazu \\ + /home/user/Mail + +FOLDER-PATH is the directory in which SEARCH-REGEXP is used to search." + (let ((namazu-index-directory + (format "%s%s" mh-user-path mh-namazu-directory))) + (unless (file-exists-p namazu-index-directory) + (error "Namazu directory %s not present" namazu-index-directory)) + (unless (executable-find mh-namazu-binary) + (error "Set mh-namazu-binary appropriately")) + (set-buffer (get-buffer-create mh-index-temp-buffer)) + (erase-buffer) + (call-process mh-namazu-binary nil '(t nil) nil + "-alR" search-regexp namazu-index-directory) + (goto-char (point-min)) + (setq mh-namazu-folder + (let ((last (substring folder-path (1- (length folder-path))))) + (if (equal last "/") + folder-path + (format "%s/" folder-path)))))) + +(defun mh-namazu-next-result () + "Get the next result from namazu output." + (prog1 + (block nil + (when (eobp) (return nil)) + (let ((file-name (buffer-substring-no-properties + (point) (line-end-position)))) + (unless (equal (string-match mh-namazu-folder file-name) 0) + (return 'error)) + (unless (file-exists-p file-name) + (return 'error)) + (string-match mh-user-path file-name) + (let* ((folder/msg (substring file-name (match-end 0))) + (mark (search "/" folder/msg :from-end t))) + (unless mark (return 'error)) + (list (format "+%s" (substring folder/msg 0 mark)) + (let ((n (ignore-errors (read-from-string + (substring folder/msg (1+ mark)))))) + (if (and (consp n) (numberp (car n))) + (car n) + (return 'error))) + nil)))) + (forward-line))) + + + +(defun mh-index-choose () + "Choose an indexing function. +The side-effects of this function are that the variables `mh-indexer', +`mh-index-execute-search-function', and `mh-index-next-result-function' are +set according to the first indexer in `mh-indexer-choices' present on the +system." + (block nil + ;; The following favors the user's preference; otherwise, the last + ;; automatically chosen indexer is used for efficiency rather than going + ;; through the list. + (let ((program-alist (cond (mh-index-program + (list + (assoc mh-index-program mh-indexer-choices))) + (mh-indexer + (list (assoc mh-indexer mh-indexer-choices))) + (t mh-indexer-choices)))) + (while program-alist + (let* ((current (pop program-alist)) + (executable (symbol-value (cadr current)))) + (when executable + (setq mh-indexer (car current)) + (setq mh-index-execute-search-function (caddr current)) + (setq mh-index-next-result-function (cadddr current)) + (return mh-indexer)))) + nil))) + + + +;;; Menu extracted from mh-menubar.el V1.1 (31 July 2001) +;;; Menus for folder mode: folder, message (in that order) +;;; folder-mode "Message" menu +(easy-menu-define + mh-index-folder-message-menu mh-index-folder-mode-keymap + "Menu for MH-E folder-message." + '("Message" + ["Show Message" mh-index-show (mh-get-msg-num nil)] + ["Show Message with Header" mh-index-header-display (mh-get-msg-num nil)] + ["Next Message" mh-index-next t] + ["Previous Message" mh-index-prev t] + "--" + ["Compose a New Message" mh-send t])) + +;;; folder-mode "Folder" menu +(easy-menu-define + mh-index-folder-folder-menu mh-index-folder-mode-keymap + "Menu for MH-E folder." + '("Folder" + ["Incorporate New Mail" mh-inc-folder t] + "--" + ["Visit a Folder..." mh-visit-folder t] + ["Indexed Search..." mh-index-search-again t] + "--" + ["Quit Indexed Search" mh-index-quit t])) + + + +;;; Support for emacs21 toolbar using gnus/message.el icons (and code). +(eval-when-compile (defvar tool-bar-map)) +(defvar mh-index-folder-tool-bar-map nil) +(when (fboundp 'tool-bar-add-item) + (setq mh-index-folder-tool-bar-map + (let ((tool-bar-map (make-sparse-keymap))) + (tool-bar-add-item "mail" 'mh-inc-folder + 'mh-indexfoldertoolbar-inc-folder + :help "Incorporate new mail in Inbox") + (tool-bar-add-item "left_arrow" 'mh-index-prev + 'mh-indexfoldertoolbar-prev :help "Previous message") + (tool-bar-add-item "page-down" 'mh-index-page-msg + 'mh-indexfoldertoolbar-page + :help "Page this message") + (tool-bar-add-item "right_arrow" 'mh-index-next + 'mh-indexfoldertoolbar-next :help "Next message") + + (tool-bar-add-item "mail_compose" 'mh-send 'mh-indexfoldertoolbar-compose + :help "Compose new message") + + (tool-bar-add-item "search" + (lambda (&optional arg) + (interactive "P") + (call-interactively mh-tool-bar-search-function)) + 'mh-indexfoldertoolbar-search :help "Search") + (tool-bar-add-item "fld_open" 'mh-visit-folder + 'mh-indexfoldertoolbar-visit + :help "Visit other folder") + + (tool-bar-add-item "preferences" (lambda () + (interactive) + (customize-group "mh")) + 'mh-indexfoldertoolbar-customize + :help "MH-E preferences") + (tool-bar-add-item "help" (lambda () + (interactive) + (Info-goto-node "(mh-e)Top")) + 'mh-indexfoldertoolbar-help :help "Help") + tool-bar-map))) + +;; Modes for mh-index +(define-derived-mode mh-index-folder-mode mh-folder-mode "MH-Index-Folder" + "Major MH-E mode for displaying the results of searching.\\<mh-index-folder-mode-keymap> + +You can display the message the cursor is pointing to and step through the +messages. + +You can also jump to the folders narrowed to the search results by pressing +RET on the folder name. Many operations, such as replying to a message, +require that you do this first. + +\\{mh-index-folder-mode-keymap}" + (make-local-variable 'font-lock-defaults) + (setq font-lock-defaults '(mh-index-font-lock-keywords t)) + (use-local-map mh-index-folder-mode-keymap) + (make-local-variable 'mh-help-messages) + (easy-menu-add mh-index-folder-message-menu) + (easy-menu-add mh-index-folder-folder-menu) + (if (and (boundp 'tool-bar-mode) tool-bar-mode) + (set (make-local-variable 'tool-bar-map) mh-index-folder-tool-bar-map)) + (setq mh-help-messages mh-index-folder-mode-help-messages)) + +(define-derived-mode mh-index-show-mode mh-show-mode "MH-Index-Show" + "Major mode for showing messages in MH-E index.\\<mh-index-folder-mode-keymap> +\\{mh-index-folder-mode-keymap}" + (use-local-map mh-index-folder-mode-keymap) + (setq mh-help-messages mh-index-folder-mode-help-messages)) + +;; Font lock support for mh-index-folder. This is the same as mh-folder +;; except that the folder line needs to be recognized and highlighted. +(defvar mh-index-folder-face 'mh-index-folder-face + "Face for highlighting folders in MH-Index buffers.") +(defface mh-index-folder-face + '((((class color) (background light)) + (:foreground "dark green")) + (((class color) (background dark)) + (:foreground "indian red")) + (t + (:bold t))) + "Face for highlighting folders in MH-Index buffers." + :group 'mh) + +(eval-after-load "font-lock" + '(progn + (defvar mh-index-folder-face 'mh-index-folder-face + "Face for highlighting folders in MH-Index buffers.") + + (defvar mh-index-font-lock-keywords + (list + ;; Folder name + (list "^\\+.*" '(0 mh-index-folder-face)) + ;; Marked for deletion + (list (concat mh-scan-deleted-msg-regexp ".*") + '(0 mh-folder-deleted-face)) + ;; Marked for refile + (list (concat mh-scan-refiled-msg-regexp ".*") + '(0 mh-folder-refiled-face)) + ;;after subj + (list mh-scan-body-regexp '(1 mh-folder-body-face nil t)) + '(mh-folder-font-lock-subject + (1 mh-folder-followup-face append t) + (2 mh-folder-subject-face append t)) + ;;current msg + (list mh-scan-cur-msg-number-regexp + '(1 mh-folder-cur-msg-number-face)) + (list mh-scan-good-msg-regexp + '(1 mh-folder-msg-number-face)) ;; Msg number + (list mh-scan-date-regexp '(1 mh-folder-date-face)) ;; Date + (list mh-scan-rcpt-regexp + '(1 mh-folder-to-face) ;; To: + '(2 mh-folder-address-face)) ;; address + ;; scan font-lock name + (list mh-scan-format-regexp + '(1 mh-folder-date-face) + '(3 mh-folder-scan-format-face)) + ;; Current message line + (list mh-scan-cur-msg-regexp + '(1 mh-folder-cur-msg-face prepend t))) + "Regexp keywords used to fontify the MH-Index-Folder buffer."))) + +(provide 'mh-index) + +;;; Local Variables: +;;; sentence-end-double-space: nil +;;; End: + +;;; mh-index ends here
--- a/lisp/mail/mh-mime.el Fri Nov 29 18:02:52 2002 +0000 +++ b/lisp/mail/mh-mime.el Fri Nov 29 18:15:21 2002 +0000 @@ -1,4 +1,4 @@ -;;; mh-mime.el --- mh-e support for composing MIME messages +;;; mh-mime.el --- MH-E support for composing MIME messages ;; Copyright (C) 1993, 1995, 2001, 2002 Free Software Foundation, Inc. @@ -26,18 +26,93 @@ ;;; Commentary: -;; Internal support for mh-e package. +;; Internal support for MH-E package. ;; Support for generating an mhn composition file. ;; MIME is supported only by MH 6.8 or later. ;;; Change Log: -;; $Id: mh-mime.el,v 1.26 2002/04/07 19:20:56 wohler Exp $ +;; $Id: mh-mime.el,v 1.90 2002/11/22 20:00:48 satyaki Exp $ ;;; Code: -(provide 'mh-mime) +(require 'cl) (require 'mh-comp) +(require 'mh-utils) +(load "mm-decode" t t) ; Non-fatal dependency +(load "mm-uu" t t) ; Non-fatal dependency +(load "mailcap" t t) ; Non-fatal dependency +(load "smiley" t t) ; Non-fatal dependency +(require 'gnus-util) + +(autoload 'gnus-article-goto-header "gnus-art") +(autoload 'article-emphasize "gnus-art") +(autoload 'gnus-get-buffer-create "gnus") +(autoload 'gnus-eval-format "gnus-spec") +(autoload 'widget-convert-button "wid-edit") +(autoload 'message-options-set-recipient "message") +(autoload 'mml-secure-message-sign-pgpmime "mml-sec") +(autoload 'mml-secure-message-encrypt-pgpmime "mml-sec") +(autoload 'mml-minibuffer-read-file "mml") +(autoload 'mml-minibuffer-read-description "mml") +(autoload 'mml-insert-empty-tag "mml") +(autoload 'mml-to-mime "mml") +(autoload 'mml-attach-file "mml") + +;;; Hooks +(defcustom mh-edit-mhn-hook nil + "Invoked on the formatted letter by \\<mh-letter-mode-map>\\[mh-edit-mhn]." + :type 'hook + :group 'mh-hook) + +;; Keeps assorted MIME data +(defstruct (mh-buffer-data (:conc-name mh-mime-) + (:constructor mh-make-buffer-data)) + ;; Structure to keep track of MIME handles on a per buffer basis. + (handles ()) ; List of MIME handles + (handles-cache (make-hash-table)) ; Cache to avoid multiple decodes of + ; nested messages + (parts-count 0) ; The button number is generated from + ; this number + (part-index-hash (make-hash-table))) ; Avoid incrementing the part number + ; for nested messages + +;;; This has to be a macro, since we do: (setf (mh-buffer-data) ...) +(defmacro mh-buffer-data () + "Convenience macro to get the MIME data structures of the current buffer." + `(gethash (current-buffer) mh-globals-hash)) + +(defun mh-compose-insertion (&optional inline) + "Add a directive to insert a MIME part from a file, using mhn or gnus. +If the variable `mh-compose-insertion' is set to 'mhn, then that will be used. +If it is set to 'gnus, then that will be used instead. +Optional argument INLINE means make it an inline attachment." + (interactive "P") + (if (equal mh-compose-insertion 'gnus) + (if inline + (mh-mml-attach-file "inline") + (mh-mml-attach-file)) + (call-interactively 'mh-mhn-compose-insertion))) + +(defun mh-compose-forward (&optional description folder message) + "Add a MIME directive to forward a message, using mhn or gnus. +If the variable `mh-compose-insertion' is set to 'mhn, then that will be used. +If it is set to 'gnus, then that will be used instead. +Optional argument DESCRIPTION is a description of the attachment. +Optional argument FOLDER is the folder from which the forwarded message should +come. +Optional argument MESSAGE is the message to forward. +If any of the optional arguments are absent, they are prompted for." + (interactive (list + (read-string "Forw Content-description: ") + (mh-prompt-for-folder "Message from" mh-sent-from-folder nil) + (read-string (format "Messages%s: " + (if mh-sent-from-msg + (format " [%d]" mh-sent-from-msg) + ""))))) + (if (equal mh-compose-insertion 'gnus) + (mh-mml-forward-message description folder message) + (mh-mhn-compose-forw description folder message))) ;; To do: ;; paragraph code should not fill # lines if MIME enabled. @@ -54,8 +129,15 @@ prefix argument. Normally default arguments to mhn are specified in the MH profile.") -(defvar mh-edit-mhn-hook nil - "Invoked on the formatted letter by \\<mh-letter-mode-map>\\[mh-edit-mhn].") +(defvar mh-media-type-regexp + (concat (regexp-opt '("text" "image" "audio" "video" "application" + "multipart" "message") t) + "/[-.+a-zA-Z0-9]+") + "Regexp matching valid media types used in MIME attachment compositions.") + +;; Just defvar the variable to avoid compiler warning... This doesn't bind +;; the variable, so things should work exactly as before. +(defvar mh-have-file-command) (defun mh-have-file-command () "Return t if 'file' command is on the system. @@ -70,6 +152,30 @@ (expand-file-name "inc" mh-progs)))))) mh-have-file-command) +(defvar mh-file-mime-type-substitutions + '(("application/msword" "\.xls" "application/ms-excel") + ("application/msword" "\.ppt" "application/ms-powerpoint")) + "Substitutions to make for Content-Type returned from file command. +The first element is the Content-Type returned by the file command. +The second element is a regexp matching the file name, usually the extension. +The third element is the Content-Type to replace with.") + +(defun mh-file-mime-type-substitute (content-type filename) + "Return possibly changed CONTENT-TYPE on the FILENAME. +Substitutions are made from the `mh-file-mime-type-substitutions' variable." + (let ((subst mh-file-mime-type-substitutions) + (type) (match) (answer content-type) + (case-fold-search t)) + (while subst + (setq type (car (car subst)) + match (elt (car subst) 1)) + (if (and (string-equal content-type type) + (string-match match filename)) + (setq answer (elt (car subst) 2) + subst nil) + (setq subst (cdr subst)))) + answer)) + (defun mh-file-mime-type (filename) "Return MIME type of FILENAME from file command. Returns nil if file command not on system." @@ -89,14 +195,9 @@ (goto-char (point-min)) (if (not (re-search-forward mh-media-type-regexp nil t)) nil - (match-string 0))) + (mh-file-mime-type-substitute (match-string 0) filename))) (kill-buffer tmp-buffer))))))) -(defvar mh-mhn-compose-insert-p nil - "Buffer-local variable to know whether MIME insertion was done. -Triggers an automatic call to `mh-edit-mhn' in `mh-send-letter'.") -(make-variable-buffer-local 'mh-mhn-compose-insert-p) - ;;; This is needed for Emacs20 which doesn't have mailcap-mime-types. (defvar mh-mime-content-types '(("application/mac-binhex40") ("application/msword") @@ -122,27 +223,22 @@ "Legal MIME content types. See documentation for \\[mh-edit-mhn].") -(defvar mh-media-type-regexp - (concat (regexp-opt '("text" "image" "audio" "video" "application" - "multipart" "message") t) - "/[-.+a-zA-Z0-9]+") - "Regexp matching valid media types used in MIME attachment compositions.") - (defun mh-mhn-compose-insertion (filename type description attributes) "Add a directive to insert a MIME message part from a file. -This is the typical way to insert non-text parts in a message. Arguments are -FILENAME, which tells where to find the file, TYPE, the MIME content type, -DESCRIPTION, a line of text for the Content-Description field. ATTRIBUTES is a -comma separated list of name=value pairs that is appended to the Content-Type -field of the attachment. +This is the typical way to insert non-text parts in a message. + +Arguments are FILENAME, which tells where to find the file, TYPE, the MIME +content type, DESCRIPTION, a line of text for the Content-Description field. +ATTRIBUTES is a comma separated list of name=value pairs that is appended to +the Content-Type field of the attachment. + See also \\[mh-edit-mhn]." (interactive (let ((filename (read-file-name "Insert contents of: "))) (list filename (or (mh-file-mime-type filename) (completing-read "Content-Type: " - (if (and (require 'mailcap nil t) - (fboundp 'mailcap-mime-types)) + (if (fboundp 'mailcap-mime-types) (mapcar 'list (mailcap-mime-types)) mh-mime-content-types))) (read-string "Content-Description: ") @@ -154,7 +250,12 @@ (defun mh-mhn-compose-type (filename type &optional description attributes comment) - (setq mh-mhn-compose-insert-p t) + "Insert a mhn directive to insert a file. + +The file specified by FILENAME is encoded as TYPE. An optional DESCRIPTION is +used as the Content-Description field, optional set of ATTRIBUTES and an +optional COMMENT can also be included." + (setq mh-mhn-compose-insert-flag t) (beginning-of-line) (insert "#" type) (and attributes @@ -170,17 +271,19 @@ (defun mh-mhn-compose-anon-ftp (host filename type description) "Add a directive for a MIME anonymous ftp external body part. -This directive tells MH to include a reference to a -message/external-body part retrievable by anonymous FTP. Arguments -are HOST and FILENAME, which tell where to find the file, TYPE, the -MIME content type, and DESCRIPTION, a line of text for the -Content-description header. See also \\[mh-edit-mhn]." +This directive tells MH to include a reference to a message/external-body part +retrievable by anonymous FTP. + +Arguments are HOST and FILENAME, which tell where to find the file, TYPE, the +MIME content type, and DESCRIPTION, a line of text for the Content-description +header. + +See also \\[mh-edit-mhn]." (interactive (list (read-string "Remote host: ") (read-string "Remote filename: ") (completing-read "External Content-Type: " - (if (and (require 'mailcap nil t) - (fboundp 'mailcap-mime-types)) + (if (fboundp 'mailcap-mime-types) (mapcar 'list (mailcap-mime-types)) mh-mime-content-types)) (read-string "External Content-Description: "))) @@ -189,10 +292,12 @@ (defun mh-mhn-compose-external-compressed-tar (host filename description) "Add a directive to include a MIME reference to a compressed tar file. -The file should be available via anonymous ftp. This directive -tells MH to include a reference to a message/external-body part. +The file should be available via anonymous ftp. This directive tells MH to +include a reference to a message/external-body part. + Arguments are HOST and FILENAME, which tell where to find the file, and DESCRIPTION, a line of text for the Content-description header. + See also \\[mh-edit-mhn]." (interactive (list (read-string "Remote host: ") @@ -208,7 +313,17 @@ (defun mh-mhn-compose-external-type (access-type host filename type &optional description attributes extra-params comment) - (setq mh-mhn-compose-insert-p t) + "Add a directive to include a MIME reference to a remote file. +The file should be available via anonymous ftp. This directive tells MH to +include a reference to a message/external-body part. + +Arguments are ACCESS-TYPE, HOST and FILENAME, which tell where to find the +file and TYPE which is the MIME Content-Type. Optional arguments include +DESCRIPTION, a line of text for the Content-description header, ATTRIBUTES, +EXTRA-PARAMS, and COMMENT. + +See also \\[mh-edit-mhn]." + (setq mh-mhn-compose-insert-flag t) (beginning-of-line) (insert "#@" type) (and attributes @@ -230,8 +345,10 @@ (defun mh-mhn-compose-forw (&optional description folder messages) "Add a forw directive to this message, to forward a message with MIME. This directive tells MH to include the named messages in this one. + Arguments are DESCRIPTION, a line of text for the Content-description header, and FOLDER and MESSAGES, which name the message(s) to be forwarded. + See also \\[mh-edit-mhn]." (interactive (list (read-string "Forw Content-description: ") @@ -240,7 +357,7 @@ (if mh-sent-from-msg (format " [%d]" mh-sent-from-msg) ""))))) - (setq mh-mhn-compose-insert-p t) + (setq mh-mhn-compose-insert-flag t) (beginning-of-line) (insert "#forw [") (and description @@ -280,23 +397,25 @@ message). If these helper functions are used, `mh-edit-mhn' is run automatically when the draft is sent. +The value of `mh-edit-mhn-hook' is a list of functions to be called, with no +arguments, after performing the conversion. + The mhn program is part of MH version 6.8 or later." (interactive "*P") (save-buffer) (message "mhn editing...") (cond - (mh-nmh-p + (mh-nmh-flag (mh-exec-cmd-error nil "mhbuild" (if extra-args mh-mhn-args) buffer-file-name)) (t (mh-exec-cmd-error (format "mhdraft=%s" buffer-file-name) "mhn" (if extra-args mh-mhn-args) buffer-file-name))) - (setq mh-mhn-compose-insert-p nil) + (setq mh-mhn-compose-insert-flag nil) (revert-buffer t t) (message "mhn editing...done") (run-hooks 'mh-edit-mhn-hook)) - (defun mh-revert-mhn-edit (noconfirm) "Undo the effect of \\[mh-edit-mhn] by reverting to the backup file. Optional non-nil argument NOCONFIRM means don't ask for confirmation." @@ -324,4 +443,857 @@ (insert-file-contents backup-file)) (after-find-file nil))) + + +;;; MIME composition functions + +(defun mh-mml-to-mime () + "Compose MIME message from mml directives." + (interactive) + (when mh-gnus-pgp-support-flag ;; This is only needed for PGP + (message-options-set-recipient)) + (mml-to-mime) + (setq mh-mml-compose-insert-flag nil)) + +(defun mh-mml-forward-message (description folder message) + "Forward a message as attachment. +The function will prompt the user for a DESCRIPTION, a FOLDER and MESSAGE +number." + (let ((msg (if (equal message "") + mh-sent-from-msg + (car (read-from-string message))))) + (cond ((integerp msg) + (if (string= "" description) + ;; Rationale: mml-attach-file constructs a malformed composition + ;; if the description string is empty. This fixes SF #625168. + (mml-attach-file (format "%s%s/%d" + mh-user-path (substring folder 1) msg) + "message/rfc822") + (mml-attach-file (format "%s%s/%d" + mh-user-path (substring folder 1) msg) + "message/rfc822" + description)) + (setq mh-mml-compose-insert-flag t)) + (t (error "The message number, %s is not a integer!" msg))))) + +(defun mh-mml-attach-file (&optional disposition) + "Attach a file to the outgoing MIME message. +The file is not inserted or encoded until you send the message with +`\\[mh-send-letter]'. +Message disposition is \"inline\" or \"attachment\" and is prompted for if +DISPOSITION is nil. + +This is basically `mml-attach-file' from gnus, modified such that a prefix +argument yields an `inline' disposition and Content-Type is determined +automatically." + (let* ((file (mml-minibuffer-read-file "Attach file: ")) + (type (or (mh-file-mime-type file) + (completing-read "Content-Type: " + (if (fboundp 'mailcap-mime-types) + (mapcar 'list (mailcap-mime-types)) + mh-mime-content-types)))) + (description (mml-minibuffer-read-description)) + (dispos (or disposition + (completing-read "Disposition: [attachment] " + '(("attachment")("inline")) + nil t nil nil + "attachment")))) + (mml-insert-empty-tag 'part 'type type 'filename file + 'disposition dispos 'description description) + (setq mh-mml-compose-insert-flag t))) + +(defun mh-mml-secure-message-sign-pgpmime () + "Add directive to encrypt/sign the entire message." + (interactive) + (if (not mh-gnus-pgp-support-flag) + (error "Sorry. Your version of gnus does not support PGP/GPG") + (mml-secure-message-sign-pgpmime) + (setq mh-mml-compose-insert-flag t))) + +(defun mh-mml-secure-message-encrypt-pgpmime (&optional dontsign) + "Add directive to encrypt and sign the entire message. +If called with a prefix argument DONTSIGN, only encrypt (do NOT sign)." + (interactive "P") + (if (not mh-gnus-pgp-support-flag) + (error "Sorry. Your version of gnus does not support PGP/GPG") + (mml-secure-message-encrypt-pgpmime dontsign) + (setq mh-mml-compose-insert-flag t))) + + + +;;; MIME decoding + +(defcustom mh-graphical-smileys-flag t + "*Non-nil means graphical smileys are displayed. +Non-nil means that small graphics will be used in the show buffer instead of +patterns like :-), ;-) etc. The setting only has effect if +`mh-decode-mime-flag' is non-nil." + :type 'boolean + :group 'mh-buffer) + +(defcustom mh-graphical-emphasis-flag t + "*Non-nil means graphical emphasis is displayed. +Non-nil means that _underline_ will be underlined, *bold* will appear in bold, +/italic/ will appear in italic etc. See `gnus-emphasis-alist' for the whole +list. The setting only has effect if `mh-decode-mime-flag' is non-nil." + :type 'boolean + :group 'mh-buffer) + +;; Small image definition +(defcustom mh-max-inline-image-width nil + "*Maximum inline image width if Content-Disposition is not present. +If nil, image will be displayed if its width is smaller than the width of the +window." + :type '(choice (const nil) integer) + :group 'mh-buffer) + +(defcustom mh-max-inline-image-height nil + "*Maximum inline image height if Content-Disposition is not present. +If nil, image will be displayed if its height is smaller than the height of +the window." + :type '(choice (const nil) integer) + :group 'mh-buffer) + +(defcustom mh-display-buttons-for-inline-parts-flag nil + "*Non-nil means display buttons for all inline MIME parts. +If non-nil, buttons are displayed for all MIME parts. Inline parts start off +in displayed state but they can be hidden by clicking the button. If nil no +buttons are shown for inline parts." + :type 'boolean + :group 'mh-buffer) + +(defcustom mh-mime-save-parts-default-directory t + "Default directory to use for `mh-mime-save-parts'. +If nil, prompt and set for next time the command is used during same session. +If t, prompt always" + :type '(choice (const :tag "Prompt the first time" nil) + (const :tag "Prompt always" t) + directory) + :group 'mh) + +(defmacro mh-defun-compat (function arg-list &rest body) + "This is a macro to define functions which are not defined. +It is used for Gnus utility functions which were added recently. If FUNCTION +is not defined then it is defined to have argument list, ARG-LIST and body, +BODY." + (let ((defined-p (fboundp function))) + (unless defined-p + `(defun ,function ,arg-list ,@body)))) + +;; Copy of original function from gnus-util.el +(mh-defun-compat gnus-local-map-property (map) + "Return a list suitable for a text property list specifying keymap MAP." + (cond (mh-xemacs-flag (list 'keymap map)) + ((>= emacs-major-version 21) (list 'keymap map)) + (t (list 'local-map map)))) + +;; Copy of original function from mm-decode.el +(mh-defun-compat mm-merge-handles (handles1 handles2) + (append (if (listp (car handles1)) handles1 (list handles1)) + (if (listp (car handles2)) handles2 (list handles2)))) + +;; Copy of function from mm-decode.el +(mh-defun-compat mm-set-handle-multipart-parameter (handle parameter value) + ;; HANDLE could be a CTL. + (if handle + (put-text-property 0 (length (car handle)) parameter value + (car handle)))) + +;; Copy of original macro is in mm-decode.el +(mh-defun-compat mm-handle-multipart-ctl-parameter (handle parameter) + (get-text-property 0 parameter (car handle))) + +;; Copy of original function in mm-decode.el +(mh-defun-compat mm-readable-p (handle) + "Say whether the content of HANDLE is readable." + (and (< (with-current-buffer (mm-handle-buffer handle) + (buffer-size)) 10000) + (mm-with-unibyte-buffer + (mm-insert-part handle) + (and (eq (mm-body-7-or-8) '7bit) + (not (mm-long-lines-p 76)))))) + +;; Copy of original function in mm-bodies.el +(mh-defun-compat mm-long-lines-p (length) + "Say whether any of the lines in the buffer is longer than LINES." + (save-excursion + (goto-char (point-min)) + (end-of-line) + (while (and (not (eobp)) + (not (> (current-column) length))) + (forward-line 1) + (end-of-line)) + (and (> (current-column) length) + (current-column)))) + +(mh-defun-compat mm-keep-viewer-alive-p (handle) + ;; Released Gnus doesn't keep handles associated with externally displayed + ;; MIME parts. So this will always return nil. + nil) + +(mh-defun-compat mm-destroy-parts (list) + "Older emacs don't have this function." + nil) + +;;; This is mm-save-part from gnus 5.10 since that function in emacs21.2 is +;;; buggy (the args to read-file-name are incorrect). When all supported +;;; versions of Emacs come with at least Gnus 5.10, we can delete this +;;; function and rename calls to mh-mm-save-part to mm-save-part. +(defun mh-mm-save-part (handle) + "Write HANDLE to a file." + (let ((name (mail-content-type-get (mm-handle-type handle) 'name)) + (filename (mail-content-type-get + (mm-handle-disposition handle) 'filename)) + file) + (when filename + (setq filename (file-name-nondirectory filename))) + (setq file (read-file-name "Save MIME part to: " + (or mm-default-directory + default-directory) + nil nil (or filename name ""))) + (setq mm-default-directory (file-name-directory file)) + (and (or (not (file-exists-p file)) + (yes-or-no-p (format "File %s already exists; overwrite? " + file))) + (mm-save-part-to-file handle file)))) + + + +;;; MIME cleanup + +(defun mh-mime-cleanup () + "Free the decoded MIME parts." + (let ((mime-data (gethash (current-buffer) mh-globals-hash))) + ;; This is for Emacs, what about XEmacs? + (cond ((fboundp 'remove-images) + (remove-images (point-min) (point-max)))) + (when mime-data + (mm-destroy-parts (mh-mime-handles mime-data)) + (remhash (current-buffer) mh-globals-hash)))) + +(defun mh-destroy-postponed-handles () + "Free MIME data for externally displayed mime parts." + (let ((mime-data (mh-buffer-data))) + (when mime-data + (mm-destroy-parts (mh-mime-handles mime-data))) + (remhash (current-buffer) mh-globals-hash))) + +(defun mh-handle-set-external-undisplayer (folder handle function) + "Replacement for `mm-handle-set-external-undisplayer'. +This is only called in recent versions of Gnus. The MIME handles are stored +in data structures corresponding to MH-E folder buffer FOLDER instead of in +Gnus (as in the original). The MIME part, HANDLE is associated with the +undisplayer FUNCTION." + (if (mm-keep-viewer-alive-p handle) + (let ((new-handle (copy-sequence handle))) + (mm-handle-set-undisplayer new-handle function) + (mm-handle-set-undisplayer handle nil) + (save-excursion + (set-buffer folder) + (push new-handle (mh-mime-handles (mh-buffer-data))))) + (mm-handle-set-undisplayer handle function))) + + + +;;; MIME transformations + +(defun mh-add-missing-mime-version-header () + "Some mail programs don't put a MIME-Version header. +I have seen this only in spam, so maybe we shouldn't fix this ;-)" + (save-excursion + (goto-char (point-min)) + (when (and (message-fetch-field "content-type") + (not (message-fetch-field "mime-version"))) + (when (search-forward "\n\n" nil t) + (forward-line -1) + (insert "MIME-Version: 1.0\n"))))) + +(defun mh-display-smileys () + "Function to display smileys." + (when (and mh-graphical-smileys-flag (fboundp 'smiley-region)) + (smiley-region (point-min) (point-max)))) + +(defun mh-display-emphasis () + "Function to display graphical emphasis." + (when mh-graphical-emphasis-flag + (flet ((article-goto-body ())) ; shadow this function to do nothing + (save-excursion + (goto-char (point-min)) + (article-emphasize))))) + +;; Copied from gnus-art.el (should be checked for other cool things that can +;; be added to the buttons) +(defvar mh-mime-button-commands + '((mh-press-button "\r" "Toggle Display"))) +(defvar mh-mime-button-map + (let ((map (make-sparse-keymap))) + (unless (>= (string-to-number emacs-version) 21) + ;; XEmacs doesn't care. + (set-keymap-parent map mh-show-mode-map)) + (define-key map [mouse-2] 'mh-push-button) + (dolist (c mh-mime-button-commands) + (define-key map (cadr c) (car c))) + map)) +(defvar mh-mime-button-line-format-alist + '((?T long-type ?s) + (?d description ?s) + (?p index ?s) + (?e dots ?s))) +(defvar mh-mime-button-line-format "%{%([%p. %d%T]%)%}%e\n") +(defvar mh-mime-security-button-pressed nil) +(defvar mh-mime-security-button-line-format "%{%([[%t:%i]%D]%)%}\n") +(defvar mh-mime-security-button-end-line-format "%{%([[End of %t]%D]%)%}\n") +(defvar mh-mime-security-button-line-format-alist + '((?t type ?s) + (?i info ?s) + (?d details ?s) + (?D pressed-details ?s))) +(defvar mh-mime-security-button-map + (let ((map (make-sparse-keymap))) + (unless (>= (string-to-number emacs-version) 21) + (set-keymap-parent map mh-show-mode-map)) + (define-key map "\r" 'mh-press-button) + (define-key map [mouse-2] 'mh-push-button) + map)) + +(defvar mh-mime-save-parts-directory nil + "Default to use for `mh-mime-save-parts-default-directory'. +Set from last use.") + +(defun mh-mime-save-parts (arg) + "Store the MIME parts of the current message. +If ARG, prompt for directory, else use that specified by the variable +`mh-mime-save-parts-default-directory'. These directories may be superseded by +mh_profile directives, since this function calls on mhstore or mhn to do the +actual storing." + (interactive "P") + (let ((msg (if (eq major-mode 'mh-show-mode) + (mh-show-buffer-message-number) + (mh-get-msg-num t))) + (folder (if (eq major-mode 'mh-show-mode) + mh-show-folder-buffer + mh-current-folder)) + (command (if mh-nmh-flag "mhstore" "mhn")) + (directory + (cond + ((and (or arg + (equal nil mh-mime-save-parts-default-directory) + (equal t mh-mime-save-parts-default-directory)) + (not mh-mime-save-parts-directory)) + (read-file-name "Store in what directory? " nil nil t nil)) + ((and (or arg + (equal t mh-mime-save-parts-default-directory)) + mh-mime-save-parts-directory) + (read-file-name (format + "Store in what directory? [%s] " + mh-mime-save-parts-directory) + "" mh-mime-save-parts-directory t "")) + ((stringp mh-mime-save-parts-default-directory) + mh-mime-save-parts-default-directory) + (t + mh-mime-save-parts-directory)))) + (if (and (equal directory "") mh-mime-save-parts-directory) + (setq directory mh-mime-save-parts-directory)) + (if (not (file-directory-p directory)) + (message "No directory specified.") + (if (equal nil mh-mime-save-parts-default-directory) + (setq mh-mime-save-parts-directory directory)) + (save-excursion + (set-buffer (get-buffer-create " *mh-store*")) + (cd directory) + (setq mh-mime-save-parts-directory directory) + (erase-buffer) + (apply 'call-process + (expand-file-name command mh-progs) nil t nil + (mh-list-to-string (list folder msg "-auto"))) + (if (> (buffer-size) 0) + (save-window-excursion + (switch-to-buffer-other-window " *mh-store*") + (sit-for 3))))))) + +;; Avoid errors if gnus-sum isn't loaded yet... +(defvar gnus-newsgroup-charset nil) +(defvar gnus-newsgroup-name nil) + +(defun mh-mime-display (&optional pre-dissected-handles) + "Display (and possibly decode) MIME handles. +Optional argument, PRE-DISSECTED-HANDLES is a list of MIME handles. If +present they are displayed otherwise the buffer is parsed and then +displayed." + (let ((handles ()) + (folder mh-show-folder-buffer)) + (flet ((mm-handle-set-external-undisplayer (handle function) + (mh-handle-set-external-undisplayer folder handle function))) + ;; If needed dissect the current buffer + (if pre-dissected-handles + (setq handles pre-dissected-handles) + (setq handles (or (mm-dissect-buffer nil) (mm-uu-dissect))) + (setf (mh-mime-handles (mh-buffer-data)) + (mm-merge-handles handles (mh-mime-handles (mh-buffer-data))))) + + (when (and handles (or (not (stringp (car handles))) (cdr handles))) + ;; Goto start of message body + (goto-char (point-min)) + (or (search-forward "\n\n" nil t) (goto-char (point-max))) + + ;; Delete the body + (delete-region (point) (point-max)) + + ;; Display the MIME handles + (mh-mime-display-part handles))))) + +(defun mh-mime-display-part (handle) + "Decides the viewer to call based on the type of HANDLE." + (cond ((null handle) nil) + ((not (stringp (car handle))) + (mh-mime-display-single handle)) + ((equal (car handle) "multipart/alternative") + (mh-mime-display-alternative (cdr handle))) + ((and mh-gnus-pgp-support-flag + (or (equal (car handle) "multipart/signed") + (equal (car handle) "multipart/encrypted"))) + (mh-mime-display-security handle)) + (t (mh-mime-display-mixed (cdr handle))))) + +(defun mh-mime-display-alternative (handles) + "Choose among the alternatives, HANDLES the part that will be displayed. +If no part is preferred then all the parts are displayed." + (let ((preferred (mm-preferred-alternative handles))) + (cond ((and preferred (stringp (car preferred))) + (mh-mime-display-part preferred)) + (preferred + (save-restriction + (narrow-to-region (point) (if (eobp) (point) (1+ (point)))) + (or (mm-display-part preferred) (mm-display-part preferred)) + (goto-char (point-max)))) + (t (mh-mime-display-mixed handles))))) + +(defun mh-mime-display-mixed (handles) + "Display the list of MIME parts, HANDLES recursively." + (mapcar #'mh-mime-display-part handles)) + +(defun mh-mime-part-index (handle) + "Generate the button number for MIME part, HANDLE. +Notice that a hash table is used to display the same number when buttons need +to be displayed multiple times (for instance when nested messages are +opened)." + (or (gethash handle (mh-mime-part-index-hash (mh-buffer-data))) + (setf (gethash handle (mh-mime-part-index-hash (mh-buffer-data))) + (incf (mh-mime-parts-count (mh-buffer-data)))))) + +;;; Avoid compiler warnings for XEmacs functions... +(eval-when (compile) + (loop for function in '(glyph-width window-pixel-width + glyph-height window-pixel-height) + do (or (fboundp function) (defalias function 'ignore)))) + +(defun mh-small-image-p (handle) + "Decide whether HANDLE is a \"small\" image that can be displayed inline. +This is only useful if a Content-Disposition header is not present." + (let ((media-test (caddr (assoc (car (mm-handle-type handle)) + mh-mm-inline-media-tests))) + (mm-inline-large-images t)) + (and media-test + (equal (mm-handle-media-supertype handle) "image") + (funcall media-test handle) ; Since mm-inline-large-images is T, + ; this only tells us if the image is + ; something that emacs can display + (let* ((image (mm-get-image handle))) + (cond ((fboundp 'glyph-width) + ;; XEmacs -- totally untested, copied from gnus + (and (< (glyph-width image) + (or mh-max-inline-image-width + (window-pixel-width))) + (< (glyph-height image) + (or mh-max-inline-image-height + (window-pixel-height))))) + ((fboundp 'image-size) + ;; Emacs21 -- copied from gnus + (let ((size (image-size image))) + (and (< (cdr size) + (or mh-max-inline-image-height + (1- (window-height)))) + (< (car size) + (or mh-max-inline-image-width (window-width)))))) + (t + ;; Can't show image inline + nil)))))) + +(defun mh-mime-display-single (handle) + "Display a leaf node, HANDLE in the MIME tree." + (let* ((type (mm-handle-media-type handle)) + (small-image-flag (mh-small-image-p handle)) + (attachmentp (equal (car (mm-handle-disposition handle)) + "attachment")) + (inlinep (and (equal (car (mm-handle-disposition handle)) "inline") + (mm-inlinable-p handle) + (mm-inlined-p handle))) + (displayp (or inlinep ; display if inline + (and (not attachmentp) ; if it is not an attachment + (or small-image-flag ; display if small image + ; or if user wants inline. + (and (not (equal + (mm-handle-media-supertype handle) + "image")) + (mm-inlinable-p handle) + (mm-inlined-p handle))))))) + (save-restriction + (narrow-to-region (point) (if (eobp) (point) (1+ (point)))) + (cond ((and mh-gnus-pgp-support-flag + (equal type "application/pgp-signature")) + nil) ; skip signatures as they are already handled... + ((not displayp) + (insert "\n") + (mh-insert-mime-button handle (mh-mime-part-index handle) nil)) + ((and displayp (not mh-display-buttons-for-inline-parts-flag)) + (or (mm-display-part handle) (mm-display-part handle))) + ((and displayp mh-display-buttons-for-inline-parts-flag) + (insert "\n") + (mh-insert-mime-button handle (mh-mime-part-index handle) nil) + (forward-line -1) + (mh-mm-display-part handle))) + (goto-char (point-max))))) + +(defun mh-insert-mime-button (handle index displayed) + "Insert MIME button for HANDLE. +INDEX is the part number that will be DISPLAYED. It is also used by commands +like \"K v\" which operate on individual MIME parts." + ;; The button could be displayed by a previous decode. In that case + ;; undisplay it if we need a hidden button. + (when (and (mm-handle-displayed-p handle) (not displayed)) + (mm-display-part handle)) + (let ((name (or (mail-content-type-get (mm-handle-type handle) 'name) + (mail-content-type-get (mm-handle-disposition handle) + 'filename) + (mail-content-type-get (mm-handle-type handle) 'url) + "")) + (type (mm-handle-media-type handle)) + (description (mail-decode-encoded-word-string + (or (mm-handle-description handle) ""))) + (dots (if (or displayed (mm-handle-displayed-p handle)) " " "...")) + long-type begin end) + (if (string-match ".*/" name) (setq name (substring name (match-end 0)))) + (setq long-type (concat type (and (not (equal name "")) + (concat "; " name)))) + (unless (equal description "") + (setq long-type (concat " --- " long-type))) + (unless (bolp) (insert "\n")) + (setq begin (point)) + (gnus-eval-format + mh-mime-button-line-format mh-mime-button-line-format-alist + `(,@(gnus-local-map-property mh-mime-button-map) + mh-callback mh-mm-display-part + mh-part ,index + mh-data ,handle)) + (setq end (point)) + (widget-convert-button + 'link begin end + :mime-handle handle + :action 'mh-widget-press-button + :button-keymap mh-mime-button-map + :help-echo + "Mouse-2 click or press RET (in show buffer) to toggle display"))) + +;; There is a bug in Gnus inline image display due to which an extra line +;; gets inserted every time it is viewed. To work around that problem we are +;; using an extra property 'mh-region to remember the region that is added +;; when the button is clicked. The region is then deleted to make sure that +;; no extra lines get inserted. +(defun mh-mm-display-part (handle) + "Toggle display of button for MIME part, HANDLE." + (beginning-of-line) + (let ((id (get-text-property (point) 'mh-part)) + (point (point)) + (window (selected-window)) + (mail-parse-charset 'nil) + (mail-parse-ignored-charsets nil) + region buffer-read-only) + (save-excursion + (unwind-protect + (let ((win (get-buffer-window (current-buffer) t))) + (when win + (select-window win)) + (goto-char point) + + (if (mm-handle-displayed-p handle) + ;; This will remove the part. + (progn + ;; Delete the button and displayed part (if any) + (let ((region (get-text-property point 'mh-region))) + (when region + (when (fboundp 'remove-images) + (remove-images (car region) (cdr region)))) + (mm-display-part handle) + (when region + (delete-region (car region) (cdr region)))) + ;; Delete button (if it still remains). This happens for + ;; externally displayed parts where the previous step does + ;; nothing. + (unless (eolp) + (delete-region (point) (progn (forward-line) (point))))) + (save-restriction + (delete-region (point) (progn (forward-line 1) (point))) + (narrow-to-region (point) (point)) + ;; Maybe we need another unwind-protect here. + (when (equal (mm-handle-media-supertype handle) "image") + (insert "\n")) + (when (and (not (eq (ignore-errors (mm-display-part handle)) + 'inline)) + (equal (mm-handle-media-supertype handle) + "image")) + (goto-char (point-min)) + (delete-char 1)) + (when (equal (mm-handle-media-supertype handle) "text") + (when (eq mh-highlight-citation-p 'gnus) + (mh-gnus-article-highlight-citation)) + (mh-display-smileys) + (mh-display-emphasis)) + (setq region (cons (progn (goto-char (point-min)) + (point-marker)) + (progn (goto-char (point-max)) + (point-marker))))))) + (when (window-live-p window) + (select-window window)) + (goto-char point) + (beginning-of-line) + (mh-insert-mime-button handle id (mm-handle-displayed-p handle)) + (goto-char point) + (when region + (add-text-properties (line-beginning-position) (line-end-position) + `(mh-region ,region))))))) + +(defun mh-press-button () + "Press MIME button. +If the MIME part is visible then it is removed. Otherwise the part is +displayed." + (interactive) + (let ((mm-inline-media-tests mh-mm-inline-media-tests) + (data (get-text-property (point) 'mh-data)) + (function (get-text-property (point) 'mh-callback)) + (buffer-read-only nil) + (folder mh-show-folder-buffer)) + (flet ((mm-handle-set-external-undisplayer (handle function) + (mh-handle-set-external-undisplayer folder handle function))) + (when (and function (eolp)) + (backward-char)) + (unwind-protect (and function (funcall function data)) + (set-buffer-modified-p nil))))) + +(defun mh-push-button (event) + "Click MIME button for EVENT. +If the MIME part is visible then it is removed. Otherwise the part is +displayed. This function is called when the mouse is used to click the MIME +button." + (interactive "e") + (set-buffer (window-buffer (posn-window (event-start event)))) + (select-window (posn-window (event-start event))) + (let* ((pos (posn-point (event-start event))) + (folder mh-show-folder-buffer) + (mm-inline-media-tests mh-mm-inline-media-tests) + (data (get-text-property pos 'mh-data)) + (function (get-text-property pos 'mh-callback)) + (buffer-read-only nil)) + (flet ((mm-handle-set-external-undisplayer (handle function) + (mh-handle-set-external-undisplayer folder handle function))) + (goto-char pos) + (unwind-protect (and function (funcall function data)) + (set-buffer-modified-p nil))))) + +(defun mh-mime-save-part () + "Save MIME part at point." + (interactive) + (let ((data (get-text-property (point) 'mh-data))) + (when data + (let ((mm-default-directory mh-mime-save-parts-directory)) + (mh-mm-save-part data) + (setq mh-mime-save-parts-directory mm-default-directory))))) + +(defun mh-mime-inline-part () + "Toggle display of the raw MIME part." + (interactive) + (let* ((buffer-read-only nil) + (data (get-text-property (point) 'mh-data)) + (inserted-flag (get-text-property (point) 'mh-mime-inserted)) + (displayed-flag (mm-handle-displayed-p data)) + (point (point)) + start end) + (cond ((and data (not inserted-flag) (not displayed-flag)) + (let ((contents (mm-get-part data))) + (add-text-properties (line-beginning-position) (line-end-position) + '(mh-mime-inserted t)) + (setq start (point-marker)) + (forward-line 1) + (mm-insert-inline data contents) + (setq end (point-marker)) + (add-text-properties + start (progn (goto-char start) (line-end-position)) + `(mh-region (,start . ,end))))) + ((and data (or inserted-flag displayed-flag)) + (mh-press-button) + (message "MIME part already inserted"))) + (goto-char point) + (set-buffer-modified-p nil))) + +(defun mh-widget-press-button (widget el) + "Callback for widget, WIDGET. +Parameter EL is unused." + (goto-char (widget-get widget :from)) + (mh-press-button)) + +(defun mh-mime-display-security (handle) + "Display PGP encrypted/signed message, HANDLE." + (insert "\n") + (save-restriction + (narrow-to-region (point) (point)) + (mh-insert-mime-security-button handle) + (mh-mime-display-mixed (cdr handle)) + (insert "\n") + (let ((mh-mime-security-button-line-format + mh-mime-security-button-end-line-format)) + (mh-insert-mime-security-button handle)) + (mm-set-handle-multipart-parameter + handle 'mh-region + (cons (set-marker (make-marker) (point-min)) + (set-marker (make-marker) (point-max)))))) + +;;; I rewrote the security part because Gnus doesn't seem to ever minimize +;;; the button. That is once the mime-security button is pressed there seems +;;; to be no way of getting rid of the inserted text. +(defun mh-mime-security-show-details (handle) + "Toggle display of detailed security info for HANDLE." + (let ((details (mm-handle-multipart-ctl-parameter handle 'gnus-details))) + (when details + (let ((mh-mime-security-button-pressed + (not (get-text-property (point) 'mh-button-pressed))) + (mh-mime-security-button-line-format + (get-text-property (point) 'mh-line-format))) + (forward-char -1) + (while (eq (get-text-property (point) 'mh-line-format) + mh-mime-security-button-line-format) + (forward-char -1)) + (forward-char) + (save-restriction + (narrow-to-region (point) (point)) + (mh-insert-mime-security-button handle)) + (delete-region + (point) + (or (text-property-not-all + (point) (point-max) + 'mh-line-format mh-mime-security-button-line-format) + (point-max))) + (forward-line -1))))) + +(defun mh-mime-security-press-button (handle) + "Callback from security button for part HANDLE." + (when (mm-handle-multipart-ctl-parameter handle 'gnus-info) + (mh-mime-security-show-details handle))) + +;; These variables should already be initialized in mm-decode.el if we have a +;; recent enough Gnus. The defvars are here to avoid compiler warnings. +(defvar mm-verify-function-alist nil) +(defvar mm-decrypt-function-alist nil) + +(defvar pressed-details) + +(defun mh-insert-mime-security-button (handle) + "Display buttons for PGP message, HANDLE." + (let* ((protocol (mm-handle-multipart-ctl-parameter handle 'protocol)) + (crypto-type (or (nth 2 (assoc protocol mm-verify-function-alist)) + (nth 2 (assoc protocol mm-decrypt-function-alist)) + "Unknown")) + (type (concat crypto-type + (if (equal (car handle) "multipart/signed") + " Signed" " Encrypted") + " Part")) + (info (or (mm-handle-multipart-ctl-parameter handle 'gnus-info) + "Undecided")) + (details (mm-handle-multipart-ctl-parameter handle 'gnus-details)) + pressed-details begin end) + (setq details (if details (concat "\n" details) "")) + (setq pressed-details (if mh-mime-security-button-pressed details "")) + (unless (bolp) (insert "\n")) + (setq begin (point)) + (gnus-eval-format + mh-mime-security-button-line-format + mh-mime-security-button-line-format-alist + `(,@(gnus-local-map-property mh-mime-security-button-map) + mh-button-pressed ,mh-mime-security-button-pressed + mh-callback mh-mime-security-press-button + mh-line-format ,mh-mime-security-button-line-format + mh-data ,handle)) + (setq end (point)) + (widget-convert-button 'link begin end + :mime-handle handle + :action 'mh-widget-press-button + :button-keymap mh-mime-security-button-map + :help-echo "Mouse-2 click or press RET (in show buffer) to see security details.") + (when (equal info "Failed") + (let* ((type (if (equal (car handle) "multipart/signed") + "verification" "decryption")) + (warning (if (equal type "decryption") + "(passphrase may be incorrect)" ""))) + (message "%s %s failed %s" crypto-type type warning))))) + +(defun mh-mm-inline-message (handle) + "Display message, HANDLE. +The function decodes the message and displays it. It avoids decoding the same +message multiple times." + (let ((b (point)) + (charset (mail-content-type-get (mm-handle-type handle) 'charset)) + (clean-message-header mh-clean-message-header-flag) + (invisible-headers mh-invisible-headers) + (visible-headers mh-visible-headers)) + (when (and charset (stringp charset)) + (setq charset (intern (downcase charset))) + (when (eq charset 'us-ascii) + (setq charset nil))) + (save-excursion + (save-restriction + (narrow-to-region b b) + (mm-insert-part handle) + (mh-mime-display + (or (gethash handle (mh-mime-handles-cache (mh-buffer-data))) + (setf (gethash handle (mh-mime-handles-cache (mh-buffer-data))) + (let ((handles (or (mm-dissect-buffer nil) + (mm-uu-dissect)))) + (setf (mh-mime-handles (mh-buffer-data)) + (mm-merge-handles + handles (mh-mime-handles (mh-buffer-data)))) + handles)))) + + (goto-char (point-min)) + (cond (clean-message-header + (mh-clean-msg-header (point-min) + invisible-headers + visible-headers) + (goto-char (point-min))) + (t + (mh-start-of-uncleaned-message))) + (mh-show-xface) + (mh-show-addr) + ;; The other highlighting types don't need anything special + (when (eq mh-highlight-citation-p 'gnus) + (mh-gnus-article-highlight-citation)) + (goto-char (point-min)) + (insert "\n------- Forwarded Message\n\n") + (mh-display-smileys) + (mh-display-emphasis) + (mm-handle-set-undisplayer + handle + `(lambda () + (let (buffer-read-only) + (if (fboundp 'remove-specifier) + ;; This is only valid on XEmacs. + (mapcar (lambda (prop) + (remove-specifier + (face-property 'default prop) (current-buffer))) + '(background background-pixmap foreground))) + (delete-region ,(point-min-marker) ,(point-max-marker))))))))) + +(provide 'mh-mime) + +;;; Local Variables: +;;; sentence-end-double-space: nil +;;; End: + ;;; mh-mime.el ends here
--- a/lisp/mail/mh-pick.el Fri Nov 29 18:02:52 2002 +0000 +++ b/lisp/mail/mh-pick.el Fri Nov 29 18:15:21 2002 +0000 @@ -1,4 +1,4 @@ -;;; mh-pick.el --- make a search pattern and search for a message in mh-e +;;; mh-pick.el --- make a search pattern and search for a message in MH-E ;; Copyright (C) 1993, 1995, 2001 Free Software Foundation, Inc. @@ -26,21 +26,24 @@ ;;; Commentary: -;; Internal support for mh-e package. +;; Internal support for MH-E package. ;;; Change Log: -;; $Id: mh-pick.el,v 1.11 2001/12/29 00:10:41 wohler Exp $ +;; $Id: mh-pick.el,v 1.21 2002/11/05 21:43:16 wohler Exp $ ;;; Code: -(provide 'mh-pick) (require 'mh-e) (require 'easymenu) (require 'gnus-util) -(defvar mh-pick-mode-hook nil - "Invoked in `mh-pick-mode' on a new pattern.") +;;; Hooks + +(defcustom mh-pick-mode-hook nil + "Invoked upon entry to `mh-pick-mode'." + :type 'hook + :group 'mh-hook) ;;; Internal variables: @@ -51,6 +54,7 @@ (defun mh-search-folder (folder) "Search FOLDER for messages matching a pattern. +This function uses the MH command `pick' to do the work. Add the messages found to the sequence named `search'." (interactive (list (mh-prompt-for-folder "Search" mh-current-folder @@ -60,10 +64,13 @@ (not (y-or-n-p "Reuse pattern? "))) (mh-make-pick-template) (message "")) - (setq mh-searching-folder folder)) + (setq mh-searching-folder folder) + (message "%s" (substitute-command-keys + (concat "Type \\[mh-do-pick-search] to search messages, " + "\\[mh-help] for help.")))) (defun mh-make-pick-template () - ;; Initialize the current buffer with a template for a pick pattern. + "Initialize the current buffer with a template for a pick pattern." (erase-buffer) (insert "From: \n" "To: \n" @@ -75,10 +82,35 @@ (goto-char (point-min)) (end-of-line)) +;;; Menu extracted from mh-menubar.el V1.1 (31 July 2001) +(easy-menu-define + mh-pick-menu mh-pick-mode-map "Menu for MH-E pick-mode" + '("Pick" + ["Execute the Search" mh-do-pick-search t])) + + +;;; Help Messages +;;; Group messages logically, more or less. +(defvar mh-pick-mode-help-messages + '((nil + "Search messages: \\[mh-do-pick-search]\n" + "Move to a field by typing C-c C-f C-<field>\n" + "where <field> is the first letter of the desired field.")) + "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.") + (put 'mh-pick-mode 'mode-class 'special) (define-derived-mode mh-pick-mode fundamental-mode "MH-Pick" - "Mode for creating search templates in mh-e.\\<mh-pick-mode-map> + "Mode for creating search templates in MH-E.\\<mh-pick-mode-map> After each field name, enter the pattern to search for. If a field's value does not matter for the search, leave it empty. To search the @@ -87,13 +119,16 @@ To effect a logical \"or\", use \\[mh-search-folder] multiple times. When you have finished, type \\[mh-do-pick-search] to do the search. -This mode runs the hook `mh-pick-mode-hook'. +The value of `mh-pick-mode-hook' is a list of functions to be called, +with no arguments, upon entry to this mode. \\{mh-pick-mode-map}" (make-local-variable 'mh-searching-folder) - (easy-menu-add mh-pick-menu)) - + (easy-menu-add mh-pick-menu) + (make-local-variable 'mh-help-messages) + (setq mh-help-messages mh-pick-mode-help-messages) + (run-hooks 'mh-pick-mode-hook)) (defun mh-do-pick-search () "Find messages that match the qualifications in the current pattern buffer. @@ -104,7 +139,6 @@ (searching-buffer mh-searching-folder) range msgs - (finding-messages t) (pattern nil) (new-buffer nil)) (save-excursion @@ -134,17 +168,16 @@ (mh-add-msgs-to-seq msgs 'search) (delete-other-windows))) - -(defun mh-seq-from-command (folder seq seq-command) - ;; In FOLDER, make a sequence named SEQ by executing COMMAND. - ;; COMMAND is a list. The first element is a program name - ;; and the subsequent elements are its arguments, all strings. +(defun mh-seq-from-command (folder seq command) + "In FOLDER, make a sequence named SEQ by executing COMMAND. +COMMAND is a list. The first element is a program name +and the subsequent elements are its arguments, all strings." (let ((msg) (msgs ()) (case-fold-search t)) (save-excursion (save-window-excursion - (if (eq 0 (apply 'mh-exec-cmd-quiet nil seq-command)) + (if (eq 0 (apply 'mh-exec-cmd-quiet nil command)) ;; "pick" outputs one number per line (while (setq msg (car (mh-read-msg-list))) (setq msgs (cons msg msgs)) @@ -153,17 +186,16 @@ (setq msgs (nreverse msgs)) ;put in ascending order msgs))) - (defun mh-next-pick-field (buffer) - ;; Return the next piece of a pick argument that can be extracted from the - ;; BUFFER. - ;; Return a list like ("--fieldname" "pattern") or ("-search" "bodypat") - ;; or NIL if no pieces remain. + "Return the next piece of a pick argument extracted from BUFFER. +Return a list like (\"--fieldname\" \"pattern\") or (\"-search\" \"bodypat\") +or nil if no pieces remain." (set-buffer buffer) (let ((case-fold-search t)) (cond ((eobp) nil) - ((re-search-forward "^\\([a-z][^: \t\n]*\\):[ \t]*\\([a-z0-9].*\\)$" nil t) + ((re-search-forward "^\\([a-z][^: \t\n]*\\):[ \t]*\\([a-z0-9].*\\)$" + nil t) (let* ((component (format "--%s" (downcase (buffer-substring (match-beginning 1) @@ -180,8 +212,12 @@ (t nil)))) + + ;;; Build the pick-mode keymap: +;;; If this changes, modify mh-pick-mode-help-messages accordingly, above. (gnus-define-keys mh-pick-mode-map + "\C-c?" mh-help "\C-c\C-c" mh-do-pick-search "\C-c\C-f\C-b" mh-to-field "\C-c\C-f\C-c" mh-to-field @@ -198,10 +234,10 @@ "\C-c\C-fs" mh-to-field "\C-c\C-ft" mh-to-field) -;;; Menu extracted from mh-menubar.el V1.1 (31 July 2001) -(easy-menu-define - mh-pick-menu mh-pick-mode-map "Menu for mh-e pick-mode" - '("Pick" - ["Execute the Search" mh-do-pick-search t])) +(provide 'mh-pick) + +;;; Local Variables: +;;; sentence-end-double-space: nil +;;; End: ;;; mh-pick.el ends here
--- a/lisp/mail/mh-seq.el Fri Nov 29 18:02:52 2002 +0000 +++ b/lisp/mail/mh-seq.el Fri Nov 29 18:15:21 2002 +0000 @@ -1,4 +1,4 @@ -;;; mh-seq.el --- mh-e sequences support +;;; mh-seq.el --- MH-E sequences support ;; Copyright (C) 1993, 1995, 2001, 2002 Free Software Foundation, Inc. @@ -25,24 +25,117 @@ ;; Boston, MA 02111-1307, USA. ;;; Commentary: +;; +;; This tries to implement the algorithm described at: +;; http://www.jwz.org/doc/threading.html +;; It is also a start to implementing the IMAP Threading extension RFC. The +;; implementation lacks the reference and subject canonicalization of the +;; RFC. +;; +;; In the presentation buffer, children messages are shown indented with +;; either [ ] or < > around them. Square brackets ([ ]) denote that the +;; algorithm can point out some headers which when taken together implies +;; that the unindented message is an ancestor of the indented message. If +;; no such proof exists then angles (< >) are used. +;; +;; Some issues and problems are as follows: +;; +;; (1) Scan truncates the fields at length 512. So longer references: +;; headers get mutilated. The same kind of MH format string works when +;; composing messages. Is there a way to avoid this? My scan command +;; is as follows: +;; scan +folder -width 10000 \ +;; -format "%(msg)\n%{message-id}\n%{references}\n%{subject}\n" +;; I would really appreciate it if someone would help me with this. +;; +;; (2) Implement heuristics to recognize message-id's in In-Reply-To: +;; header. Right now it just assumes that the last text between angles +;; (< and >) is the message-id. There is the chance that this will +;; incorrectly use an email address like a message-id. +;; +;; (3) Error checking of found message-id's should be done. +;; +;; (4) Since this breaks the assumption that message indices increase as +;; one goes down the buffer, the binary search based mh-goto-msg +;; doesn't work. I have a simpler replacement which may be less +;; efficient. +;; +;; (5) Better canonicalizing for message-id and subject strings. +;; -;; Internal support for mh-e package. +;; Internal support for MH-E package. ;;; Change Log: -;; $Id: mh-seq.el,v 1.14 2002/04/07 19:20:56 wohler Exp $ +;; $Id: mh-seq.el,v 1.71 2002/11/14 20:41:12 wohler Exp $ ;;; Code: -(provide 'mh-seq) +(require 'cl) (require 'mh-e) +;; Shush the byte-compiler +(defvar tool-bar-mode) + +;;; Data structures (used in message threading)... +(defstruct (mh-thread-message (:conc-name mh-message-) + (:constructor mh-thread-make-message)) + (id nil) + (references ()) + (subject "") + (subject-re-p nil)) + +(defstruct (mh-thread-container (:conc-name mh-container-) + (:constructor mh-thread-make-container)) + message parent children + (real-child-p t)) + + ;;; Internal variables: +(defvar mh-last-seq-used nil + "Name of seq to which a msg was last added.") -(defvar mh-last-seq-used nil) ;Name of seq to which a msg was last added. +(defvar mh-non-seq-mode-line-annotation nil + "Saved value of `mh-mode-line-annotation' when narrowed to a seq.") -(defvar mh-non-seq-mode-line-annotation nil) ;Saved value of mh-mode-line-annotation when narrowed to a seq. +;;; Maps and hashes... +(defvar mh-thread-id-hash nil + "Hashtable used to canonicalize message-id strings.") +(defvar mh-thread-subject-hash nil + "Hashtable used to canonicalize subject strings.") +(defvar mh-thread-id-table nil + "Thread ID table maps from message-id's to message containers.") +(defvar mh-thread-id-index-map nil + "Table to lookup message index number from message-id.") +(defvar mh-thread-index-id-map nil + "Table to lookup message-id from message index.") +(defvar mh-thread-scan-line-map nil + "Map of message index to various parts of the scan line.") +(defvar mh-thread-old-scan-line-map nil + "Old map of message index to various parts of the scan line. +This is the original map that is stored when the folder is narrowed.") +(defvar mh-thread-subject-container-hash nil + "Hashtable used to group messages by subject.") +(defvar mh-thread-duplicates nil + "Hashtable used to remember multiple messages with the same message-id.") +(defvar mh-thread-history () + "Variable to remember the transformations to the thread tree. +When new messages are added, these transformations are rewound, then the +links are added from the newly seen messages. Finally the transformations are +redone to get the new thread tree. This makes incremental threading easier.") +(defvar mh-thread-body-width nil + "Width of scan substring that contains subject and body of message.") +(make-variable-buffer-local 'mh-thread-id-hash) +(make-variable-buffer-local 'mh-thread-subject-hash) +(make-variable-buffer-local 'mh-thread-id-table) +(make-variable-buffer-local 'mh-thread-id-index-map) +(make-variable-buffer-local 'mh-thread-index-id-map) +(make-variable-buffer-local 'mh-thread-scan-line-map) +(make-variable-buffer-local 'mh-thread-old-scan-line-map) +(make-variable-buffer-local 'mh-thread-subject-container-hash) +(make-variable-buffer-local 'mh-thread-duplicates) +(make-variable-buffer-local 'mh-thread-history) (defun mh-delete-seq (sequence) "Delete the SEQUENCE." @@ -52,6 +145,8 @@ (mh-undefine-sequence sequence '("all")) (mh-delete-seq-locally sequence)) +;; Avoid compiler warnings +(defvar view-exit-action) (defun mh-list-sequences (folder) "List the sequences defined in FOLDER." @@ -86,16 +181,21 @@ (setq view-exit-action 'kill-buffer) (message "Listing sequences...done"))))) - (defun mh-msg-is-in-seq (message) "Display the sequences that contain MESSAGE (default: current message)." (interactive (list (mh-get-msg-num t))) - (message "Message %d is in sequences: %s" - message - (mapconcat 'concat - (mh-list-to-string (mh-seq-containing-msg message t)) - " "))) - + (let* ((dest-folder (loop for seq in mh-refile-list + when (member message (cdr seq)) + return (car seq))) + (deleted-flag (unless dest-folder (member message mh-delete-list)))) + (message "Message %d%s is in sequences: %s" + message + (cond (dest-folder (format " (to be refiled to %s)" dest-folder)) + (deleted-flag (format " (to be deleted)")) + (t "")) + (mapconcat 'concat + (mh-list-to-string (mh-seq-containing-msg message t)) + " ")))) (defun mh-narrow-to-seq (sequence) "Restrict display of this folder to just messages in SEQUENCE. @@ -104,9 +204,17 @@ (with-mh-folder-updating (t) (cond ((mh-seq-to-msgs sequence) (mh-widen) - (let ((eob (point-max))) - (mh-copy-seq-to-point sequence eob) - (narrow-to-region eob (point-max)) + (mh-remove-all-notation) + (let ((eob (point-max)) + (msg-at-cursor (mh-get-msg-num nil))) + (setq mh-thread-old-scan-line-map mh-thread-scan-line-map) + (setq mh-thread-scan-line-map (make-hash-table :test #'eql)) + (mh-copy-seq-to-eob sequence) + (narrow-to-region eob (point-max)) + (mh-notate-user-sequences) + (mh-notate-deleted-and-refiled) + (mh-notate-seq 'cur mh-note-cur mh-cmd-note) + (when msg-at-cursor (mh-goto-msg msg-at-cursor t t)) (make-variable-buffer-local 'mh-non-seq-mode-line-annotation) (setq mh-non-seq-mode-line-annotation mh-mode-line-annotation) (setq mh-mode-line-annotation (symbol-name sequence)) @@ -115,86 +223,103 @@ (if (and (boundp 'tool-bar-mode) tool-bar-mode) (set (make-local-variable 'tool-bar-map) mh-folder-seq-tool-bar-map)) - (setq mh-narrowed-to-seq sequence))) + (setq mh-narrowed-to-seq sequence) + (push 'widen mh-view-ops))) (t (error "No messages in sequence `%s'" (symbol-name sequence)))))) - (defun mh-put-msg-in-seq (msg-or-seq sequence) "Add MSG-OR-SEQ (default: displayed message) to SEQUENCE. -If optional prefix argument provided, then prompt for the message sequence." - (interactive (list (if current-prefix-arg - (mh-read-seq-default "Add messages from" t) - (mh-get-msg-num t)) +If optional prefix argument provided, then prompt for the message sequence. +If variable `transient-mark-mode' is non-nil and the mark is active, then +the selected region is added to the sequence." + (interactive (list (cond + ((mh-mark-active-p t) + (mh-region-to-sequence (region-beginning) (region-end)) + 'region) + (current-prefix-arg + (mh-read-seq-default "Add messages from" t)) + (t + (mh-get-msg-num t))) (mh-read-seq-default "Add to" nil))) (if (not (mh-internal-seq sequence)) (setq mh-last-seq-used sequence)) (mh-add-msgs-to-seq (if (numberp msg-or-seq) msg-or-seq - (mh-seq-to-msgs msg-or-seq)) + (mh-seq-to-msgs msg-or-seq)) sequence)) +(defun mh-valid-view-change-operation-p (op) + "Check if the view change operation can be performed. +OP is one of 'widen and 'unthread." + (cond ((eq (car mh-view-ops) op) + (pop mh-view-ops)) + (t nil))) (defun mh-widen () "Remove restrictions from current folder, thereby showing all messages." (interactive) (let ((msg (mh-get-msg-num nil))) (when mh-narrowed-to-seq + (cond ((mh-valid-view-change-operation-p 'widen) nil) + ((memq 'widen mh-view-ops) + (while (not (eq (car mh-view-ops) 'widen)) + (setq mh-view-ops (cdr mh-view-ops))) + (pop mh-view-ops)) + (t (error "Widening is not applicable"))) + (when (memq 'unthread mh-view-ops) + (setq mh-thread-scan-line-map mh-thread-old-scan-line-map)) (with-mh-folder-updating (t) (delete-region (point-min) (point-max)) (widen) (setq mh-mode-line-annotation mh-non-seq-mode-line-annotation) (mh-make-folder-mode-line)) (if msg - (mh-goto-msg msg t nil)))) - (mh-notate-deleted-and-refiled) + (mh-goto-msg msg t t)) + (mh-notate-deleted-and-refiled) + (mh-notate-user-sequences) + (mh-notate-seq 'cur mh-note-cur mh-cmd-note) + (mh-recenter nil))) (if (and (boundp 'tool-bar-mode) tool-bar-mode) (set (make-local-variable 'tool-bar-map) mh-folder-tool-bar-map)) (setq mh-narrowed-to-seq nil)) - ;; FIXME? We may want to clear all notations and add one for current-message ;; and process user sequences. (defun mh-notate-deleted-and-refiled () - ;; notate the sequence 'deleted as well as all the sequences in - ;; mh-refile-list. - ;; - ;; First, the 'deleted sequence is straightforward - (mh-notate-seq 'deleted mh-note-deleted mh-cmd-note) - ;; Second, refiles are stored in multiple sequences, one for each folder - ;; name to refile to. This list of buffer names is stored in - ;; mh-refile-list - (mh-mapc - (function - (lambda (dest) - ;; foreach folder name, get the keyed sequence from mh-seq-list - (let ((msg-list (cdr (assoc dest mh-seq-list)))) - (mapcar (lambda (msg) - ;; foreach msg in a sequence, do the mh-notate - (mh-notate msg mh-note-refiled mh-cmd-note)) - msg-list)))) - mh-refile-list)) + "Notate messages marked for deletion or refiling. +Messages to be deleted are given by `mh-delete-list' while messages to be +refiled are present in `mh-refile-list'." + (mh-mapc #'(lambda (msg) (mh-notate msg mh-note-deleted mh-cmd-note)) + mh-delete-list) + (mh-mapc #'(lambda (dest-msg-list) + ;; foreach folder name, get the keyed sequence from mh-seq-list + (let ((msg-list (cdr dest-msg-list))) + (mh-mapc #'(lambda (msg) + (mh-notate msg mh-note-refiled mh-cmd-note)) + msg-list))) + mh-refile-list)) + ;;; Commands to manipulate sequences. Sequences are stored in an alist ;;; of the form: ;;; ((seq-name msgs ...) (seq-name msgs ...) ...) - (defun mh-read-seq-default (prompt not-empty) - ;; Read and return sequence name with default narrowed or previous sequence. + "Read and return sequence name with default narrowed or previous sequence. +PROMPT is the prompt to use when reading. If NOT-EMPTY is non-nil then a +non-empty sequence is read." (mh-read-seq prompt not-empty (or mh-narrowed-to-seq mh-last-seq-used (car (mh-seq-containing-msg (mh-get-msg-num nil) nil))))) - (defun mh-read-seq (prompt not-empty &optional default) - ;; Read and return a sequence name. Prompt with PROMPT, raise an error - ;; if the sequence is empty and the NOT-EMPTY flag is non-nil, and supply - ;; an optional DEFAULT sequence. - ;; A reply of '%' defaults to the first sequence containing the current - ;; message. + "Read and return a sequence name. +Prompt with PROMPT, raise an error if the sequence is empty and the NOT-EMPTY +flag is non-nil, and supply an optional DEFAULT sequence. A reply of '%' +defaults to the first sequence containing the current message." (let* ((input (completing-read (format "%s %s %s" prompt "sequence:" (if default (format "[%s] " default) @@ -209,13 +334,11 @@ (error "No messages in sequence `%s'" seq)) seq)) - (defun mh-seq-names (seq-list) - ;; Return an alist containing the names of the SEQUENCES. - (mapcar (function (lambda (entry) (list (symbol-name (mh-seq-name entry))))) + "Return an alist containing the names of the SEQ-LIST." + (mapcar (lambda (entry) (list (symbol-name (mh-seq-name entry)))) seq-list)) - (defun mh-rename-seq (sequence new-name) "Rename SEQUENCE to have NEW-NAME." (interactive (list (mh-read-seq "Old" t) @@ -228,10 +351,9 @@ (mh-undefine-sequence sequence (mh-seq-msgs old-seq)) (rplaca old-seq new-name))) - (defun mh-map-to-seq-msgs (func seq &rest args) - ;; Invoke the FUNCTION at each message in the SEQUENCE, passing the - ;; remaining ARGS as arguments. +"Invoke the FUNC at each message in the SEQ. +The remaining ARGS are passed as arguments to FUNC." (save-excursion (let ((msgs (mh-seq-to-msgs seq))) (while msgs @@ -239,14 +361,14 @@ (apply func (car msgs) args)) (setq msgs (cdr msgs)))))) - (defun mh-notate-seq (seq notation offset) - ;; Mark the scan listing of all messages in the SEQUENCE with the CHARACTER - ;; at the given OFFSET from the beginning of the listing line. + "Mark the scan listing. +All messages in SEQ are marked with NOTATION at OFFSET from the beginning of +the line." (mh-map-to-seq-msgs 'mh-notate seq notation offset)) - (defun mh-add-to-sequence (seq msgs) + "The sequence SEQ is augmented with the messages in MSGS." ;; Add to a SEQUENCE each message the list of MSGS. (if (not (mh-folder-name-p seq)) (if msgs @@ -254,14 +376,47 @@ "-sequence" (symbol-name seq) (mh-coalesce-msg-list msgs))))) +;; This has a tricky bug. mh-map-to-seq-msgs uses mh-goto-msg, which assumes +;; that the folder buffer is sorted. However in this case that assumption +;; doesn't hold. So we will do this the dumb way. +;(defun mh-copy-seq-to-point (seq location) +; ;; Copy the scan listing of the messages in SEQUENCE to after the point +; ;; LOCATION in the current buffer. +; (mh-map-to-seq-msgs 'mh-copy-line-to-point seq location)) -(defun mh-copy-seq-to-point (seq location) - ;; Copy the scan listing of the messages in SEQUENCE to after the point - ;; LOCATION in the current buffer. - (mh-map-to-seq-msgs 'mh-copy-line-to-point seq location)) - +(defun mh-copy-seq-to-eob (seq) + "Copy SEQ to the end of the buffer." + ;; It is quite involved to write something which will work at any place in + ;; the buffer, so we will write something which works only at the end of + ;; the buffer. If we ever need to insert sequences in the middle of the + ;; buffer, this will need to be fixed. + (save-excursion + (let* ((msgs (mh-seq-to-msgs seq)) + (coalesced-msgs (mh-coalesce-msg-list msgs))) + (goto-char (point-max)) + (save-restriction + (narrow-to-region (point) (point)) + (mh-regenerate-headers coalesced-msgs t) + (when (memq 'unthread mh-view-ops) + ;; Populate restricted scan-line map + (goto-char (point-min)) + (while (not (eobp)) + (setf (gethash (mh-get-msg-num nil) mh-thread-scan-line-map) + (mh-thread-parse-scan-line)) + (forward-line)) + ;; Remove scan lines and read results from pre-computed thread tree + (delete-region (point-min) (point-max)) + (let ((thread-tree (mh-thread-generate mh-current-folder ())) + (mh-thread-body-width + (- (window-width) mh-cmd-note + (1- mh-scan-field-subject-start-offset)))) + (mh-thread-generate-scan-lines thread-tree -2))))))) (defun mh-copy-line-to-point (msg location) + "Copy current message line to a specific location. +The argument MSG is not used. The message in the current line is copied to +LOCATION." + ;; msg is not used? ;; Copy the current line to the LOCATION in the current buffer. (beginning-of-line) (save-excursion @@ -278,19 +433,25 @@ (interactive "r") (mh-delete-seq-locally 'region) (save-excursion + ;; If end is end of buffer back up one position + (setq end (if (equal end (point-max)) (1- end) end)) (goto-char begin) (while (<= (point) end) (mh-add-msgs-to-seq (mh-get-msg-num t) 'region t) (forward-line 1)))) + ;;; Commands to handle new 'subject sequence. ;;; Or "Poor man's threading" by psg. -(defun mh-subject-thread-to-sequence (all) + +(defun mh-subject-to-sequence (all) "Put all following messages with same subject in sequence 'subject. If arg ALL is t, move to beginning of folder buffer to collect all messages. If arg ALL is nil, collect only messages fron current one on forward. + Return number of messages put in the sequence: + nil -> there was no subject line. 0 -> there were no later messages with the same subject (sequence not made) >1 -> the total number of messages including current one." @@ -299,12 +460,11 @@ (save-excursion (beginning-of-line) (if (or (not (looking-at mh-scan-subject-regexp)) - (not (match-string 2)) - (string-equal "" (match-string 2))) + (not (match-string 3)) + (string-equal "" (match-string 3))) (progn (message "No subject line.") nil) - (let ((subject (match-string-no-properties 2)) - (end (point-max)) + (let ((subject (match-string-no-properties 3)) (list)) (if (> (length subject) 41) (setq subject (substring subject 0 41))) @@ -312,7 +472,7 @@ (if all (goto-char (point-min))) (while (re-search-forward mh-scan-subject-regexp nil t) - (let ((this-subject (match-string-no-properties 2))) + (let ((this-subject (match-string-no-properties 3))) (if (> (length this-subject) 41) (setq this-subject (substring this-subject 0 41))) (if (string-equal this-subject subject) @@ -322,22 +482,22 @@ ;; If we created a new sequence, add the initial message to it too. (if (not (member (mh-get-msg-num t) list)) (setq list (cons (mh-get-msg-num t) list))) - (mh-delete-seq-locally 'subject) + (if (member '("subject") (mh-seq-names mh-seq-list)) + (mh-delete-seq 'subject)) ;; sort the result into a sequence - (let ((sorted-list (sort (copy-sequence list) 'mh-lessp)) - (msg)) + (let ((sorted-list (sort (copy-sequence list) 'mh-lessp))) (while sorted-list - (mh-add-msgs-to-seq (car sorted-list) 'subject t) + (mh-add-msgs-to-seq (car sorted-list) 'subject nil) (setq sorted-list (cdr sorted-list))) (safe-length list))) (t 0)))))) -(defun mh-narrow-to-subject-thread () +(defun mh-narrow-to-subject () "Narrow to a sequence containing all following messages with same subject." (interactive) (let ((num (mh-get-msg-num nil)) - (count (mh-subject-thread-to-sequence t))) + (count (mh-subject-to-sequence t))) (cond ((not count) ; No subject line, delete msg anyway nil) @@ -350,20 +510,13 @@ (if (numberp num) (mh-goto-msg num t t)))))) -(defun mh-toggle-subject-thread () - "Narrow to or widen from a sequence containing current subject sequence." +(defun mh-delete-subject () + "Mark all following messages with same subject to be deleted. +This puts the messages in a sequence named subject. You can undo the last +deletion marks using `mh-undo' with a prefix argument and then specifying the +subject sequence." (interactive) - (if (and (stringp mh-mode-line-annotation) - (string-equal mh-mode-line-annotation "subject")) - (progn - (goto-char (point-min)) - (mh-widen)) - (mh-narrow-to-subject-thread))) - -(defun mh-delete-subject-thread () - "Mark all following messages with same subject to be deleted." - (interactive) - (let ((count (mh-subject-thread-to-sequence nil))) + (let ((count (mh-subject-to-sequence nil))) (cond ((not count) ; No subject line, delete msg anyway (mh-delete-msg (mh-get-msg-num t))) @@ -374,16 +527,541 @@ (message "Marked %d messages for deletion" count) (mh-delete-msg 'subject))))) -(defun mh-next-unseen-subject-thread () - "Get the next unseen subject thread." +;;; Message threading: + +(defun mh-thread-initialize () + "Make hash tables, otherwise clear them." + (cond + (mh-thread-id-hash + (clrhash mh-thread-id-hash) + (clrhash mh-thread-subject-hash) + (clrhash mh-thread-id-table) + (clrhash mh-thread-id-index-map) + (clrhash mh-thread-index-id-map) + (clrhash mh-thread-scan-line-map) + (clrhash mh-thread-subject-container-hash) + (clrhash mh-thread-duplicates) + (setq mh-thread-history ())) + (t (setq mh-thread-id-hash (make-hash-table :test #'equal)) + (setq mh-thread-subject-hash (make-hash-table :test #'equal)) + (setq mh-thread-id-table (make-hash-table :test #'eq)) + (setq mh-thread-id-index-map (make-hash-table :test #'eq)) + (setq mh-thread-index-id-map (make-hash-table :test #'eql)) + (setq mh-thread-scan-line-map (make-hash-table :test #'eql)) + (setq mh-thread-subject-container-hash (make-hash-table :test #'eq)) + (setq mh-thread-duplicates (make-hash-table :test #'eq)) + (setq mh-thread-history ())))) + +(defsubst mh-thread-id-container (id) + "Given ID, return the corresponding container in `mh-thread-id-table'. +If no container exists then a suitable container is created and the id-table +is updated." + (when (not id) + (error "1")) + (or (gethash id mh-thread-id-table) + (setf (gethash id mh-thread-id-table) + (let ((message (mh-thread-make-message :id id))) + (mh-thread-make-container :message message))))) + +(defsubst mh-thread-remove-parent-link (child) + "Remove parent link of CHILD if it exists." + (let* ((child-container (if (mh-thread-container-p child) + child (mh-thread-id-container child))) + (parent-container (mh-container-parent child-container))) + (when parent-container + (setf (mh-container-children parent-container) + (remove* child-container (mh-container-children parent-container) + :test #'eq)) + (setf (mh-container-parent child-container) nil)))) + +(defsubst mh-thread-add-link (parent child &optional at-end-p) + "Add links so that PARENT becomes a parent of CHILD. +Doesn't make any changes if CHILD is already an ancestor of PARENT. If +optional argument AT-END-P is non-nil, the CHILD is added to the end of the +children list of PARENT." + (let ((parent-container (cond ((null parent) nil) + ((mh-thread-container-p parent) parent) + (t (mh-thread-id-container parent)))) + (child-container (if (mh-thread-container-p child) + child (mh-thread-id-container child)))) + (when (and parent-container + (not (mh-thread-ancestor-p child-container parent-container)) + (not (mh-thread-ancestor-p parent-container child-container))) + (mh-thread-remove-parent-link child-container) + (cond ((not at-end-p) + (push child-container (mh-container-children parent-container))) + ((null (mh-container-children parent-container)) + (push child-container (mh-container-children parent-container))) + (t (let ((last-child (mh-container-children parent-container))) + (while (cdr last-child) + (setq last-child (cdr last-child))) + (setcdr last-child (cons child-container nil))))) + (setf (mh-container-parent child-container) parent-container)) + (unless parent-container + (mh-thread-remove-parent-link child-container)))) + +(defun mh-thread-ancestor-p (ancestor successor) + "Return t if ANCESTOR is really an ancestor of SUCCESSOR and nil otherwise. +In the limit, the function returns t if ANCESTOR and SUCCESSOR are the same +containers." + (block nil + (while successor + (when (eq ancestor successor) (return t)) + (setq successor (mh-container-parent successor))) + nil)) + +(defsubst mh-thread-get-message-container (message) + "Return container which has MESSAGE in it. +If there is no container present then a new container is allocated." + (let* ((id (mh-message-id message)) + (container (gethash id mh-thread-id-table))) + (cond (container (setf (mh-container-message container) message) + container) + (t (setf (gethash id mh-thread-id-table) + (mh-thread-make-container :message message)))))) + +(defsubst mh-thread-get-message (id subject-re-p subject refs) + "Return appropriate message. +Otherwise update message already present to have the proper ID, SUBJECT-RE-P, +SUBJECT and REFS fields." + (let* ((container (gethash id mh-thread-id-table)) + (message (if container (mh-container-message container) nil))) + (cond (message + (setf (mh-message-subject-re-p message) subject-re-p) + (setf (mh-message-subject message) subject) + (setf (mh-message-id message) id) + (setf (mh-message-references message) refs) + message) + (container + (setf (mh-container-message container) + (mh-thread-make-message :subject subject + :subject-re-p subject-re-p + :id id :references refs))) + (t (let ((message (mh-thread-make-message + :subject subject + :subject-re-p subject-re-p + :id id :references refs))) + (prog1 message + (mh-thread-get-message-container message))))))) + +(defsubst mh-thread-canonicalize-id (id) + "Produce canonical string representation for ID. +This allows cheap string comparison with EQ." + (or (and (equal id "") (copy-sequence "")) + (gethash id mh-thread-id-hash) + (setf (gethash id mh-thread-id-hash) id))) + +(defsubst mh-thread-prune-subject (subject) + "Prune leading Re:'s, Fwd:'s etc. and trailing (fwd)'s from SUBJECT. +If the result after pruning is not the empty string then it is canonicalized +so that subjects can be tested for equality with eq. This is done so that all +the messages without a subject are not put into a single thread." + (let ((case-fold-search t) + (subject-pruned-flag nil)) + ;; Prune subject leader + (while (or (string-match "^[ \t]*\\(re\\|fwd?\\)\\(\\[[0-9]*\\]\\)?:[ \t]*" + subject) + (string-match "^[ \t]*\\[[^\\]][ \t]*" subject)) + (setq subject-pruned-flag t) + (setq subject (substring subject (match-end 0)))) + ;; Prune subject trailer + (while (or (string-match "(fwd)$" subject) + (string-match "[ \t]+$" subject)) + (setq subject-pruned-flag t) + (setq subject (substring subject 0 (match-beginning 0)))) + ;; Canonicalize subject only if it is non-empty + (cond ((equal subject "") (values subject subject-pruned-flag)) + (t (values + (or (gethash subject mh-thread-subject-hash) + (setf (gethash subject mh-thread-subject-hash) subject)) + subject-pruned-flag))))) + +(defun mh-thread-container-subject (container) + "Return the subject of CONTAINER. +If CONTAINER is empty return the subject info of one of its children." + (cond ((and (mh-container-message container) + (mh-message-id (mh-container-message container))) + (mh-message-subject (mh-container-message container))) + (t (block nil + (dolist (kid (mh-container-children container)) + (when (and (mh-container-message kid) + (mh-message-id (mh-container-message kid))) + (let ((kid-message (mh-container-message kid))) + (return (mh-message-subject kid-message))))) + (error "This can't happen!"))))) + +(defun mh-thread-rewind-pruning () + "Restore the thread tree to its state before pruning." + (while mh-thread-history + (let ((action (pop mh-thread-history))) + (cond ((eq (car action) 'DROP) + (mh-thread-remove-parent-link (cadr action)) + (mh-thread-add-link (caddr action) (cadr action))) + ((eq (car action) 'PROMOTE) + (let ((node (cadr action)) + (parent (caddr action)) + (children (cdddr action))) + (dolist (child children) + (mh-thread-remove-parent-link child) + (mh-thread-add-link node child)) + (mh-thread-add-link parent node))) + ((eq (car action) 'SUBJECT) + (let ((node (cadr action))) + (mh-thread-remove-parent-link node) + (setf (mh-container-real-child-p node) t))))))) + +(defun mh-thread-prune-containers (roots) +"Prune empty containers in the containers ROOTS." + (let ((dfs-ordered-nodes ()) + (work-list roots)) + (while work-list + (let ((node (pop work-list))) + (dolist (child (mh-container-children node)) + (push child work-list)) + (push node dfs-ordered-nodes))) + (while dfs-ordered-nodes + (let ((node (pop dfs-ordered-nodes))) + (cond ((gethash (mh-message-id (mh-container-message node)) + mh-thread-id-index-map) + ;; Keep it + (setf (mh-container-children node) + (mh-thread-sort-containers (mh-container-children node)))) + ((and (mh-container-children node) + (or (null (cdr (mh-container-children node))) + (mh-container-parent node))) + ;; Promote kids + (let ((children ())) + (dolist (kid (mh-container-children node)) + (mh-thread-remove-parent-link kid) + (mh-thread-add-link (mh-container-parent node) kid) + (push kid children)) + (push `(PROMOTE ,node ,(mh-container-parent node) ,@children) + mh-thread-history) + (mh-thread-remove-parent-link node))) + ((mh-container-children node) + ;; Promote the first orphan to parent and add the other kids as + ;; his children + (setf (mh-container-children node) + (mh-thread-sort-containers (mh-container-children node))) + (let ((new-parent (car (mh-container-children node))) + (other-kids (cdr (mh-container-children node)))) + (mh-thread-remove-parent-link new-parent) + (dolist (kid other-kids) + (mh-thread-remove-parent-link kid) + (setf (mh-container-real-child-p kid) nil) + (mh-thread-add-link new-parent kid t)) + (push `(PROMOTE ,node ,(mh-container-parent node) + ,new-parent ,@other-kids) + mh-thread-history) + (mh-thread-remove-parent-link node))) + (t + ;; Drop it + (push `(DROP ,node ,(mh-container-parent node)) + mh-thread-history) + (mh-thread-remove-parent-link node))))) + (let ((results ())) + (maphash #'(lambda (k v) + (declare (ignore k)) + (when (and (null (mh-container-parent v)) + (gethash (mh-message-id (mh-container-message v)) + mh-thread-id-index-map)) + (push v results))) + mh-thread-id-table) + (mh-thread-sort-containers results)))) + +(defun mh-thread-sort-containers (containers) + "Sort a list of message CONTAINERS to be in ascending order wrt index." + (sort containers + #'(lambda (x y) + (when (and (mh-container-message x) (mh-container-message y)) + (let* ((id-x (mh-message-id (mh-container-message x))) + (id-y (mh-message-id (mh-container-message y))) + (index-x (gethash id-x mh-thread-id-index-map)) + (index-y (gethash id-y mh-thread-id-index-map))) + (and (integerp index-x) (integerp index-y) + (< index-x index-y))))))) + +(defsubst mh-thread-group-by-subject (roots) + "Group the set of message containers, ROOTS based on subject. +Bug: Check for and make sure that something without Re: is made the parent in +preference to something that has it." + (clrhash mh-thread-subject-container-hash) + (let ((results ())) + (dolist (root roots) + (let* ((subject (mh-thread-container-subject root)) + (parent (gethash subject mh-thread-subject-container-hash))) + (cond (parent (mh-thread-remove-parent-link root) + (mh-thread-add-link parent root t) + (setf (mh-container-real-child-p root) nil) + (push `(SUBJECT ,root) mh-thread-history)) + (t + (setf (gethash subject mh-thread-subject-container-hash) root) + (push root results))))) + (nreverse results))) + +(defsubst mh-thread-process-in-reply-to (reply-to-header) + "Extract message id's from REPLY-TO-HEADER. +Ideally this should have some regexp which will try to guess if a string +between < and > is a message id and not an email address. For now it will +take the last string inside angles." + (let ((end (search ">" reply-to-header :from-end t))) + (when (numberp end) + (let ((begin (search "<" reply-to-header :from-end t :end2 end))) + (when (numberp begin) + (list (substring reply-to-header begin (1+ end)))))))) + +(defun mh-thread-set-tables (folder) + "Use the tables of FOLDER in current buffer." + (flet ((mh-get-table (symbol) + (save-excursion (set-buffer folder) (symbol-value symbol)))) + (setq mh-thread-id-hash (mh-get-table 'mh-thread-id-hash)) + (setq mh-thread-subject-hash (mh-get-table 'mh-thread-subject-hash)) + (setq mh-thread-id-table (mh-get-table 'mh-thread-id-table)) + (setq mh-thread-id-index-map (mh-get-table 'mh-thread-id-index-map)) + (setq mh-thread-index-id-map (mh-get-table 'mh-thread-index-id-map)) + (setq mh-thread-scan-line-map (mh-get-table 'mh-thread-scan-line-map)) + (setq mh-thread-subject-container-hash + (mh-get-table 'mh-thread-subject-container-hash)) + (setq mh-thread-duplicates (mh-get-table 'mh-thread-duplicates)) + (setq mh-thread-history (mh-get-table 'mh-thread-history)))) + +(defsubst mh-thread-update-id-index-maps (id index) + "Message with id, ID is the message in INDEX. +The function also checks for duplicate messages (that is multiple messages +with the same ID). These messages are put in the `mh-thread-duplicates' hash +table." + (let ((old-index (gethash id mh-thread-id-index-map))) + (when old-index (push old-index (gethash id mh-thread-duplicates))) + (setf (gethash id mh-thread-id-index-map) index) + (setf (gethash index mh-thread-index-id-map) id))) + + + +;;; Generate Threads... + +(defun mh-thread-generate (folder msg-list) + "Scan FOLDER to get info for threading. +Only information about messages in MSG-LIST are added to the tree." + (save-excursion + (set-buffer (get-buffer-create "*mh-thread*")) + (mh-thread-set-tables folder) + (erase-buffer) + (when msg-list + (apply + #'call-process (expand-file-name mh-scan-prog mh-progs) nil '(t nil) nil + "-width" "10000" "-format" + "%(msg)\n%{message-id}\n%{references}\n%{in-reply-to}\n%{subject}\n" + (mapcar #'(lambda (x) (format "%s" x)) msg-list))) + (goto-char (point-min)) + (let ((roots ()) + (case-fold-search t)) + (block nil + (while (not (eobp)) + (block process-message + (let* ((index-line + (prog1 (buffer-substring (point) (line-end-position)) + (forward-line))) + (index (car (read-from-string index-line))) + (id (prog1 (buffer-substring (point) (line-end-position)) + (forward-line))) + (refs (prog1 (buffer-substring (point) (line-end-position)) + (forward-line))) + (in-reply-to (prog1 (buffer-substring (point) + (line-end-position)) + (forward-line))) + (subject (prog1 + (buffer-substring (point) (line-end-position)) + (forward-line))) + (subject-re-p nil)) + (unless (gethash index mh-thread-scan-line-map) + (return-from process-message)) + (unless (integerp index) (return)) ;Error message here + (multiple-value-setq (subject subject-re-p) + (mh-thread-prune-subject subject)) + (setq in-reply-to (mh-thread-process-in-reply-to in-reply-to)) + (setq refs (append (split-string refs) in-reply-to)) + (setq id (mh-thread-canonicalize-id id)) + (mh-thread-update-id-index-maps id index) + (setq refs (mapcar #'mh-thread-canonicalize-id refs)) + (mh-thread-get-message id subject-re-p subject refs) + (do ((ancestors refs (cdr ancestors))) + ((null (cdr ancestors)) + (when (car ancestors) + (mh-thread-remove-parent-link id) + (mh-thread-add-link (car ancestors) id))) + (mh-thread-add-link (car ancestors) (cadr ancestors))))))) + (maphash #'(lambda (k v) + (declare (ignore k)) + (when (null (mh-container-parent v)) + (push v roots))) + mh-thread-id-table) + (setq roots (mh-thread-prune-containers roots)) + (prog1 (setq roots (mh-thread-group-by-subject roots)) + (let ((history mh-thread-history)) + (set-buffer folder) + (setq mh-thread-history history)))))) + +(defun mh-thread-inc (folder start-point) + "Update thread tree for FOLDER. +All messages after START-POINT are added to the thread tree." + (mh-thread-rewind-pruning) + (goto-char start-point) + (let ((msg-list ())) + (while (not (eobp)) + (let ((index (mh-get-msg-num nil))) + (push index msg-list) + (setf (gethash index mh-thread-scan-line-map) + (mh-thread-parse-scan-line)) + (forward-line))) + (let ((thread-tree (mh-thread-generate folder msg-list)) + (buffer-read-only nil) + (old-buffer-modified-flag (buffer-modified-p))) + (delete-region (point-min) (point-max)) + (let ((mh-thread-body-width (- (window-width) mh-cmd-note + (1- mh-scan-field-subject-start-offset)))) + (mh-thread-generate-scan-lines thread-tree -2)) + (mh-notate-user-sequences) + (mh-notate-deleted-and-refiled) + (mh-notate-seq 'cur mh-note-cur mh-cmd-note) + (set-buffer-modified-p old-buffer-modified-flag)))) + +(defun mh-thread-generate-scan-lines (tree level) + "Generate scan lines. +TREE is the hierarchical tree of messages, SCAN-LINE-MAP maps message indices +to the corresponding scan lines and LEVEL used to determine indentation of +the message." + (cond ((null tree) nil) + ((mh-thread-container-p tree) + (let* ((message (mh-container-message tree)) + (id (mh-message-id message)) + (index (gethash id mh-thread-id-index-map)) + (duplicates (gethash id mh-thread-duplicates)) + (new-level (+ level 2)) + (dupl-flag t) + (increment-level-flag nil)) + (dolist (scan-line (mapcar (lambda (x) + (gethash x mh-thread-scan-line-map)) + (reverse (cons index duplicates)))) + (when scan-line + (insert (car scan-line) + (format (format "%%%ss" + (if dupl-flag level new-level)) "") + (if (and (mh-container-real-child-p tree) dupl-flag) + "[" "<") + (cadr scan-line) + (if (and (mh-container-real-child-p tree) dupl-flag) + "]" ">") + (truncate-string-to-width + (caddr scan-line) (- mh-thread-body-width + (if dupl-flag level new-level))) + "\n") + (setq increment-level-flag t) + (setq dupl-flag nil))) + (unless increment-level-flag (setq new-level level)) + (dolist (child (mh-container-children tree)) + (mh-thread-generate-scan-lines child new-level)))) + (t (let ((nlevel (+ level 2))) + (dolist (ch tree) + (mh-thread-generate-scan-lines ch nlevel)))))) + +;; Another and may be better approach would be to generate all the info from +;; the scan which generates the threading info. For now this will have to do. +(defun mh-thread-parse-scan-line (&optional string) + "Parse a scan line. +If optional argument STRING is given then that is assumed to be the scan line. +Otherwise uses the line at point as the scan line to parse." + (let* ((string (or string + (buffer-substring-no-properties (line-beginning-position) + (line-end-position)))) + (first-string (substring string 0 (+ mh-cmd-note 8)))) + (setf (elt first-string mh-cmd-note) ? ) + (when (equal (elt first-string (1+ mh-cmd-note)) (elt mh-note-seq 0)) + (setf (elt first-string (1+ mh-cmd-note)) ? )) + (list first-string + (substring string + (+ mh-cmd-note mh-scan-field-from-start-offset) + (+ mh-cmd-note mh-scan-field-from-end-offset -2)) + (substring string (+ mh-cmd-note mh-scan-field-from-end-offset)) + string))) + +(defun mh-thread-add-spaces (count) + "Add COUNT spaces to each scan line in `mh-thread-scan-line-map'." + (let ((spaces (format (format "%%%ss" count) ""))) + (while (not (eobp)) + (let* ((msg-num (mh-get-msg-num nil)) + (old-line (nth 3 (gethash msg-num mh-thread-scan-line-map)))) + (setf (gethash msg-num mh-thread-scan-line-map) + (mh-thread-parse-scan-line (format "%s%s" spaces old-line)))) + (forward-line 1)))) + +(defun mh-thread-folder () + "Generate thread view of folder." + (message "Threading %s..." (buffer-name)) + (mh-thread-initialize) + (goto-char (point-min)) + (while (not (eobp)) + (setf (gethash (mh-get-msg-num nil) mh-thread-scan-line-map) + (mh-thread-parse-scan-line)) + (forward-line)) + (let* ((range (format "%s-%s" mh-first-msg-num mh-last-msg-num)) + (thread-tree (mh-thread-generate (buffer-name) (list range))) + (buffer-read-only nil) + (old-buffer-modified-p (buffer-modified-p))) + (delete-region (point-min) (point-max)) + (let ((mh-thread-body-width (- (window-width) mh-cmd-note + (1- mh-scan-field-subject-start-offset)))) + (mh-thread-generate-scan-lines thread-tree -2)) + (mh-notate-user-sequences) + (mh-notate-deleted-and-refiled) + (mh-notate-seq 'cur mh-note-cur mh-cmd-note) + (set-buffer-modified-p old-buffer-modified-p) + (message "Threading %s...done" (buffer-name)))) + +(defun mh-toggle-threads () + "Toggle threaded view of folder. +The conversion of normal view to threaded view is exact, that is the same +messages are displayed in the folder buffer before and after threading. However +the conversion from threaded view to normal view is inexact. So more messages +than were originally present may be shown as a result." (interactive) - (if (and mh-mode-line-annotation - (string-equal mh-mode-line-annotation "subject")) - (goto-char (point-min))) - (if (or (not mh-mode-line-annotation) - (not (string-equal mh-mode-line-annotation "unseen"))) - (mh-narrow-to-seq 'unseen)) - (mh-next-undeleted-msg) - (mh-narrow-to-subject-thread)) + (let ((msg-at-point (mh-get-msg-num nil))) + (cond ((and (memq 'unthread mh-view-ops) mh-narrowed-to-seq) + (unless (mh-valid-view-change-operation-p 'unthread) + (error "Can't unthread folder")) + (mh-scan-folder mh-current-folder + (format "%s" mh-narrowed-to-seq) + t)) + ((memq 'unthread mh-view-ops) + (unless (mh-valid-view-change-operation-p 'unthread) + (error "Can't unthread folder")) + (mh-scan-folder mh-current-folder + (format "%s-%s" mh-first-msg-num mh-last-msg-num) + t)) + (t (mh-thread-folder) + (push 'unthread mh-view-ops))) + (when msg-at-point (mh-goto-msg msg-at-point t t)) + (mh-recenter nil))) + +(defun mh-thread-forget-message (index) + "Forget the message INDEX from the threading tables." + (let* ((id (gethash index mh-thread-index-id-map)) + (id-index (gethash id mh-thread-id-index-map)) + (duplicates (gethash id mh-thread-duplicates))) + (remhash index mh-thread-index-id-map) + (cond ((and (eql index id-index) (null duplicates)) + (remhash id mh-thread-id-index-map)) + ((eql index id-index) + (setf (gethash id mh-thread-id-index-map) (car duplicates)) + (setf (gethash (car duplicates) mh-thread-index-id-map) id) + (setf (gethash id mh-thread-duplicates) (cdr duplicates))) + (t + (setf (gethash id mh-thread-duplicates) + (remove index duplicates)))))) + +(provide 'mh-seq) + +;;; Local Variables: +;;; sentence-end-double-space: nil +;;; End: ;;; mh-seq.el ends here
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/mail/mh-speed.el Fri Nov 29 18:15:21 2002 +0000 @@ -0,0 +1,667 @@ +;;; mh-speed.el --- Speedbar interface for MH-E. + +;; Copyright (C) 2002 Free Software Foundation, Inc. + +;; Author: Bill Wohler <wohler@newt.com> +;; Maintainer: Bill Wohler <wohler@newt.com> +;; Keywords: mail +;; See: mh-e.el + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Commentary: +;; Future versions should only use flists. + +;; Speedbar support for MH-E package. + +;;; Change Log: + +;; $Id: mh-speed.el,v 1.26 2002/11/13 19:36:00 wohler Exp $ + +;;; Code: + +;; Requires +(require 'cl) +(require 'mh-utils) +(require 'mh-e) +(require 'speedbar) + +;; Autoloads +(autoload 'mh-index-goto-nearest-msg "mh-index") +(autoload 'mh-index-parse-folder "mh-index") +(autoload 'mh-visit-folder "mh-e") + +;; User customizable +(defcustom mh-large-folder 200 + "The number of messages that indicates a large folder. +If the number of messages in a folder exceeds this value, confirmation is +required when the folder is visited from the speedbar." + :type 'integer + :group 'mh) + +(defcustom mh-speed-flists-interval 60 + "Time between calls to flists in seconds. +If 0, flists is not called repeatedly." + :type 'integer + :group 'mh) + +(defcustom mh-speed-run-flists-flag t + "Non-nil means flists is used. +If non-nil, flists is executed every `mh-speed-flists-interval' seconds to +update the display of the number of unseen and total messages in each folder. +If resources are limited, this can be set to nil and the speedbar display can +be updated manually with the \\[mh-speed-flists] command." + :type 'boolean + :group 'mh) + +(defface mh-speedbar-folder-face + '((((class color) (background light)) + (:foreground "blue4")) + (((class color) (background dark)) + (:foreground "light blue"))) + "Face used for folders in the speedbar buffer." + :group 'mh) + +(defface mh-speedbar-selected-folder-face + '((((class color) (background light)) + (:foreground "red" :underline t)) + (((class color) (background dark)) + (:foreground "red" :underline t)) + (t (:underline t))) + "Face used for the current folder." + :group 'mh) + +(defface mh-speedbar-folder-with-unseen-messages-face + '((t (:inherit mh-speedbar-folder-face :bold t))) + "Face used for folders in the speedbar buffer which have unread messages." + :group 'mh) + +(defface mh-speedbar-selected-folder-with-unseen-messages-face + '((t (:inherit mh-speedbar-selected-folder-face :bold t))) + "Face used for the current folder when it has unread messages." + :group 'mh) + +;; Global variables +(defvar mh-speed-refresh-flag nil) +(defvar mh-speed-last-selected-folder nil) +(defvar mh-speed-folder-map (make-hash-table :test #'equal)) +(defvar mh-speed-folders-cache (make-hash-table :test #'equal)) +(defvar mh-speed-flists-cache (make-hash-table :test #'equal)) +(defvar mh-speed-flists-process nil) +(defvar mh-speed-flists-timer nil) +(defvar mh-speed-partial-line "") + +;; Add our stealth update function +(unless (member 'mh-speed-stealth-update + (cdr (assoc "files" speedbar-stealthy-function-list))) + ;; Is changing constant lists in elisp safe? + (setq speedbar-stealthy-function-list + (copy-tree speedbar-stealthy-function-list)) + (push 'mh-speed-stealth-update + (cdr (assoc "files" speedbar-stealthy-function-list)))) + +;; Functions called by speedbar to initialize display... +(defun mh-folder-speedbar-buttons (buffer) + "Interface function to create MH-E speedbar buffer. +BUFFER is the MH-E buffer for which the speedbar buffer is to be created." + (unless (get-text-property (point-min) 'mh-level) + (erase-buffer) + (clrhash mh-speed-folder-map) + (speedbar-make-tag-line 'bracket ?+ 'mh-speed-toggle nil " " 'ignore nil + 'mh-speedbar-folder-face 0) + (forward-line -1) + (setf (gethash nil mh-speed-folder-map) + (set-marker (make-marker) (1+ (line-beginning-position)))) + (add-text-properties + (line-beginning-position) (1+ (line-beginning-position)) + `(mh-folder nil mh-expanded nil mh-children-p t mh-level 0)) + (mh-speed-stealth-update t) + (when mh-speed-run-flists-flag + (mh-speed-flists nil)))) + +(defalias 'mh-show-speedbar-buttons 'mh-folder-speedbar-buttons) +(defalias 'mh-index-folder-speedbar-buttons 'mh-folder-speedbar-buttons) +(defalias 'mh-index-show-speedbar-buttons 'mh-folder-speedbar-buttons) +(defalias 'mh-letter-speedbar-buttons 'mh-folder-speedbar-buttons) + +;; Keymaps for speedbar... +(defvar mh-folder-speedbar-key-map (speedbar-make-specialized-keymap) + "Specialized speedbar keymap for MH-E buffers.") +(gnus-define-keys mh-folder-speedbar-key-map + "+" mh-speed-expand-folder + "-" mh-speed-contract-folder + "\r" mh-speed-view + "f" mh-speed-flists + "i" mh-speed-invalidate-map) + +(defvar mh-show-speedbar-key-map mh-folder-speedbar-key-map) +(defvar mh-index-folder-speedbar-key-map mh-folder-speedbar-key-map) +(defvar mh-index-show-speedbar-key-map mh-folder-speedbar-key-map) +(defvar mh-letter-speedbar-key-map mh-folder-speedbar-key-map) + +;; Menus for speedbar... +(defvar mh-folder-speedbar-menu-items + '(["Visit Folder" mh-speed-view + (save-excursion + (set-buffer speedbar-buffer) + (get-text-property (line-beginning-position) 'mh-folder))] + ["Expand nested folders" mh-speed-expand-folder + (and (get-text-property (line-beginning-position) 'mh-children-p) + (not (get-text-property (line-beginning-position) 'mh-expanded)))] + ["Contract nested folders" mh-speed-contract-folder + (and (get-text-property (line-beginning-position) 'mh-children-p) + (get-text-property (line-beginning-position) 'mh-expanded))] + ["Run Flists" mh-speed-flists t] + ["Invalidate cached folders" mh-speed-invalidate-map t]) + "Extra menu items for speedbar.") + +(defvar mh-show-speedbar-menu-items mh-folder-speedbar-menu-items) +(defvar mh-index-folder-speedbar-menu-items mh-folder-speedbar-menu-items) +(defvar mh-index-show-speedbar-menu-items mh-folder-speedbar-menu-items) +(defvar mh-letter-speedbar-menu-items mh-folder-speedbar-menu-items) + +(defmacro mh-speed-select-attached-frame () + "Compatibility macro to handle speedbar versions 0.11a and 0.14beta4." + (cond ((fboundp 'dframe-select-attached-frame) + '(dframe-select-attached-frame speedbar-frame)) + ((boundp 'speedbar-attached-frame) + '(select-frame speedbar-attached-frame)) + (t (error "Installed speedbar version not supported by MH-E")))) + +(defun mh-speed-update-current-folder (force) + "Update speedbar highlighting of the current folder. +The function tries to be smart so that work done is minimized. The currently +highlighted folder is cached and no highlighting happens unless it changes. +Also highlighting is suspended while the speedbar frame is selected. +Otherwise you get the disconcerting behavior of folders popping open on their +own when you are trying to navigate around in the speedbar buffer. + +The update is always carried out if FORCE is non-nil." + (let* ((lastf (selected-frame)) + (newcf (save-excursion + (mh-speed-select-attached-frame) + (prog1 (mh-speed-extract-folder-name (buffer-name)) + (select-frame lastf)))) + (lastb (current-buffer)) + (case-fold-search t)) + (when (or force + (and mh-speed-refresh-flag (not (eq lastf speedbar-frame))) + (and (stringp newcf) + (equal (substring newcf 0 1) "+") + (not (equal newcf mh-speed-last-selected-folder)))) + (setq mh-speed-refresh-flag nil) + (select-frame speedbar-frame) + (set-buffer speedbar-buffer) + + ;; Remove highlight from previous match... + (mh-speed-highlight mh-speed-last-selected-folder + 'mh-speedbar-folder-face) + + ;; If we found a match highlight it... + (when (mh-speed-goto-folder newcf) + (mh-speed-highlight newcf 'mh-speedbar-selected-folder-face)) + + (setq mh-speed-last-selected-folder newcf) + (speedbar-position-cursor-on-line) + (set-window-point (frame-first-window speedbar-frame) (point)) + (set-buffer lastb) + (select-frame lastf)) + (when (eq lastf speedbar-frame) + (setq mh-speed-refresh-flag t)))) + +(defun mh-speed-normal-face (face) + "Return normal face for given FACE." + (cond ((eq face 'mh-speedbar-folder-with-unseen-messages-face) + 'mh-speedbar-folder-face) + ((eq face 'mh-speedbar-selected-folder-with-unseen-messages-face) + 'mh-speedbar-selected-folder-face) + (t face))) + +(defun mh-speed-bold-face (face) + "Return bold face for given FACE." + (cond ((eq face 'mh-speedbar-folder-face) + 'mh-speedbar-folder-with-unseen-messages-face) + ((eq face 'mh-speedbar-selected-folder-face) + 'mh-speedbar-selected-folder-with-unseen-messages-face) + (t face))) + +(defun mh-speed-highlight (folder face) + "Set FOLDER to FACE." + (save-excursion + (speedbar-with-writable + (goto-char (gethash folder mh-speed-folder-map (point))) + (beginning-of-line) + (if (re-search-forward "([1-9][0-9]*/[0-9]+)" (line-end-position) t) + (setq face (mh-speed-bold-face face)) + (setq face (mh-speed-normal-face face))) + (beginning-of-line) + (when (re-search-forward "\\[.\\] " (line-end-position) t) + (put-text-property (point) (line-end-position) 'face face))))) + +(defun mh-speed-stealth-update (&optional force) + "Do stealth update. +With non-nil FORCE, the update is always carried out." + (cond ((save-excursion (set-buffer speedbar-buffer) + (get-text-property (point-min) 'mh-level)) + ;; Execute this hook and *don't* run anything else + (mh-speed-update-current-folder force) + nil) + ;; Otherwise on to your regular programming + (t t))) + +(defun mh-speed-goto-folder (folder) + "Move point to line containing FOLDER. +The function will expand out parent folders of FOLDER if needed." + (let ((prefix folder) + (suffix-list ()) + (last-slash t)) + (while (and (not (gethash prefix mh-speed-folder-map)) last-slash) + (setq last-slash (search "/" prefix :from-end t)) + (when (integerp last-slash) + (push (substring prefix (1+ last-slash)) suffix-list) + (setq prefix (substring prefix 0 last-slash)))) + (let ((prefix-position (gethash prefix mh-speed-folder-map))) + (if prefix-position + (goto-char prefix-position) + (goto-char (point-min)) + (mh-speed-toggle) + (unless (get-text-property (point) 'mh-expanded) + (mh-speed-toggle)) + (goto-char (gethash prefix mh-speed-folder-map)))) + (while suffix-list + ;; We always need atleast one toggle. We need two if the directory list + ;; is stale since a folder was added. + (when (equal prefix (get-text-property (line-beginning-position) + 'mh-folder)) + (mh-speed-toggle) + (unless (get-text-property (point) 'mh-expanded) + (mh-speed-toggle))) + (setq prefix (format "%s/%s" prefix (pop suffix-list))) + (goto-char (gethash prefix mh-speed-folder-map (point)))) + (beginning-of-line) + (equal folder (get-text-property (point) 'mh-folder)))) + +(defun mh-speed-extract-folder-name (buffer) + "Given an MH-E BUFFER find the folder that should be highlighted. +Do the right thing for the different kinds of buffers that MH-E uses." + (save-excursion + (set-buffer buffer) + (cond ((eq major-mode 'mh-folder-mode) + mh-current-folder) + ((eq major-mode 'mh-show-mode) + (set-buffer mh-show-folder-buffer) + mh-current-folder) + ((eq major-mode 'mh-index-folder-mode) + (save-excursion + (mh-index-goto-nearest-msg) + (mh-index-parse-folder))) + ((or (eq major-mode 'mh-index-show-mode) + (eq major-mode 'mh-letter-mode)) + (when (string-match mh-user-path buffer-file-name) + (let* ((rel-path (substring buffer-file-name (match-end 0))) + (directory-end (search "/" rel-path :from-end t))) + (when directory-end + (format "+%s" (substring rel-path 0 directory-end))))))))) + +(defun mh-speed-add-buttons (folder level) + "Add speedbar button for FOLDER which is at indented by LEVEL amount." + (let ((folder-list (mh-speed-folders folder))) + (mapc + (lambda (f) + (let* ((folder-name (format "%s%s%s" (or folder "+") + (if folder "/" "") (car f))) + (counts (gethash folder-name mh-speed-flists-cache))) + (speedbar-with-writable + (speedbar-make-tag-line + 'bracket (if (cdr f) ?+ ? ) + 'mh-speed-toggle nil + (format "%s%s" + (car f) + (if counts + (format " (%s/%s)" (car counts) (cdr counts)) + "")) + 'mh-speed-view nil + (if (and counts (> (car counts) 0)) + 'mh-speedbar-folder-with-unseen-messages-face + 'mh-speedbar-folder-face) + level) + (save-excursion + (forward-line -1) + (setf (gethash folder-name mh-speed-folder-map) + (set-marker (make-marker) (1+ (line-beginning-position)))) + (add-text-properties + (line-beginning-position) (1+ (line-beginning-position)) + `(mh-folder ,folder-name + mh-expanded nil + mh-children-p ,(not (not (cdr f))) + ,@(if counts `(mh-count (,(car counts) . ,(cdr counts))) ()) + mh-level ,level)))))) + folder-list))) + +(defun mh-speed-toggle (&rest args) + "Toggle the display of child folders. +The otional ARGS are ignored and there for compatibilty with speedbar." + (interactive) + (declare (ignore args)) + (beginning-of-line) + (let ((parent (get-text-property (point) 'mh-folder)) + (kids-p (get-text-property (point) 'mh-children-p)) + (expanded (get-text-property (point) 'mh-expanded)) + (level (get-text-property (point) 'mh-level)) + (point (point)) + start-region) + (speedbar-with-writable + (cond ((not kids-p) nil) + (expanded + (forward-line) + (setq start-region (point)) + (while (and (get-text-property (point) 'mh-level) + (> (get-text-property (point) 'mh-level) level)) + (remhash (get-text-property (point) 'mh-folder) + mh-speed-folder-map) + (forward-line)) + (delete-region start-region (point)) + (forward-line -1) + (speedbar-change-expand-button-char ?+) + (add-text-properties + (line-beginning-position) (1+ (line-beginning-position)) + '(mh-expanded nil))) + (t + (forward-line) + (mh-speed-add-buttons parent (1+ level)) + (goto-char point) + (speedbar-change-expand-button-char ?-) + (add-text-properties + (line-beginning-position) (1+ (line-beginning-position)) + `(mh-expanded t))))))) + +(defalias 'mh-speed-expand-folder 'mh-speed-toggle) +(defalias 'mh-speed-contract-folder 'mh-speed-toggle) + +(defun mh-speed-folder-size () + "Find folder size if folder on current line." + (let ((folder (get-text-property (line-beginning-position) 'mh-folder))) + (or (cdr (get-text-property (line-beginning-position) 'mh-count)) + (and (null folder) 0) + (with-temp-buffer + (call-process (expand-file-name "flist" mh-progs) nil t nil + "-norecurse" folder) + (goto-char (point-min)) + (unless (re-search-forward "out of " (line-end-position) t) + (error "Call to flist failed on folder %s" folder)) + (car (read-from-string + (buffer-substring-no-properties (point) + (line-end-position)))))))) + +(defun mh-speed-view (&rest args) + "View folder on current line. +Optional ARGS are ignored." + (interactive) + (declare (ignore args)) + (let* ((folder (get-text-property (line-beginning-position) 'mh-folder)) + (range + (cond ((save-excursion + (beginning-of-line) + (re-search-forward "([1-9][0-9]*/[0-9]+)" + (line-end-position) t)) + mh-unseen-seq) + ((> (mh-speed-folder-size) mh-large-folder) + (let* ((size (mh-speed-folder-size)) + (prompt + (format "How many messages from %s (default: %s): " + folder size)) + (in (read-string prompt nil nil + (number-to-string size))) + (result (car (ignore-errors (read-from-string in))))) + (cond ((null result) (format "last:%s" size)) + ((numberp result) (format "last:%s" result)) + (t (format "%s" result))))) + (t nil)))) + (when (stringp folder) + (speedbar-with-attached-buffer + (mh-visit-folder folder range) + (delete-other-windows))))) + +(defun mh-speed-folders (folder) + "Find the subfolders of FOLDER. +The function avoids running folders unnecessarily by caching the results of +the actual folders call." + (let ((match (gethash folder mh-speed-folders-cache 'no-result))) + (cond ((eq match 'no-result) + (setf (gethash folder mh-speed-folders-cache) + (mh-speed-folders-actual folder))) + (t match)))) + +(defun mh-speed-folders-actual (folder) + "Execute the command folders to return the sub-folders of FOLDER. +Filters out the folder names that start with \".\" so that directories that +aren't usually mail folders are hidden." + (let* ((folder (cond ((and (stringp folder) + (equal (substring folder 0 1) "+")) + folder) + (t nil))) + (arg-list `(,(expand-file-name "folders" mh-progs) + nil (t nil) nil "-noheader" "-norecurse" + ,@(if (stringp folder) (list folder) ()))) + (results ())) + (with-temp-buffer + (apply #'call-process arg-list) + (goto-char (point-min)) + (while (not (and (eolp) (bolp))) + (let ((folder-end (or (search-forward "+ " (line-end-position) t) + (search-forward " " (line-end-position) t)))) + (when (integerp folder-end) + (let ((name (buffer-substring (line-beginning-position) + (match-beginning 0)))) + (let ((first-char (substring name 0 1))) + (unless (or (string-equal first-char ".") + (string-equal first-char "#") + (string-equal first-char ",")) + (push + (cons name + (search-forward "(others)" (line-end-position) t)) + results))))) + (forward-line 1)))) + (setq results (nreverse results)) + (when (stringp folder) + (setq results (cdr results)) + (let ((folder-name-len (length (format "%s/" (substring folder 1))))) + (setq results (mapcar (lambda (f) + (cons (substring (car f) folder-name-len) + (cdr f))) + results)))) + results)) + +(defun mh-speed-flists (force) + "Execute flists -recurse and update message counts. +If FORCE is non-nil the timer is reset." + (interactive (list t)) + (when force + (when (timerp mh-speed-flists-timer) + (cancel-timer mh-speed-flists-timer)) + (setq mh-speed-flists-timer nil) + (when (and (processp mh-speed-flists-process) + (not (eq (process-status mh-speed-flists-process) 'exit))) + (kill-process mh-speed-flists-process) + (setq mh-speed-flists-process nil))) + (unless mh-speed-flists-timer + (setq mh-speed-flists-timer + (run-at-time + nil mh-speed-flists-interval + (lambda () + (unless (and (processp mh-speed-flists-process) + (not (eq (process-status mh-speed-flists-process) + 'exit))) + (setq mh-speed-flists-process + (start-process (expand-file-name "flists" mh-progs) nil + "flists" "-recurse")) + (set-process-filter mh-speed-flists-process + 'mh-speed-parse-flists-output))))))) + +;; Copied from mh-make-folder-list-filter... +(defun mh-speed-parse-flists-output (process output) + "Parse the incremental results from flists. +PROCESS is the flists process and OUTPUT is the results that must be handled +next." + (let ((prevailing-match-data (match-data)) + (position 0) + line-end line folder unseen total) + (unwind-protect + (while (setq line-end (string-match "\n" output position)) + (setq line (format "%s%s" + mh-speed-partial-line + (substring output position line-end)) + mh-speed-partial-line "") + (when (string-match "+? " line) + (setq folder (format "+%s" (subseq line 0 (match-beginning 0)))) + (when (string-match " has " line) + (setq unseen (car (read-from-string line (match-end 0)))) + (when (string-match "; out of " line) + (setq total (car (read-from-string line (match-end 0)))) + (setf (gethash folder mh-speed-flists-cache) + (cons unseen total)) + (save-excursion + (when (buffer-live-p (get-buffer speedbar-buffer)) + (set-buffer speedbar-buffer) + (speedbar-with-writable + (when (get-text-property (point-min) 'mh-level) + (let ((pos (gethash folder mh-speed-folder-map)) + face) + (when pos + (goto-char pos) + (goto-char (line-beginning-position)) + (cond + ((null (get-text-property (point) 'mh-count)) + (goto-char (line-end-position)) + (setq face (get-text-property (1- (point)) + 'face)) + (insert (format " (%s/%s)" unseen total)) + (mh-speed-highlight 'unknown face) + (goto-char (line-beginning-position)) + (add-text-properties + (point) (1+ (point)) + `(mh-count (,unseen . ,total)))) + ((not + (equal (get-text-property (point) 'mh-count) + (cons unseen total))) + (goto-char (line-end-position)) + (setq face (get-text-property (1- (point)) + 'face)) + (re-search-backward + " " (line-beginning-position) t) + (delete-region (point) (line-end-position)) + (insert (format " (%s/%s)" unseen total)) + (mh-speed-highlight 'unknown face) + (goto-char (line-beginning-position)) + (add-text-properties + (point) (1+ (point)) + `(mh-count (,unseen . ,total)))))))))))))) + (setq position (1+ line-end))) + (set-match-data prevailing-match-data)) + (setq mh-speed-partial-line (subseq output position)))) + +(defun mh-speed-invalidate-map (folder) + "Remove FOLDER from various optimization caches." + (interactive (list "")) + (save-excursion + (set-buffer speedbar-buffer) + (let* ((speedbar-update-flag nil) + (last-slash (search "/" folder :from-end t)) + (parent (if last-slash (substring folder 0 last-slash) nil)) + (parent-position (gethash parent mh-speed-folder-map)) + (parent-change nil)) + (remhash parent mh-speed-folders-cache) + (remhash folder mh-speed-folders-cache) + (when parent-position + (let ((parent-kids (mh-speed-folders parent))) + (cond ((null parent-kids) + (setq parent-change ?+)) + ((and (null (cdr parent-kids)) + (equal (if last-slash + (substring folder (1+ last-slash)) + (substring folder 1)) + (caar parent-kids))) + (setq parent-change ? )))) + (goto-char parent-position) + (when (equal (get-text-property (line-beginning-position) 'mh-folder) + parent) + (when (get-text-property (line-beginning-position) 'mh-expanded) + (mh-speed-toggle)) + (when parent-change + (speedbar-with-writable + (mh-speedbar-change-expand-button-char parent-change) + (add-text-properties + (line-beginning-position) (1+ (line-beginning-position)) + `(mh-children-p ,(equal parent-change ?+))))) + (mh-speed-highlight mh-speed-last-selected-folder + 'mh-speedbar-folder-face) + (setq mh-speed-last-selected-folder nil) + (setq mh-speed-refresh-flag t))) + (when (equal folder "") + (clrhash mh-speed-folders-cache))))) + +(defun mh-speed-add-folder (folder) + "Add FOLDER since it is being created. +The function invalidates the latest ancestor that is present." + (save-excursion + (set-buffer speedbar-buffer) + (let ((speedbar-update-flag nil) + (last-slash (search "/" folder :from-end t)) + (ancestor folder) + (ancestor-pos nil)) + (block while-loop + (while last-slash + (setq ancestor (substring ancestor 0 last-slash)) + (setq ancestor-pos (gethash ancestor mh-speed-folder-map)) + (when ancestor-pos + (return-from while-loop)) + (setq last-slash (search "/" ancestor :from-end t)))) + (unless ancestor-pos (setq ancestor nil)) + (goto-char (or ancestor-pos (gethash nil mh-speed-folder-map))) + (speedbar-with-writable + (mh-speedbar-change-expand-button-char ?+) + (add-text-properties + (line-beginning-position) (1+ (line-beginning-position)) + `(mh-children-p t))) + (when (get-text-property (line-beginning-position) 'mh-expanded) + (mh-speed-toggle)) + (remhash ancestor mh-speed-folders-cache) + (setq mh-speed-refresh-flag t)))) + +;; Make it slightly more general to allow for [ ] buttons to be changed to +;; [+]. +(defun mh-speedbar-change-expand-button-char (char) + "Change the expansion button character to CHAR for the current line." + (save-excursion + (beginning-of-line) + (if (re-search-forward "\\[.\\]" (line-end-position) t) + (speedbar-with-writable + (backward-char 2) + (delete-char 1) + (insert-char char 1 t) + (put-text-property (point) (1- (point)) 'invisible nil) + ;; make sure we fix the image on the text here. + (speedbar-insert-image-button-maybe (- (point) 2) 3))))) + +(provide 'mh-speed) + +;;; Local Variables: +;;; sentence-end-double-space: nil +;;; End: + +;;; mh-speed.el ends here
--- a/lisp/mail/mh-utils.el Fri Nov 29 18:02:52 2002 +0000 +++ b/lisp/mail/mh-utils.el Fri Nov 29 18:15:21 2002 +0000 @@ -1,4 +1,4 @@ -;;; mh-utils.el --- mh-e code needed for both sending and reading +;;; mh-utils.el --- MH-E code needed for both sending and reading ;; Copyright (C) 1993, 1995, 1997, 2000, 2001, 2002 Free Software Foundation, Inc. @@ -26,27 +26,204 @@ ;;; Commentary: -;; Internal support for mh-e package. +;; Internal support for MH-E package. ;;; Change Log: -;; $Id: mh-utils.el,v 1.79 2002/04/07 19:20:56 wohler Exp $ +;; $Id: mh-utils.el,v 1.177 2002/11/22 20:00:47 satyaki Exp $ ;;; Code: +(require 'cl) +(require 'gnus-util) + +;; Shush the byte-compiler +(defvar font-lock-auto-fontify) +(defvar font-lock-defaults) +(defvar mark-active) +(defvar tool-bar-mode) + +(load "mm-decode" t t) ; Non-fatal dependency +(load "mm-view" t t) ; Non-fatal dependency + (load "executable" t t) ; Non-fatal dependency on ; executable-find ;;; Autoload mh-seq - (autoload 'mh-add-to-sequence "mh-seq") (autoload 'mh-notate-seq "mh-seq") (autoload 'mh-read-seq-default "mh-seq") (autoload 'mh-map-to-seq-msgs "mh-seq") -;;; Other Autoloads +;;; Autoload mh-e +(autoload 'mh-goto-cur-msg "mh-e") +(autoload 'mh-update-sequences "mh-e") + +;;; Autoload mh-mime +(autoload 'mh-add-missing-mime-version-header "mh-mime") +(autoload 'mh-mime-cleanup "mh-mime") +(autoload 'mh-buffer-data "mh-mime" nil nil t) +(autoload 'mh-make-buffer-data "mh-mime" nil nil) +(autoload 'mh-mime-display "mh-mime") +(autoload 'mh-display-smileys "mh-mime") +(autoload 'mh-display-emphasis "mh-mime") + +;;; Autoload mh-index +(autoload 'mh-index-search "mh-index" + "Perform an indexed search in an MH mail folder. + +FOLDER is searched with SEARCH-REGEXP and the results are presented in an MH-E +folder. If FOLDER is \"+\" then mail in all folders are searched. Optional +prefix argument NEW-BUFFER-FLAG decides whether the results are presented in a +new buffer. This allows multiple search results to coexist. + +Four indexing programs are supported; if none of these are present, then grep +is used. This function picks the first program that is available on your +system. If you would prefer to use a different program, set the customization +variable `mh-index-program' accordingly. + +The documentation for the following functions describes how to generate the +index for each program: + + - `mh-swish++-execute-search' + - `mh-swish-execute-search' + - `mh-namazu-execute-search' + - `mh-glimpse-execute-search'" + t) +;;; These are here since their docstrings are needed before loading mh-index. +(autoload 'mh-swish++-execute-search "mh-index" + "Execute swish++ and read the results. + +In the examples below, replace /home/user/Mail with the path to your MH +directory. + +First create the directory /home/user/Mail/.swish++. Then create the file +/home/user/Mail/.swish++/swish++.conf with the following contents: + + IncludeMeta Bcc Cc Comments Content-Description From Keywords + IncludeMeta Newsgroups Resent-To Subject To + IncludeFile Mail [0-9]* + IndexFile /home/user/Mail/.swish++/swish++.index + +Use the following command line to generate the swish index. Run this +daily from cron: + + index -c /home/user/Mail/.swish++/swish++.conf /home/user/Mail + +On some systems (Debian GNU/Linux, for example), use index++ instead of index. + +FOLDER-PATH is the directory in which SEARCH-REGEXP is used to search." + t) +(autoload 'mh-swish-execute-search "mh-index" + "Execute swish-e and read the results. + +In the examples below, replace /home/user/Mail with the path to your MH +directory. + +First create the directory /home/user/Mail/.swish. Then create the file +/home/user/Mail/.swish/config with the following contents: + IndexDir /home/user/Mail + IndexFile /home/user/Mail/.swish/index + IndexName \"Mail Index\" + IndexDescription \"Mail Index\" + IndexPointer \"http://nowhere\" + IndexAdmin \"nobody\" + #MetaNames automatic + IndexReport 3 + FollowSymLinks no + UseStemming no + IgnoreTotalWordCountWhenRanking yes + WordCharacters abcdefghijklmnopqrstuvwxyz0123456789- + BeginCharacters abcdefghijklmnopqrstuvwxyz + EndCharacters abcdefghijklmnopqrstuvwxyz0123456789 + IgnoreLimit 50 1000 + IndexComments 0 + FileRules pathname contains /home/user/Mail/.swish + FileRules filename is index + FileRules filename is \..* + FileRules filename is #.* + FileRules filename is ,.* + FileRules filename is .*~ + +If there are any directories you would like to ignore, append lines like the +following to config: + + FileRules pathname contains /home/user/Mail/scripts + +Use the following command line to generate the swish index. Run this +daily from cron: + + swish-e -c /home/user/Mail/.swish/config + +FOLDER-PATH is the directory in which SEARCH-REGEXP is used to search." + t) +(autoload 'mh-namazu-execute-search "mh-index" + "Execute namazu and read the results. + +In the examples below, replace /home/user/Mail with the path to your MH +directory. + +First create the directory /home/user/Mail/.namazu. Then create the file +/home/user/Mail/.namazu/mknmzrc with the following contents: + + package conf; # Don't remove this line! + $ADDRESS = 'user@localhost'; + $ALLOW_FILE = \"[0-9]*\"; + +Use the following command line to generate the namazu index. Run this +daily from cron: + + mknmz -f /home/user/Mail/.namazu/mknmzrc -O /home/user/Mail/.namazu \\ + /home/user/Mail + +FOLDER-PATH is the directory in which SEARCH-REGEXP is used to search." + t) +(autoload 'mh-glimpse-execute-search "mh-index" + "Execute glimpse and read the results. + +In the examples below, replace /home/user/Mail with the path to your MH +directory. + +First create the directory /home/user/Mail/.glimpse. Then create the file +/home/user/Mail/.glimpse/.glimpse_exclude with the following contents: + + */.* + */#* + */,* + */*~ + ^/home/user/Mail/.glimpse + +If there are any directories you would like to ignore, append lines like the +following to .glimpse_exclude: + + ^/home/user/Mail/scripts + +Use the following command line to generate the glimpse index. Run this +daily from cron: + + glimpseindex -H /home/user/Mail/.glimpse /home/user/Mail + +FOLDER-PATH is the directory in which SEARCH-REGEXP is used to search." + t) + +;;; Autoload mh-speed +(autoload 'mh-speed-add-folder "mh-speed") + +;;; Autoload mh-comp +(autoload 'mh-reply "mh-comp" nil t) + +;;; Other Autoloads +(autoload 'gnus-article-highlight-citation "gnus-cite") (autoload 'mail-header-end "sendmail") +(autoload 'Info-goto-node "info") +(autoload 'font-lock-default-fontify-region "font-lock") +(unless (fboundp 'make-hash-table) + (autoload 'make-hash-table "cl")) + +;; Is this XEmacs-land? +(defvar mh-xemacs-flag (featurep 'xemacs) + "Non-nil means the current Emacs is XEmacs.") ;;; Set for local environment: ;;; mh-progs and mh-lib used to be set in paths.el, which tried to @@ -59,16 +236,14 @@ (defvar mh-lib nil "Directory containing the MH library. -This directory contains, among other things, -the components file.") +This directory contains, among other things, the components file.") (defvar mh-lib-progs nil "Directory containing MH helper programs. -This directory contains, among other things, -the mhl program.") +This directory contains, among other things, the mhl program.") -(defvar mh-nmh-p nil - "Non-nil if nmh is installed on this system instead of MH.") +(defvar mh-nmh-flag nil + "Non-nil means nmh is installed on this system instead of MH.") ;;;###autoload (put 'mh-progs 'risky-local-variable t) @@ -77,7 +252,21 @@ ;;;###autoload (put 'mh-lib-progs 'risky-local-variable t) ;;;###autoload -(put 'mh-nmh-p 'risky-local-variable t) +(put 'mh-nmh-flag 'risky-local-variable t) + +;;; Macro to generate correct code for different emacs variants + +(defmacro mh-mark-active-p (check-transient-mark-mode-flag) + "A macro that expands into appropriate code in XEmacs and nil in GNU Emacs. +In GNU Emacs if CHECK-TRANSIENT-MARK-MODE-FLAG is non-nil then check if +variable `transient-mark-mode' is active." + (cond (mh-xemacs-flag ;XEmacs + `(and (boundp 'zmacs-regions) zmacs-regions (region-active-p))) + ((not check-transient-mark-mode-flag) ;GNU Emacs + `(and (boundp 'mark-active) mark-active)) + (t ;GNU Emacs + `(and (boundp 'transient-mark-mode) transient-mark-mode + (boundp 'mark-active) mark-active)))) ;;; User preferences: @@ -86,20 +275,53 @@ :prefix "mh-" :group 'mh) - -(defcustom mh-auto-folder-collect t - "*Whether to start collecting MH folder names immediately in the background. -Non-nil means start a background process collecting the names of all -folders as soon as mh-e is loaded." +(defcustom mh-tool-bar-reply-3-buttons-flag nil + "*Non-nil means use three buttons for reply commands in tool-bar. +If you have room on your tool-bar because you are using a large font, you +may set this variable to expand the single reply button into three buttons +that won't lead to minibuffer prompt about who to reply to." :type 'boolean :group 'mh) -(defcustom mh-recursive-folders nil - "*If non-nil, then commands which operate on folders do so recursively." +(defcustom mh-tool-bar-search-function 'mh-search-folder + "*Function called by the tool-bar search button. +See `mh-search-folder' and `mh-index-search' for details." + :type '(choice (const mh-search-folder) + (const mh-index-search) + (function :tag "Other function")) + :group 'mh) + +(defcustom mh-decode-mime-flag (not (not (locate-library "mm-decode"))) + "*Non-nil means that Gnus is used to show MIME attachments with Gnus." + :type 'boolean + :group 'mh-buffer) + +(defcustom mh-auto-folder-collect-flag t + "*Non-nil means immediate collect folder names in the background. +If t, MH-E should start a background process to collect the names of all +folders as soon as MH-E is first used." :type 'boolean :group 'mh) -(defcustom mh-clean-message-header t +(defcustom mh-recursive-folders-flag nil + "*Non-nil means that commands which operate on folders do so recursively." + :type 'boolean + :group 'mh) + +(defcustom mh-adaptive-cmd-note-flag t + "*Non-nil means that the message number width is determined dynamically. +This is done once when a folder is first opened by running scan on the last +message of the folder. The message number for the last message is extracted +and its width calculated. This width is used when calling `mh-set-cmd-note'. + +If you prefer fixed-width message numbers, set this variable to nil and call +`mh-set-cmd-note' with the width specified by the scan format in +`mh-scan-format-file'. For example, the default width is 4, so you would use +\"(mh-set-cmd-note 4)\" if `mh-scan-format-file' were nil." + :type 'boolean + :group 'mh) + +(defcustom mh-clean-message-header-flag t "*Non-nil means clean headers of messages that are displayed or inserted. The variables `mh-visible-headers' and `mh-invisible-headers' control what is removed." @@ -107,74 +329,113 @@ :group 'mh-buffer) (defcustom mh-visible-headers nil - "*If non-nil, contains a regexp specifying the headers to keep when cleaning. -Only used if `mh-clean-message-header' is non-nil. Setting this variable + "*Contains a regexp specifying the headers to keep when cleaning. +Only used if `mh-clean-message-header-flag' is non-nil. Setting this variable overrides `mh-invisible-headers'." :type '(choice (const nil) regexp) :group 'mh-buffer) +(defcustom mh-show-use-xface-flag (and window-system + (not (null (cond + (mh-xemacs-flag + (locate-library "x-face")) + ((>= emacs-major-version 21) + (locate-library "x-face-e21")) + (t ;Emacs20 + nil)))) + (not (null (and (fboundp 'executable-find) + (executable-find + "uncompface"))))) + "*Non-nil means display faces in `mh-show-mode' with external x-face package. +It is available from ftp://ftp.jpl.org/pub/elisp/. Download it and put its +files in the Emacs `load-path' and MH-E will invoke it automatically for you if +this variable is non-nil. + +The `uncompface' binary is also required to be in the execute PATH. It can +be obtained from: ftp://ftp.cs.indiana.edu/pub/faces/compface/compface.tar.Z" + :type 'boolean + :group 'mh-buffer) + +(defcustom mh-show-maximum-size 0 + "*Maximum size of message (in bytes) to display automatically. +Provides an opportunity to skip over large messages which may be slow to load. +Use a value of 0 to display all messages automatically regardless of size." + :type 'integer + :group 'mh-buffer) + (defvar mh-invisible-headers (concat "^" (let ((max-specpdl-size 1000)) ;workaround for insufficient default (regexp-opt - '( ;; RFC 822 - "Received: " "Message-Id: " "Return-Path: " - ;; RFC 2045 - "Mime-Version" "Content-" - ;; sendmail - "X-Authentication-Warning: " "X-MIME-Autoconverted: " "From " - "Status: " - ;; X400 - "X400-" "P1-Message-Id: " "Original-Encoded-Information-Types: " - "P1-Recipient: " "P1-Content-Type: " "Ua-Content-Id: " - ;; MH - "Resent" "Prev-Resent" "Forwarded: " "Replied: " "Delivery-Date: " - "In-Reply-To: " "Remailed-" "Via: " "Mail-from: " - ;; gnus - "X-Gnus-Mail-Source: " - ;; MS Outlook - "X-Priority: " "X-Msmail-" "X-MimeOLE: " "X-Apparently-From: " - "Importance: " "Sensitivity: " "X-MS-TNEF-Correlator: " - ;; Juno - "X-Juno-" - ;; Hotmail - "X-OriginalArrivalTime: " "X-Originating-IP: " - ;; Netscape/Mozilla - "X-Accept-Language: " "X-Mozilla-Status: " - ;; NTMail - "X-Info: " "X-VSMLoop: " - ;; News - "NNTP-" "X-News: " - ;; Mailman mailing list manager - "List-" "X-Beenthere: " "X-Mailman-Version: " - ;; Egroups/yahoogroups mailing list manager - "X-eGroups-" "X-Apparently-To: " "Mailing-List: " "Delivered-To: " - ;; SourceForge mailing list manager - "X-Original-Date: " - ;; Unknown mailing list managers - "X-Mailing-List: " "X-Loop: " - "List-Subscribe: " "List-Unsubscribe: " - "X-List-Subscribe: " "X-List-Unsubscribe: " - "X-Listserver: " "List-" "X-List-Host: " - ;; Sieve filtering - "X-Sieve: " - ;; Worldtalk gateways - "X-Wss-Id: " - ;; User added - "X-Face: " "X-Qotd-" - ;; Miscellaneous - "X-Sender: " "X-Ack: " "Errors-To: " "Precedence: " "X-Message-Id" - "X-From-Line" "X-Cron-Env: " "Delivery: " "X-Delivered" - "X-Received: " "X-Vms-To: " "Xref: " "X-Request-" "X-UIDL: " - "X-Orcl-Content-Type: " "X-Server-Uuid: " "X-Envelope-Sender: " - "X-Envelope-To: " "Encoding: " "Old-Return-Path: " "Path: " - "References: " "Lines: " "Autoforwarded: " "Bestservhost: " - "X-pgp: " "X-Accept-Language: " "Priority: " "User-Agent: " - "X-MIMETrack: " "X-Abuse-Info: " "X-Complaints-To: " - "X-No-Archive: " "X-Original-Complaints-To: " - "X-Original-Trace: " "X-Received-Date: " "X-Server-Date: " - "X-Trace: " "X-UserInfo1: " "X-submission-address: ") + (append + (if (not mh-show-use-xface-flag) + '("X-Face: ")) + '( ;; RFC 822 + "Received: " "Message-Id: " "Return-Path: " + ;; RFC 2045 + "Mime-Version" "Content-" + ;; sendmail + "X-Authentication-Warning: " "X-MIME-Autoconverted: " "From " + "Status: " + ;; X400 + "X400-" "P1-Message-Id: " "Original-Encoded-Information-Types: " + "P1-Recipient: " "P1-Content-Type: " "Ua-Content-Id: " + ;; MH + "Resent" "Prev-Resent" "Forwarded: " "Replied: " "Delivery-Date: " + "In-Reply-To: " "Remailed-" "Via: " "Mail-from: " + ;; gnus + "X-Gnus-Mail-Source: " + ;; MS Outlook + "X-Priority: " "X-Msmail-" "X-MimeOLE: " "X-Apparently-From: " + "Importance: " "Sensitivity: " "X-MS-TNEF-Correlator: " + ;; Juno + "X-Juno-" + ;; Hotmail + "X-OriginalArrivalTime: " "X-Originating-IP: " + ;; Netscape/Mozilla + "X-Accept-Language: " "X-Mozilla-Status: " + ;; NTMail + "X-Info: " "X-VSMLoop: " + ;; News + "NNTP-" "X-News: " + ;; Mailman mailing list manager + "List-" "X-Beenthere: " "X-Mailman-Version: " + ;; Egroups/yahoogroups mailing list manager + "X-eGroups-" "X-Apparently-To: " "Mailing-List: " "Delivered-To: " + ;; SourceForge mailing list manager + "X-Original-Date: " + ;; Unknown mailing list managers + "X-Mailing-List: " "X-Loop: " + "List-Subscribe: " "List-Unsubscribe: " + "X-List-Subscribe: " "X-List-Unsubscribe: " + "X-Listserver: " "List-" "X-List-Host: " + ;; Sieve filtering + "X-Sieve: " + ;; Spam + "X-Spam-Status: " "X-Spam-Level: " "X-Spam-Score: " + "X-SpamBouncer: " "X-SBClass: " "X-SBRule: " "X-SBNote: " + "X-SBPass: " "X-Folder: " + "X-Habeas-SWE-1: " "X-Habeas-SWE-2: " "X-Habeas-SWE-3: " + "X-Habeas-SWE-4: " "X-Habeas-SWE-5: " "X-Habeas-SWE-6: " + "X-Habeas-SWE-7: " "X-Habeas-SWE-8: " "X-Habeas-SWE-9: " + ;; Worldtalk gateways + "X-Wss-Id: " + ;; User added + "X-Qotd-" + ;; Miscellaneous + "X-Sender: " "X-Ack: " "Errors-To: " "Precedence: " "X-Message-Id" + "X-From-Line" "X-Cron-Env: " "Delivery: " "X-Delivered" + "X-Received: " "X-Vms-To: " "Xref: " "X-Request-" "X-UIDL: " + "X-Orcl-Content-Type: " "X-Server-Uuid: " "X-Envelope-Sender: " + "X-Envelope-To: " "Encoding: " "Old-Return-Path: " "Path: " + "References: " "Lines: " "Autoforwarded: " "Bestservhost: " + "X-pgp: " "X-Accept-Language: " "Priority: " "User-Agent: " + "X-MIMETrack: " "X-Abuse-Info: " "X-Complaints-To: " + "X-No-Archive: " "X-Original-Complaints-To: " + "X-Original-Trace: " "X-Received-Date: " "X-Server-Date: " + "X-Trace: " "X-UserInfo1: " "X-submission-address: " + "X-Scanned-By")) t))) "*Regexp matching lines in a message header that are not to be shown. If `mh-visible-headers' is non-nil, it is used instead to specify what @@ -183,7 +444,7 @@ ;;; Additional header fields that might someday be added: ;;; "Sender: " "Reply-to: " -(defcustom mh-bury-show-buffer t +(defcustom mh-bury-show-buffer-flag t "*Non-nil means that the displayed show buffer for a folder is buried." :type 'boolean :group 'mh-buffer) @@ -198,9 +459,9 @@ ;; Use goto-addr if it was already loaded (which probably sets this ;; variable to t), or if this variable is otherwise set to t. -(defcustom mh-show-use-goto-addr (and (boundp 'goto-address-highlight-p) - goto-address-highlight-p) - "*Non-nil means URLs and e-mail addresses are highlighted using goto-addr while in mh-show-mode." +(defcustom mh-show-use-goto-addr-flag (and (boundp 'goto-address-highlight-p) + goto-address-highlight-p) + "*Non-nil means URLs and e-mail addresses are highlighted using goto-addr while in `mh-show-mode'." :type 'boolean :group 'mh-buffer) @@ -208,17 +469,29 @@ "Regexp to find the number of a message in a scan line. The message's number must be surrounded with \\( \\)") +(defvar mh-scan-msg-overflow-regexp "^\\?[0-9]" + "Regexp to find a scan line in which the message number overflowed. +The message's number is left truncated in this case.") + +(defvar mh-scan-msg-format-regexp "%\\([0-9]*\\)(msg)" + "Regexp to find message number width in an scan format. +The message number width must be surrounded with \\( \\).") + +(defvar mh-scan-msg-format-string "%d" + "Format string for width of the message number in a scan format. +Use `0%d' for zero-filled message numbers.") + (defvar mh-scan-msg-search-regexp "^[^0-9]*%d[^0-9]" "Format string containing a regexp matching the scan listing for a message. The desired message's number will be an argument to format.") (defcustom mhl-formfile nil "*Name of format file to be used by mhl to show and print messages. -A value of T means use the default format file. -Nil means don't use mhl to format messages when showing; mhl is still used, +A value of t means use the default format file. +nil means don't use mhl to format messages when showing; mhl is still used, with the default format file, to format messages when printing them. The format used should specify a non-zero value for overflowoffset so -the message continues to conform to RFC 822 and mh-e can parse the headers." +the message continues to conform to RFC 822 and MH-E can parse the headers." :type '(choice (const nil) (const t) string) :group 'mh) (put 'mhl-formfile 'info-file "mh-e") @@ -226,24 +499,30 @@ (defvar mh-decode-quoted-printable-have-mimedecode (not (null (and (fboundp 'executable-find)(executable-find "mimedecode")))) "Whether the mimedecode command is installed on the system. -This sets the default value of variable `mh-decode-quoted-printable' to -determine whether quoted-printable MIME parts are decode when viewed in -`mh-show'. The source code for mimedecode can be obtained from -http://www.freesoft.org/CIE/FAQ/mimedeco.c") +This sets the default value of variable `mh-decode-quoted-printable-flag' to +determine whether quoted-printable MIME parts are decoded by the mimedecode +command when viewed in `mh-show'. The source code for mimedecode can be +obtained from http://www.freesoft.org/CIE/FAQ/mimedeco.c") -(defcustom mh-decode-quoted-printable +(defcustom mh-decode-quoted-printable-flag mh-decode-quoted-printable-have-mimedecode - "Whether to decode quoted-printable MIME parts in `mh-show'. -This can only be done if the 'mimedecode' command is available in the -executable path on the system (the mh-decode-quoted-printable-have-mimedecode -variable is set if the command was found). That program is used as a helper -program to achieve this. The source code for mimedecode can usually be -obtained from http://www.freesoft.org/CIE/FAQ/mimedeco.c" + "Non-nil means decode quoted-printable MIME part using mimedecode. + +Determine whether to decode quoted-printable MIME parts in `mh-show' +using mimedecode. + +Quoted printable content is translated to 8-bit characters in `mh-show' by +the gnus' mm-decode library if it is available. Otherwise (and for certain +cases mm-decode can't handle) this can be done using the 'mimedecode' +command. Setting this variable indicates to use 'mimedecode' when +mm-decode is not available or as a helper to it. The source code for +mimedecode can usually be obtained from +http://www.freesoft.org/CIE/FAQ/mimedeco.c" :type 'boolean :group 'mh-buffer) -(defcustom mh-update-sequences-after-mh-show t - "Whether to call `mh-update-sequence' in `mh-show-mode'. +(defcustom mh-update-sequences-after-mh-show-flag t + "*Non-nil means `mh-update-sequence' is called from `mh-show-mode'. If set, `mh-update-sequence' is run every time a message is shown, telling MH or nmh that this is your current message. It's useful, for example, to display MIME content using \"M-! mhshow RET\"" @@ -266,22 +545,21 @@ `save-excursion', with point at the start of the message. It should return the folder to offer as the refile or Fcc folder, as a string with a leading `+' sign. It can also return an empty string to use no -default, or NIL to calculate the default the usual way. +default, or nil to calculate the default the usual way. NOTE: This variable is not an ordinary hook; It may not be a list of functions.") -(defvar mh-find-path-hook nil - "Invoked by `mh-find-path' while reading the user's MH profile.") - -(defvar mh-folder-list-change-hook nil - "Invoked whenever the cached folder list `mh-folder-list' is changed.") - (defvar mh-show-buffer-mode-line-buffer-id "{show-%s} %d" "Format string to produce `mode-line-buffer-identification' for show buffers. First argument is folder name. Second is message number.") (defvar mh-cmd-note 4 - "Offset to insert notation.") + "Column to insert notation. +Use `mh-set-cmd-note' to modify it. +This value may be dynamically updated if `mh-adaptive-cmd-note-flag' is +non-nil and `mh-scan-format-file' is t. +Note that the first column is column number 0.") +(make-variable-buffer-local 'mh-cmd-note) (defvar mh-note-seq "%" "String whose first character is used to notate messages in a sequence.") @@ -297,13 +575,139 @@ passed through `regexp-quote' before being used by functions like `re-search-forward'.") +;;; Hooks + +(defcustom mh-find-path-hook nil + "Invoked by `mh-find-path' after reading the user's MH profile." + :type 'hook + :group 'mh-hook) + +(defcustom mh-show-hook nil + "Invoked after \\<mh-folder-mode-map>`\\[mh-show]' shows a message." + :type 'hook + :group 'mh-hook) + +(defcustom mh-show-mode-hook nil + "Invoked upon entry to `mh-show-mode'." + :type 'hook + :group 'mh-hook) + +;; Variables for MIME display +(defvar mh-globals-hash (make-hash-table) + "Keeps track of MIME data on a per buffer basis.") + +(defvar mh-gnus-pgp-support-flag (not (not (locate-library "mml2015"))) + "Non-nil means installed Gnus has PGP support.") + +(defvar mh-mm-inline-media-tests + `(("image/jpeg" + mm-inline-image + (lambda (handle) + (mm-valid-and-fit-image-p 'jpeg handle))) + ("image/png" + mm-inline-image + (lambda (handle) + (mm-valid-and-fit-image-p 'png handle))) + ("image/gif" + mm-inline-image + (lambda (handle) + (mm-valid-and-fit-image-p 'gif handle))) + ("image/tiff" + mm-inline-image + (lambda (handle) + (mm-valid-and-fit-image-p 'tiff handle)) ) + ("image/xbm" + mm-inline-image + (lambda (handle) + (mm-valid-and-fit-image-p 'xbm handle))) + ("image/x-xbitmap" + mm-inline-image + (lambda (handle) + (mm-valid-and-fit-image-p 'xbm handle))) + ("image/xpm" + mm-inline-image + (lambda (handle) + (mm-valid-and-fit-image-p 'xpm handle))) + ("image/x-pixmap" + mm-inline-image + (lambda (handle) + (mm-valid-and-fit-image-p 'xpm handle))) + ("image/bmp" + mm-inline-image + (lambda (handle) + (mm-valid-and-fit-image-p 'bmp handle))) + ("image/x-portable-bitmap" + mm-inline-image + (lambda (handle) + (mm-valid-and-fit-image-p 'pbm handle))) + ("text/plain" mm-inline-text identity) + ("text/enriched" mm-inline-text identity) + ("text/richtext" mm-inline-text identity) + ("text/x-patch" mm-display-patch-inline + (lambda (handle) + (locate-library "diff-mode"))) + ("application/emacs-lisp" mm-display-elisp-inline identity) + ("application/x-emacs-lisp" mm-display-elisp-inline identity) + ("text/html" + ,(if (fboundp 'mm-inline-text-html) 'mm-inline-text-html 'mm-inline-text) + (lambda (handle) + (or (and (boundp 'mm-inline-text-html-renderer) + mm-inline-text-html-renderer) + (and (boundp 'mm-text-html-renderer) mm-text-html-renderer)))) + ("text/x-vcard" + mm-inline-text-vcard + (lambda (handle) + (or (featurep 'vcard) + (locate-library "vcard")))) + ("message/delivery-status" mm-inline-text identity) + ("message/rfc822" mh-mm-inline-message identity) + ;("message/partial" mm-inline-partial identity) + ;("message/external-body" mm-inline-external-body identity) + ("text/.*" mm-inline-text identity) + ("audio/wav" mm-inline-audio + (lambda (handle) + (and (or (featurep 'nas-sound) (featurep 'native-sound)) + (device-sound-enabled-p)))) + ("audio/au" + mm-inline-audio + (lambda (handle) + (and (or (featurep 'nas-sound) (featurep 'native-sound)) + (device-sound-enabled-p)))) + ("application/pgp-signature" ignore identity) + ("application/x-pkcs7-signature" ignore identity) + ("application/pkcs7-signature" ignore identity) + ("application/x-pkcs7-mime" ignore identity) + ("application/pkcs7-mime" ignore identity) + ("multipart/alternative" ignore identity) + ("multipart/mixed" ignore identity) + ("multipart/related" ignore identity) + ;; Disable audio and image + ("audio/.*" ignore ignore) + ("image/.*" ignore ignore) + ;; Default to displaying as text + (".*" mm-inline-text mm-readable-p)) + "Alist of media types/tests saying whether types can be displayed inline.") + +;; Needed by mh-comp.el and mh-mime.el +(defvar mh-mhn-compose-insert-flag nil + "Non-nil means MIME insertion was done. +Triggers an automatic call to `mh-edit-mhn' in `mh-send-letter'. +This variable is buffer-local.") +(make-variable-buffer-local 'mh-mhn-compose-insert-flag) + +(defvar mh-mml-compose-insert-flag nil + "Non-nil means that a MIME insertion was done. +This buffer-local variable is used to remember if a MIME insertion was done. +Triggers an automatic call to `mh-mml-to-mime' in `mh-send-letter'.") +(make-variable-buffer-local 'mh-mml-compose-insert-flag) + (defun mh-in-header-p () - ;; Return non-nil if the point is in the header of a draft message. + "Return non-nil if the point is in the header of a draft message." (< (point) (mail-header-end))) (defun mh-header-field-end () - ;; Move to the end of the current header field. - ;; Handles RFC 822 continuation lines. + "Move to the end of the current header field. +Handles RFC 822 continuation lines." (forward-line 1) (while (looking-at "^[ \t]") (forward-line 1)) @@ -341,12 +745,18 @@ t))))) (defun mh-header-to-font-lock (limit) + "Return the value of a header field To to font-lock. +Argument LIMIT limits search." (mh-header-field-font-lock "To:" limit)) (defun mh-header-cc-font-lock (limit) + "Return the value of a header field cc to font-lock. +Argument LIMIT limits search." (mh-header-field-font-lock "cc:" limit)) (defun mh-header-subject-font-lock (limit) + "Return the value of a header field Subject to font-lock. +Argument LIMIT limits search." (mh-header-field-font-lock "Subject:" limit)) (defvar mh-show-to-face 'mh-show-to-face @@ -393,68 +803,122 @@ "Face for highlighting the Subject header field.") (copy-face 'mh-folder-subject-face 'mh-show-subject-face) -(eval-after-load "font-lock" - '(progn - (defvar mh-show-cc-face 'mh-show-cc-face - "Face for highlighting cc header fields.") - (copy-face 'font-lock-variable-name-face 'mh-show-cc-face) - (defvar mh-show-date-face 'mh-show-date-face - "Face for highlighting the Date header field.") - (copy-face 'font-lock-type-face 'mh-show-date-face) - (defvar mh-show-header-face 'mh-show-header-face - "Face used to deemphasize unspecified header fields.") - (copy-face 'font-lock-string-face 'mh-show-header-face) - - (defvar mh-show-font-lock-keywords - '(("^\\(From:\\|Sender:\\)\\(.*\\)" - (1 'default) (2 mh-show-from-face)) - (mh-header-to-font-lock - (0 'default) (1 mh-show-to-face)) - (mh-header-cc-font-lock - (0 'default) (1 mh-show-cc-face)) - ("^\\(Reply-To:\\|Return-Path:\\)\\(.*\\)$" - (1 'default) (2 mh-show-from-face)) - (mh-header-subject-font-lock - (0 'default) (1 mh-show-subject-face)) - ("^\\(Apparently-To:\\|Newsgroups:\\)\\(.*\\)" - (1 'default) (2 mh-show-cc-face)) - ("^\\(In-reply-to\\|Date\\):\\(.*\\)$" - (1 'default) (2 mh-show-date-face)) - (mh-letter-header-font-lock (0 mh-show-header-face append t))) - "Additional expressions to highlight in MH-show mode.") - - (defvar mh-show-font-lock-keywords-with-cite - (eval-when-compile - (let* ((cite-chars "[>|}]") - (cite-prefix "A-Za-z") - (cite-suffix (concat cite-prefix "0-9_.@-`'\""))) - (append - mh-show-font-lock-keywords - (list - ;; Use MATCH-ANCHORED to effectively anchor the regexp left side. - `(,cite-chars - (,(concat "\\=[ \t]*" - "\\(\\([" cite-prefix "]+[" cite-suffix "]*\\)?" - "\\(" cite-chars "[ \t]*\\)\\)+" - "\\(.*\\)") - (beginning-of-line) (end-of-line) - (2 font-lock-constant-face nil t) - (4 font-lock-comment-face nil t))))))) - "Additional expressions to highlight in MH-show mode.") - )) +(defvar mh-show-cc-face 'mh-show-cc-face + "Face for highlighting cc header fields.") +(defface mh-show-cc-face + '((((type tty) (class color)) (:foreground "yellow" :weight light)) + (((class grayscale) (background light)) + (:foreground "Gray90" :bold t :italic t)) + (((class grayscale) (background dark)) + (:foreground "DimGray" :bold t :italic t)) + (((class color) (background light)) (:foreground "DarkGoldenrod")) + (((class color) (background dark)) (:foreground "LightGoldenrod")) + (t (:bold t :italic t))) + "Face for highlighting cc header fields." + :group 'mh-buffer) + +(defvar mh-show-date-face 'mh-show-date-face + "Face for highlighting the Date header field.") +(defface mh-show-date-face + '((((type tty) (class color)) (:foreground "green")) + (((class grayscale) (background light)) (:foreground "Gray90" :bold t)) + (((class grayscale) (background dark)) (:foreground "DimGray" :bold t)) + (((class color) (background light)) (:foreground "ForestGreen")) + (((class color) (background dark)) (:foreground "PaleGreen")) + (t (:bold t :underline t))) + "Face for highlighting the Date header field." + :group 'mh-buffer) + +(defvar mh-show-header-face 'mh-show-header-face + "Face used to deemphasize unspecified header fields.") +(defface mh-show-header-face + '((((type tty) (class color)) (:foreground "green")) + (((class grayscale) (background light)) (:foreground "DimGray" :italic t)) + (((class grayscale) (background dark)) (:foreground "LightGray" :italic t)) + (((class color) (background light)) (:foreground "RosyBrown")) + (((class color) (background dark)) (:foreground "LightSalmon")) + (t (:italic t))) + "Face used to deemphasize unspecified header fields." + :group 'mh-buffer) + +(eval-and-compile + ;; Otherwise byte-compilation fails on `mh-show-font-lock-keywords-with-cite' + (defvar mh-show-font-lock-keywords + '(("^\\(From:\\|Sender:\\)\\(.*\\)" (1 'default) (2 mh-show-from-face)) + (mh-header-to-font-lock (0 'default) (1 mh-show-to-face)) + (mh-header-cc-font-lock (0 'default) (1 mh-show-cc-face)) + ("^\\(Reply-To:\\|Return-Path:\\)\\(.*\\)$" + (1 'default) (2 mh-show-from-face)) + (mh-header-subject-font-lock (0 'default) (1 mh-show-subject-face)) + ("^\\(Apparently-To:\\|Newsgroups:\\)\\(.*\\)" + (1 'default) (2 mh-show-cc-face)) + ("^\\(In-reply-to\\|Date\\):\\(.*\\)$" + (1 'default) (2 mh-show-date-face)) + (mh-letter-header-font-lock (0 mh-show-header-face append t))) + "Additional expressions to highlight in MH-show mode.")) + +(defvar mh-show-font-lock-keywords-with-cite + (eval-when-compile + (let* ((cite-chars "[>|}]") + (cite-prefix "A-Za-z") + (cite-suffix (concat cite-prefix "0-9_.@-`'\""))) + (append + mh-show-font-lock-keywords + (list + ;; Use MATCH-ANCHORED to effectively anchor the regexp left side. + `(,cite-chars + (,(concat "\\=[ \t]*" + "\\(\\([" cite-prefix "]+[" cite-suffix "]*\\)?" + "\\(" cite-chars "[ \t]*\\)\\)+" + "\\(.*\\)") + (beginning-of-line) (end-of-line) + (2 font-lock-constant-face nil t) + (4 font-lock-comment-face nil t))))))) + "Additional expressions to highlight in MH-show mode.") + +(defun mh-show-font-lock-fontify-region (beg end loudly) + "Limit font-lock in `mh-show-mode' to the header. +Used when `mh-highlight-citation-p' is set to gnus, leaving the body to be +dealt with by gnus highlighting. The region between BEG and END is +given over to be fontified and LOUDLY controls if a user sees a +message about the fontification operation." + (let ((header-end (mail-header-end))) + (cond + ((and (< beg header-end)(< end header-end)) + (font-lock-default-fontify-region beg end loudly)) + ((and (< beg header-end)(>= end header-end)) + (font-lock-default-fontify-region beg header-end loudly)) + (t + nil)))) + +;; Needed to help shush the byte-compiler. +(if mh-xemacs-flag + (progn + (eval-and-compile + (require 'gnus) + (require 'gnus-art) + (require 'gnus-cite)))) (defun mh-gnus-article-highlight-citation () "Highlight cited text in current buffer using gnus." (interactive) - (require 'gnus-cite) - (let ((modified (buffer-modified-p)) - (gnus-article-buffer (buffer-name)) - (gnus-cite-face-list - '(gnus-cite-face-2 gnus-cite-face-3 gnus-cite-face-4 gnus-cite-face-5 - gnus-cite-face-6 gnus-cite-face-7 gnus-cite-face-8 gnus-cite-face-9 - gnus-cite-face-10 gnus-cite-face-11 gnus-cite-face-1))) - (gnus-article-highlight-citation t) - (set-buffer-modified-p modified))) + ;; Requiring gnus-cite should have been sufficient. However for Emacs21.1, + ;; recursive-load-depth-limit is only 10, so an error occurs. Also it may be + ;; better to have an autoload at top-level (though that won't work because + ;; of recursive-load-depth-limit). That gets rid of a compiler warning as + ;; well. + (unless mh-xemacs-flag + (require 'gnus-art) + (require 'gnus-cite)) + ;; Don't allow Gnus to create buttons while highlighting, maybe this is bad + ;; style? + (flet ((gnus-article-add-button (&rest args) nil)) + (let* ((modified (buffer-modified-p)) + (gnus-article-buffer (buffer-name)) + (gnus-cite-face-list `(,@(cdr gnus-cite-face-list) + ,(car gnus-cite-face-list)))) + (gnus-article-highlight-citation t) + (set-buffer-modified-p modified)))) ;;; Internal bookkeeping variables: @@ -467,7 +931,7 @@ ;; User's mail folder directory. (defvar mh-user-path nil) -;; An mh-draft-folder of NIL means do not use a draft folder. +;; An mh-draft-folder of nil means do not use a draft folder. ;; Cached value of the `Draft-Folder:' component in the user's MH profile. ;; Name of folder containing draft messages. (defvar mh-draft-folder nil) @@ -486,20 +950,20 @@ ;; Name of the Inbox folder. (defvar mh-inbox nil) -;; Name of mh-e scratch buffer. +;; Name of MH-E scratch buffer. (defconst mh-temp-buffer " *mh-temp*") -;; Name of the mh-e folder list buffer. +;; Name of the MH-E folder list buffer. (defconst mh-temp-folders-buffer "*Folders*") -;; Name of the mh-e sequences list buffer. +;; Name of the MH-E sequences list buffer. (defconst mh-temp-sequences-buffer "*Sequences*") -;; Window configuration before mh-e command. +;; Window configuration before MH-E command. (defvar mh-previous-window-config nil) ;;Non-nil means next SPC or whatever goes to next undeleted message. -(defvar mh-page-to-next-msg-p nil) +(defvar mh-page-to-next-msg-flag nil) ;;; Internal variables local to a folder. @@ -518,6 +982,12 @@ ;; If non-nil, show the message in a separate window. (defvar mh-showing-mode nil) +(defvar mh-show-mode-map (make-sparse-keymap) + "Keymap used by the show buffer.") + +(defvar mh-show-folder-buffer nil + "Keeps track of folder whose message is being displayed.") + ;;; This holds a documentation string used by describe-mode. (defun mh-showing-mode (&optional arg) "Change whether messages should be displayed. @@ -539,15 +1009,15 @@ (defvar mh-showing-with-headers nil) -;;; mh-e macros +;;; MH-E macros -(defmacro with-mh-folder-updating (save-modification-flag-p &rest body) - ;; Format is (with-mh-folder-updating (SAVE-MODIFICATION-FLAG-P) &body BODY). - ;; Execute BODY, which can modify the folder buffer without having to - ;; worry about file locking or the read-only flag, and return its result. - ;; If SAVE-MODIFICATION-FLAG-P is non-nil, the buffer's modification - ;; flag is unchanged, otherwise it is cleared. - (setq save-modification-flag-p (car save-modification-flag-p)) ; CL style +(defmacro with-mh-folder-updating (save-modification-flag &rest body) + "Format is (with-mh-folder-updating (SAVE-MODIFICATION-FLAG) &body BODY). +Execute BODY, which can modify the folder buffer without having to +worry about file locking or the read-only flag, and return its result. +If SAVE-MODIFICATION-FLAG is non-nil, the buffer's modification +flag is unchanged, otherwise it is cleared." + (setq save-modification-flag (car save-modification-flag)) ; CL style `(prog1 (let ((mh-folder-updating-mod-flag (buffer-modified-p)) (buffer-read-only nil) @@ -556,19 +1026,19 @@ (progn ,@body) (mh-set-folder-modified-p mh-folder-updating-mod-flag))) - ,@(if (not save-modification-flag-p) + ,@(if (not save-modification-flag) '((mh-set-folder-modified-p nil))))) (put 'with-mh-folder-updating 'lisp-indent-hook 1) (defmacro mh-in-show-buffer (show-buffer &rest body) - ;; Format is (mh-in-show-buffer (SHOW-BUFFER) &body BODY). - ;; Display buffer SHOW-BUFFER in other window and execute BODY in it. - ;; Stronger than save-excursion, weaker than save-window-excursion. + "Format is (mh-in-show-buffer (SHOW-BUFFER) &body BODY). +Display buffer SHOW-BUFFER in other window and execute BODY in it. +Stronger than `save-excursion', weaker than `save-window-excursion'." (setq show-buffer (car show-buffer)) ; CL style `(let ((mh-in-show-buffer-saved-window (selected-window))) (switch-to-buffer-other-window ,show-buffer) - (if mh-bury-show-buffer (bury-buffer (current-buffer))) + (if mh-bury-show-buffer-flag (bury-buffer (current-buffer))) (unwind-protect (progn ,@body) @@ -576,54 +1046,543 @@ (put 'mh-in-show-buffer 'lisp-indent-hook 1) -(defmacro mh-make-seq (name msgs) (list 'cons name msgs)) +(defmacro mh-make-seq (name msgs) + "Create sequence NAME with the given MSGS." + (list 'cons name msgs)) + +(defmacro mh-seq-name (sequence) + "Extract sequence name from the given SEQUENCE." + (list 'car sequence)) + +(defmacro mh-seq-msgs (sequence) + "Extract messages from the given SEQUENCE." + (list 'cdr sequence)) + +(defun mh-recenter (arg) + "Like recenter but with three improvements: +- At the end of the buffer it tries to show fewer empty lines. +- operates only if the current buffer is in the selected window. + (Commands like `save-some-buffers' can make this false.) +- nil ARG means recenter as if prefix argument had been given." + (cond ((not (eq (get-buffer-window (current-buffer)) (selected-window))) + nil) + ((= (point-max) (save-excursion + (forward-line (- (/ (window-height) 2) 2)) + (point))) + (let ((lines-from-end 2)) + (save-excursion + (while (> (point-max) (progn (forward-line) (point))) + (incf lines-from-end))) + (recenter (- lines-from-end)))) + ;; '(4) is the same as C-u prefix argument. + (t (recenter (or arg '(4)))))) + +(defun mh-start-of-uncleaned-message () + "Position uninteresting headers off the top of the window." + (let ((case-fold-search t)) + (re-search-forward + "^To:\\|^Cc:\\|^From:\\|^Subject:\\|^Date:" nil t) + (beginning-of-line) + (mh-recenter 0))) + +(defun mh-invalidate-show-buffer () + "Invalidate the show buffer so we must update it to use it." + (if (get-buffer mh-show-buffer) + (save-excursion + (set-buffer mh-show-buffer) + (mh-unvisit-file)))) + +(defun mh-unvisit-file () + "Separate current buffer from the message file it was visiting." + (or (not (buffer-modified-p)) + (null buffer-file-name) ;we've been here before + (yes-or-no-p (format "Message %s modified; flush changes? " + (file-name-nondirectory buffer-file-name))) + (error "Flushing changes not confirmed")) + (clear-visited-file-modtime) + (unlock-buffer) + (setq buffer-file-name nil)) + +(defun mh-get-msg-num (error-if-no-message) + "Return the message number of the displayed message. +If the argument ERROR-IF-NO-MESSAGE is non-nil, then complain if the cursor is +not pointing to a message." + (save-excursion + (beginning-of-line) + (cond ((looking-at mh-scan-msg-number-regexp) + (string-to-int (buffer-substring (match-beginning 1) + (match-end 1)))) + (error-if-no-message + (error "Cursor not pointing to message")) + (t nil)))) + +(defun mh-folder-name-p (name) + "Return non-nil if NAME is the name of a folder. +A name (a string or symbol) can be a folder name if it begins with \"+\"." + (if (symbolp name) + (eq (aref (symbol-name name) 0) ?+) + (and (> (length name) 0) + (eq (aref name 0) ?+)))) + + +(defun mh-expand-file-name (filename &optional default) + "Expand FILENAME like `expand-file-name', but also handle MH folder names. +Any filename that starts with '+' is treated as a folder name. +See `expand-file-name' for description of DEFAULT." + (if (mh-folder-name-p filename) + (expand-file-name (substring filename 1) mh-user-path) + (expand-file-name filename default))) + + +(defun mh-msg-filename (msg &optional folder) + "Return the file name of MSG in FOLDER (default current folder)." + (expand-file-name (int-to-string msg) + (if folder + (mh-expand-file-name folder) + mh-folder-filename))) + +;;; Infrastructure to generate show-buffer functions from folder functions +;;; XEmacs does not have deactivate-mark? What is the equivalent of +;;; transient-mark-mode for XEmacs? Should we be restoring the mark in the +;;; folder buffer after the operation has been carried out. +(defmacro mh-defun-show-buffer (function original-function + &optional dont-return) + "Define FUNCTION to run ORIGINAL-FUNCTION in folder buffer. +If the buffer we start in is still visible and DONT-RETURN is nil then switch +to it after that." + `(defun ,function () + ,(format "Calls %s from the message's folder.\n%s\nSee `%s' for more info.\n" + original-function + (if dont-return "" + "When function completes, returns to the show buffer if it is +still visible.\n") + original-function) + (interactive) + (when (buffer-live-p (get-buffer mh-show-folder-buffer)) + (let ((config (current-window-configuration)) + (folder-buffer mh-show-folder-buffer) + (normal-exit nil) + ,@(if dont-return () '((cur-buffer-name (buffer-name))))) + (pop-to-buffer mh-show-folder-buffer nil) + (unless (equal (buffer-name + (window-buffer (frame-first-window (selected-frame)))) + folder-buffer) + (delete-other-windows)) + (mh-goto-cur-msg t) + (and (fboundp 'deactivate-mark) (deactivate-mark)) + (unwind-protect + (prog1 (call-interactively (function ,original-function)) + (setq normal-exit t)) + (and (fboundp 'deactivate-mark) (deactivate-mark)) + (cond ((not normal-exit) + (set-window-configuration config)) + ,(if dont-return + `(t (setq mh-previous-window-config config)) + `((and (get-buffer cur-buffer-name) + (window-live-p (get-buffer-window + (get-buffer cur-buffer-name)))) + (pop-to-buffer (get-buffer cur-buffer-name) nil))))))))) + +;;; Generate interactive functions for the show buffer from the corresponding +;;; folder functions. +(mh-defun-show-buffer mh-show-previous-undeleted-msg + mh-previous-undeleted-msg) +(mh-defun-show-buffer mh-show-next-undeleted-msg + mh-next-undeleted-msg) +(mh-defun-show-buffer mh-show-quit mh-quit) +(mh-defun-show-buffer mh-show-delete-msg mh-delete-msg) +(mh-defun-show-buffer mh-show-refile-msg mh-refile-msg) +(mh-defun-show-buffer mh-show-undo mh-undo) +(mh-defun-show-buffer mh-show-execute-commands mh-execute-commands) +(mh-defun-show-buffer mh-show-reply mh-reply t) +(mh-defun-show-buffer mh-show-redistribute mh-redistribute) +(mh-defun-show-buffer mh-show-forward mh-forward t) +(mh-defun-show-buffer mh-show-header-display mh-header-display) +(mh-defun-show-buffer mh-show-refile-or-write-again + mh-refile-or-write-again) +(mh-defun-show-buffer mh-show-show mh-show) +(mh-defun-show-buffer mh-show-write-message-to-file + mh-write-msg-to-file) +(mh-defun-show-buffer mh-show-extract-rejected-mail + mh-extract-rejected-mail t) +(mh-defun-show-buffer mh-show-delete-msg-no-motion + mh-delete-msg-no-motion) +(mh-defun-show-buffer mh-show-first-msg mh-first-msg) +(mh-defun-show-buffer mh-show-last-msg mh-last-msg) +(mh-defun-show-buffer mh-show-copy-msg mh-copy-msg) +(mh-defun-show-buffer mh-show-edit-again mh-edit-again t) +(mh-defun-show-buffer mh-show-goto-msg mh-goto-msg) +(mh-defun-show-buffer mh-show-inc-folder mh-inc-folder) +(mh-defun-show-buffer mh-show-delete-subject + mh-delete-subject) +(mh-defun-show-buffer mh-show-print-msg mh-print-msg) +(mh-defun-show-buffer mh-show-send mh-send t) +(mh-defun-show-buffer mh-show-toggle-showing mh-toggle-showing t) +(mh-defun-show-buffer mh-show-pipe-msg mh-pipe-msg t) +(mh-defun-show-buffer mh-show-sort-folder mh-sort-folder) +(mh-defun-show-buffer mh-show-visit-folder mh-visit-folder t) +(mh-defun-show-buffer mh-show-rescan-folder mh-rescan-folder) +(mh-defun-show-buffer mh-show-pack-folder mh-pack-folder) +(mh-defun-show-buffer mh-show-kill-folder mh-kill-folder t) +(mh-defun-show-buffer mh-show-list-folders mh-list-folders t) +(mh-defun-show-buffer mh-show-search-folder mh-search-folder t) +(mh-defun-show-buffer mh-show-undo-folder mh-undo-folder) +(mh-defun-show-buffer mh-show-delete-msg-from-seq + mh-delete-msg-from-seq) +(mh-defun-show-buffer mh-show-delete-seq mh-delete-seq) +(mh-defun-show-buffer mh-show-list-sequences mh-list-sequences) +(mh-defun-show-buffer mh-show-narrow-to-seq mh-narrow-to-seq) +(mh-defun-show-buffer mh-show-put-msg-in-seq mh-put-msg-in-seq) +(mh-defun-show-buffer mh-show-msg-is-in-seq mh-msg-is-in-seq) +(mh-defun-show-buffer mh-show-widen mh-widen) +(mh-defun-show-buffer mh-show-narrow-to-subject + mh-narrow-to-subject) +(mh-defun-show-buffer mh-show-store-msg mh-store-msg) +(mh-defun-show-buffer mh-show-page-digest mh-page-digest) +(mh-defun-show-buffer mh-show-page-digest-backwards + mh-page-digest-backwards) +(mh-defun-show-buffer mh-show-burst-digest mh-burst-digest) +(mh-defun-show-buffer mh-show-page-msg mh-page-msg) +(mh-defun-show-buffer mh-show-previous-page mh-previous-page) +(mh-defun-show-buffer mh-show-modify mh-modify t) +(mh-defun-show-buffer mh-show-next-button mh-next-button) +(mh-defun-show-buffer mh-show-prev-button mh-prev-button) +(mh-defun-show-buffer mh-show-toggle-mime-part mh-folder-toggle-mime-part) +(mh-defun-show-buffer mh-show-save-mime-part mh-folder-save-mime-part) +(mh-defun-show-buffer mh-show-inline-mime-part mh-folder-inline-mime-part) +(mh-defun-show-buffer mh-show-toggle-threads mh-toggle-threads) +(mh-defun-show-buffer mh-show-update-sequences mh-update-sequences) -(defmacro mh-seq-name (pair) (list 'car pair)) +;;; Populate mh-show-mode-map +(gnus-define-keys mh-show-mode-map + " " mh-show-page-msg + "!" mh-show-refile-or-write-again + "," mh-show-header-display + "." mh-show-show + ">" mh-show-write-message-to-file + "?" mh-help + "E" mh-show-extract-rejected-mail + "M" mh-show-modify + "\177" mh-show-previous-page + "\C-d" mh-show-delete-msg-no-motion + "\t" mh-show-next-button + [backtab] mh-show-prev-button + "\M-\t" mh-show-prev-button + "\ed" mh-show-redistribute + "^" mh-show-refile-msg + "c" mh-show-copy-msg + "d" mh-show-delete-msg + "e" mh-show-edit-again + "f" mh-show-forward + "g" mh-show-goto-msg + "i" mh-show-inc-folder + "k" mh-show-delete-subject + "l" mh-show-print-msg + "m" mh-show-send + "n" mh-show-next-undeleted-msg + "o" mh-show-refile-msg + "p" mh-show-previous-undeleted-msg + "q" mh-show-quit + "r" mh-show-reply + "s" mh-show-send + "t" mh-show-toggle-showing + "u" mh-show-undo + "x" mh-show-execute-commands + "|" mh-show-pipe-msg) + +(gnus-define-keys (mh-show-folder-map "F" mh-show-mode-map) + "?" mh-prefix-help + "S" mh-show-sort-folder + "f" mh-show-visit-folder + "i" mh-index-search + "k" mh-show-kill-folder + "l" mh-show-list-folders + "o" mh-show-visit-folder + "r" mh-show-rescan-folder + "s" mh-show-search-folder + "t" mh-show-toggle-threads + "u" mh-show-undo-folder + "v" mh-show-visit-folder) + +(gnus-define-keys (mh-show-sequence-map "S" mh-show-mode-map) + "?" mh-prefix-help + "d" mh-show-delete-msg-from-seq + "k" mh-show-delete-seq + "l" mh-show-list-sequences + "n" mh-show-narrow-to-seq + "p" mh-show-put-msg-in-seq + "s" mh-show-msg-is-in-seq + "w" mh-show-widen) + +(gnus-define-keys (mh-show-thread-map "T" mh-show-mode-map) + "?" mh-prefix-help + "t" mh-show-toggle-threads) + +(gnus-define-keys (mh-show-limit-map "/" mh-show-mode-map) + "?" mh-prefix-help + "s" mh-show-narrow-to-subject + "w" mh-show-widen) + +(gnus-define-keys (mh-show-extract-map "X" mh-show-mode-map) + "?" mh-prefix-help + "s" mh-show-store-msg + "u" mh-show-store-msg) + +;; Untested... +(gnus-define-keys (mh-show-digest-map "D" mh-show-mode-map) + "?" mh-prefix-help + " " mh-show-page-digest + "\177" mh-show-page-digest-backwards + "b" mh-show-burst-digest) + +(gnus-define-keys (mh-show-mime-map "K" mh-show-mode-map) + "?" mh-prefix-help + "a" mh-mime-save-parts + "v" mh-show-toggle-mime-part + "o" mh-show-save-mime-part + "i" mh-show-inline-mime-part + "\t" mh-show-next-button + [backtab] mh-show-prev-button + "\M-\t" mh-show-prev-button) + +(easy-menu-define + mh-show-sequence-menu mh-show-mode-map "Menu for MH-E folder-sequence." + '("Sequence" + ["Add Message to Sequence..." mh-show-put-msg-in-seq t] + ["List Sequences for Message" mh-show-msg-is-in-seq t] + ["Delete Message from Sequence..." mh-show-delete-msg-from-seq t] + ["List Sequences in Folder..." mh-show-list-sequences t] + ["Delete Sequence..." mh-show-delete-seq t] + ["Narrow to Sequence..." mh-show-narrow-to-seq t] + ["Widen from Sequence" mh-show-widen t] + "--" + ["Narrow to Subject Sequence" mh-show-narrow-to-subject t] + ["Delete Rest of Same Subject" mh-show-delete-subject t] + "--" + ["Push State Out to MH" mh-show-update-sequences t])) -(defmacro mh-seq-msgs (pair) (list 'cdr pair)) +(easy-menu-define + mh-show-message-menu mh-show-mode-map "Menu for MH-E folder-message." + '("Message" + ["Show Message" mh-show-show t] + ["Show Message with Header" mh-show-header-display t] + ["Next Message" mh-show-next-undeleted-msg t] + ["Previous Message" mh-show-previous-undeleted-msg t] + ["Go to First Message" mh-show-first-msg t] + ["Go to Last Message" mh-show-last-msg t] + ["Go to Message by Number..." mh-show-goto-msg t] + ["Modify Message" mh-show-modify t] + ["Delete Message" mh-show-delete-msg t] + ["Refile Message" mh-show-refile-msg t] + ["Undo Delete/Refile" mh-show-undo t] + ["Process Delete/Refile" mh-show-execute-commands t] + "--" + ["Compose a New Message" mh-send t] + ["Reply to Message..." mh-show-reply t] + ["Forward Message..." mh-show-forward t] + ["Redistribute Message..." mh-show-redistribute t] + ["Edit Message Again" mh-show-edit-again t] + ["Re-edit a Bounced Message" mh-show-extract-rejected-mail t] + "--" + ["Copy Message to Folder..." mh-show-copy-msg t] + ["Print Message" mh-show-print-msg t] + ["Write Message to File..." mh-show-write-msg-to-file t] + ["Pipe Message to Command..." mh-show-pipe-msg t] + ["Unpack Uuencoded Message..." mh-show-store-msg t] + ["Burst Digest Message" mh-show-burst-digest t])) + +(easy-menu-define + mh-show-folder-menu mh-show-mode-map "Menu for MH-E folder." + '("Folder" + ["Incorporate New Mail" mh-show-inc-folder t] + ["Toggle Show/Folder" mh-show-toggle-showing t] + ["Execute Delete/Refile" mh-show-execute-commands t] + ["Rescan Folder" mh-show-rescan-folder t] + ["Thread Folder" mh-show-toggle-threads t] + ["Pack Folder" mh-show-pack-folder t] + ["Sort Folder" mh-show-sort-folder t] + "--" + ["List Folders" mh-show-list-folders t] + ["Visit a Folder..." mh-show-visit-folder t] + ["Search a Folder..." mh-show-search-folder t] + ["Indexed Search..." mh-index-search t] + "--" + ["Quit MH-E" mh-quit t])) + +(eval-when-compile (defvar tool-bar-map)) +(defvar mh-show-tool-bar-map nil) +(when (and (fboundp 'tool-bar-add-item) + tool-bar-mode) + (setq mh-show-tool-bar-map + (let ((tool-bar-map (make-sparse-keymap))) + (tool-bar-add-item "mail" 'mh-inc-folder 'mh-showtoolbar-inc-folder + :help "Incorporate new mail in Inbox") + (tool-bar-add-item "attach" 'mh-mime-save-parts + 'mh-showtoolbar-mime-save-parts + :help "Save MIME parts") + + (tool-bar-add-item "left_arrow" 'mh-show-previous-undeleted-msg + 'mh-showtoolbar-prev :help "Previous message") + (tool-bar-add-item "page-down" 'mh-show-page-msg 'mh-showtoolbar-page + :help "Page this message") + (tool-bar-add-item "right_arrow" 'mh-show-next-undeleted-msg + 'mh-showtoolbar-next :help "Next message") + (tool-bar-add-item "close" 'mh-show-delete-msg 'mh-showtoolbar-delete + :help "Mark for deletion") + (tool-bar-add-item "refile" 'mh-show-refile-msg 'mh-showtoolbar-refile + :help "Refile this message") + (tool-bar-add-item "undo" 'mh-show-undo 'mh-showtoolbar-undo + :help "Undo this mark") + (tool-bar-add-item "execute" 'mh-show-execute-commands + 'mh-showtoolbar-exec + :help "Perform moves and deletes") + + (tool-bar-add-item "show" 'mh-show-toggle-showing + 'mh-showtoolbar-toggle-show + :help "Toggle showing message") + + (cond + (mh-tool-bar-reply-3-buttons-flag + (tool-bar-add-item "reply-from" + (lambda (&optional arg) + (interactive "P") + (set-buffer mh-show-folder-buffer) + (mh-reply (mh-get-msg-num nil) "from" arg)) + 'mh-showtoolbar-reply-from + :help "Reply to \"from\"") + (tool-bar-add-item "reply-to" + (lambda (&optional arg) + (interactive "P") + (set-buffer mh-show-folder-buffer) + (mh-reply (mh-get-msg-num nil) "to" arg)) + 'mh-showtoolbar-reply-to + :help "Reply to \"to\"") + (tool-bar-add-item "reply-all" + (lambda (&optional arg) + (interactive "P") + (set-buffer mh-show-folder-buffer) + (mh-reply (mh-get-msg-num nil) "all" arg)) + 'mh-showtoolbar-reply-all + :help "Reply to \"all\"")) + (t + (tool-bar-add-item "mail/reply2" 'mh-show-reply 'mh-showtoolbar-reply + :help "Reply to this message"))) + (tool-bar-add-item "mail_compose" 'mh-send 'mh-showtoolbar-compose + :help "Compose new message") + + (tool-bar-add-item "rescan" 'mh-show-rescan-folder + 'mh-showtoolbar-rescan :help "Rescan this folder") + (tool-bar-add-item "repack" 'mh-show-pack-folder 'mh-showtoolbar-pack + :help "Repack this folder") + + (tool-bar-add-item "search" + (lambda (&optional arg) + (interactive "P") + (call-interactively mh-tool-bar-search-function)) + 'mh-showtoolbar-search :help "Search") + (tool-bar-add-item "fld_open" 'mh-visit-folder 'mh-showtoolbar-visit + :help "Visit other folder") + + (tool-bar-add-item "preferences" (lambda () + (interactive) + (customize-group "mh")) + 'mh-showtoolbar-customize + :help "MH-E preferences") + (tool-bar-add-item "help" (lambda () + (interactive) + (Info-goto-node "(mh-e)Top")) + 'mh-showtoolbar-help :help "Help") + tool-bar-map))) ;;; Ensure new buffers won't get this mode if default-major-mode is nil. (put 'mh-show-mode 'mode-class 'special) (define-derived-mode mh-show-mode text-mode "MH-Show" - "Major mode for showing messages in mh-e. -The value of `mh-show-mode-hook' is called when a new message is displayed." + "Major mode for showing messages in MH-E.\\<mh-show-mode-map> +The value of `mh-show-mode-hook' is a list of functions to +be called, with no arguments, upon entry to this mode." (set (make-local-variable 'mail-header-separator) mh-mail-header-separator) + (setq paragraph-start (default-value 'paragraph-start)) (mh-show-unquote-From) - (when mh-show-use-goto-addr - (if (not (featurep 'goto-addr)) - (load "goto-addr" t t)) - (if (fboundp 'goto-address) - (goto-address))) + (mh-show-xface) + (mh-show-addr) (make-local-variable 'font-lock-defaults) - (set (make-local-variable 'font-lock-support-mode) nil) + ;(set (make-local-variable 'font-lock-support-mode) nil) (cond ((equal mh-highlight-citation-p 'font-lock) (setq font-lock-defaults '(mh-show-font-lock-keywords-with-cite t))) ((equal mh-highlight-citation-p 'gnus) - (setq font-lock-defaults '(mh-show-font-lock-keywords t)) + (setq font-lock-defaults '((mh-show-font-lock-keywords) + t nil nil nil + (font-lock-fontify-region-function + . mh-show-font-lock-fontify-region))) (mh-gnus-article-highlight-citation)) (t - (setq font-lock-defaults '(mh-show-font-lock-keywords t))))) + (setq font-lock-defaults '(mh-show-font-lock-keywords t)))) + (if (and mh-xemacs-flag + font-lock-auto-fontify) + (turn-on-font-lock)) + (if (and (boundp 'tool-bar-mode) tool-bar-mode) + (set (make-local-variable 'tool-bar-map) mh-show-tool-bar-map)) + (when mh-decode-mime-flag + (add-hook 'kill-buffer-hook 'mh-mime-cleanup nil t)) + (easy-menu-add mh-show-sequence-menu) + (easy-menu-add mh-show-message-menu) + (easy-menu-add mh-show-folder-menu) + (make-local-variable 'mh-show-folder-buffer) + (buffer-disable-undo) + (setq buffer-read-only t) + (use-local-map mh-show-mode-map) + (run-hooks 'mh-show-mode-hook)) + +(defun mh-show-addr () + "Use `goto-address'." + (when mh-show-use-goto-addr-flag + (if (not (featurep 'goto-addr)) + (load "goto-addr" t t)) + (if (fboundp 'goto-address) + (goto-address)))) + +(defvar mh-show-xface-function + (cond ((and mh-xemacs-flag (locate-library "x-face")) + (load "x-face" t t) + (if (fboundp 'x-face-xmas-wl-display-x-face) + #'x-face-xmas-wl-display-x-face + #'ignore)) + ((>= emacs-major-version 21) + (load "x-face-e21" t t) + (if (fboundp 'x-face-decode-message-header) + #'x-face-decode-message-header + #'ignore)) + (t #'ignore)) + "Determine at run time what function should be called to display X-Face.") + +(defun mh-show-xface () + "Display X-Face." + (when (and mh-show-use-xface-flag + (or mh-decode-mime-flag mhl-formfile mh-clean-message-header-flag)) + (funcall mh-show-xface-function))) (defun mh-maybe-show (&optional msg) - ;; If in showing mode, then display the message pointed to by the cursor. + "Display message at cursor, but only if in show mode. +If optional arg MSG is non-nil, display that message instead." (if mh-showing-mode (mh-show msg))) (defun mh-show (&optional message) - "Show MESSAGE (default: message at cursor). + "Show message at cursor. +If optional argument MESSAGE is non-nil, display that message instead. Force a two-window display with the folder window on top (size `mh-summary-height') and the show buffer below it. If the message is already visible, display the start of the message. Display of the message is controlled by setting the variables -`mh-clean-message-header' and `mhl-formfile'. The default behavior is +`mh-clean-message-header-flag' and `mhl-formfile'. The default behavior is to scroll uninteresting headers off the top of the window. Type \"\\[mh-header-display]\" to see the message with all its headers." (interactive) (and mh-showing-with-headers - (or mhl-formfile mh-clean-message-header) + (or mhl-formfile mh-clean-message-header-flag) (mh-invalidate-show-buffer)) (mh-show-msg message)) @@ -634,12 +1593,15 @@ (mh-show)) (defun mh-show-msg (msg) + "Show MSG. +The value of `mh-show-hook' is a list of functions to be called, with no +arguments, after the message has been displayed." (if (not msg) (setq msg (mh-get-msg-num t))) (mh-showing-mode t) - (setq mh-page-to-next-msg-p nil) + (setq mh-page-to-next-msg-flag nil) (let ((folder mh-current-folder) - (clean-message-header mh-clean-message-header) + (clean-message-header mh-clean-message-header-flag) (show-window (get-buffer-window mh-show-buffer))) (if (not (eq (next-window (minibuffer-window)) (selected-window))) (delete-other-windows)) ; force ourself to the top window @@ -655,18 +1617,51 @@ (shrink-window (- (window-height) mh-summary-height))) (mh-recenter nil) (if (not (memq msg mh-seen-list)) (setq mh-seen-list (cons msg mh-seen-list))) - (when mh-update-sequences-after-mh-show + (when mh-update-sequences-after-mh-show-flag (mh-update-sequences)) (run-hooks 'mh-show-hook)) +(defun mh-modify (&optional message) + "Edit message at cursor. +If optional argument MESSAGE is non-nil, edit that message instead. +Force a two-window display with the folder window on top (size +`mh-summary-height') and the message editing buffer below it. + +The message is displayed in raw form." + (interactive) + (let* ((message (or message (mh-get-msg-num t))) + (msg-filename (mh-msg-filename message)) + edit-buffer) + (when (not (file-exists-p msg-filename)) + (error "Message %d does not exist" message)) + + ;; Invalidate the show buffer if it is showing the same message that is + ;; to be edited. + (when (and (buffer-live-p (get-buffer mh-show-buffer)) + (equal (save-excursion (set-buffer mh-show-buffer) + buffer-file-name) + msg-filename)) + (mh-invalidate-show-buffer)) + + ;; Edit message + (find-file msg-filename) + (setq edit-buffer (current-buffer)) + + ;; Set buffer properties + (mh-letter-mode) + (use-local-map text-mode-map) + + ;; Just show the edit buffer... + (delete-other-windows) + (switch-to-buffer edit-buffer))) (defun mh-decode-quoted-printable () - ;; Run mimedecode commmand on current buffer, replacing it contents. + "Run mimedecode on current buffer, replacing its contents." (let ((case-fold-search t)) (goto-char (point-min)) (when (and (re-search-forward "^content-transfer-encoding:[ \t]*quoted-printable" - nil t) + (if mh-decode-mime-flag (mail-header-end) nil) t) (search-forward "\n\n" nil t)) (message "Converting quoted-printable characters...") (let ((modified (buffer-modified-p)) @@ -677,9 +1672,8 @@ (set-buffer-modified-p modified)) (message "Converting quoted-printable characters... done.")))) - (defun mh-show-unquote-From () - ;; Decode >From at beginning of lines for mh-show-mode + "Decode >From at beginning of lines for `mh-show-mode'." (save-excursion (let ((modified (buffer-modified-p)) (case-fold-search nil)) @@ -688,117 +1682,103 @@ (replace-match "From")) (set-buffer-modified-p modified)))) -(defun mh-display-msg (msg-num folder) - ;; Display message NUMBER of FOLDER. - ;; Sets the current buffer to the show buffer. - (set-buffer folder) - ;; Bind variables in folder buffer in case they are local - (let ((formfile mhl-formfile) - (clean-message-header mh-clean-message-header) - (invisible-headers mh-invisible-headers) - (visible-headers mh-visible-headers) - (msg-filename (mh-msg-filename msg-num)) - (show-buffer mh-show-buffer)) - (if (not (file-exists-p msg-filename)) - (error "Message %d does not exist" msg-num)) - (set-buffer show-buffer) - (cond ((not (equal msg-filename buffer-file-name)) - (mh-unvisit-file) - (erase-buffer) - ;; Changing contents, so this hook needs to be reinitialized. - ;; pgp.el uses this. - (if (boundp 'write-contents-hooks) ;Emacs 19 - (kill-local-variable 'write-contents-hooks)) - (if formfile - (mh-exec-lib-cmd-output "mhl" "-nobell" "-noclear" - (if (stringp formfile) - (list "-form" formfile)) - msg-filename) - (insert-file-contents msg-filename)) - (if mh-decode-quoted-printable - (mh-decode-quoted-printable)) - (goto-char (point-min)) - (cond (clean-message-header - (mh-clean-msg-header (point-min) - invisible-headers - visible-headers) - (goto-char (point-min))) - (t - (mh-start-of-uncleaned-message))) - ;; the parts of visiting we want to do (no locking) - (or (eq buffer-undo-list t) ;don't save undo info for prev msgs - (setq buffer-undo-list nil)) - (set-buffer-modified-p nil) - (set-buffer-auto-saved) - ;; the parts of set-visited-file-name we want to do (no locking) - (setq buffer-file-name msg-filename) - (setq buffer-backed-up nil) - (auto-save-mode 1) - (set-mark nil) - (mh-show-mode) - (setq mode-line-buffer-identification - (list (format mh-show-buffer-mode-line-buffer-id - folder msg-num))) - (set-buffer folder) - (setq mh-showing-with-headers nil))))) +(defun mh-msg-folder (folder-name) + "Return the name of the buffer for FOLDER-NAME." + folder-name) -(defun mh-start-of-uncleaned-message () - ;; position uninteresting headers off the top of the window - (let ((case-fold-search t)) - (re-search-forward - "^To:\\|^Cc:\\|^From:\\|^Subject:\\|^Date:" nil t) - (beginning-of-line) - (mh-recenter 0))) - - -(defun mh-invalidate-show-buffer () - ;; Invalidate the show buffer so we must update it to use it. - (if (get-buffer mh-show-buffer) - (save-excursion - (set-buffer mh-show-buffer) - (mh-unvisit-file)))) - - -(defun mh-unvisit-file () - ;; Separate current buffer from the message file it was visiting. - (or (not (buffer-modified-p)) - (null buffer-file-name) ;we've been here before - (yes-or-no-p (format "Message %s modified; flush changes? " - (file-name-nondirectory buffer-file-name))) - (error "Flushing changes not confirmed")) - (clear-visited-file-modtime) - (unlock-buffer) - (setq buffer-file-name nil)) - - -(defun mh-get-msg-num (error-if-no-message) - ;; Return the message number of the displayed message. If the argument - ;; ERROR-IF-NO-MESSAGE is non-nil, then complain if the cursor is not - ;; pointing to a message. - (save-excursion - (beginning-of-line) - (cond ((looking-at mh-scan-msg-number-regexp) - (string-to-int (buffer-substring (match-beginning 1) - (match-end 1)))) - (error-if-no-message - (error "Cursor not pointing to message")) - (t nil)))) - - -(defun mh-msg-filename (msg &optional folder) - ;; Return the file name of MESSAGE in FOLDER (default current folder). - (expand-file-name (int-to-string msg) - (if folder - (mh-expand-file-name folder) - mh-folder-filename))) - +(defun mh-display-msg (msg-num folder-name) + "Display MSG-NUM of FOLDER-NAME. +Sets the current buffer to the show buffer." + (let ((folder (mh-msg-folder folder-name))) + (set-buffer folder) + ;; When Gnus uses external displayers it has to keep handles longer. So + ;; we will delete these handles when mh-quit is called on the folder. It + ;; would be nicer if there are weak pointers in emacs lisp, then we could + ;; get the garbage collector to do this for us. + (unless (mh-buffer-data) + (setf (mh-buffer-data) (mh-make-buffer-data))) + ;; Bind variables in folder buffer in case they are local + (let ((formfile mhl-formfile) + (clean-message-header mh-clean-message-header-flag) + (invisible-headers mh-invisible-headers) + (visible-headers mh-visible-headers) + (msg-filename (mh-msg-filename msg-num folder-name)) + (show-buffer mh-show-buffer) + (mm-inline-media-tests mh-mm-inline-media-tests)) + (if (not (file-exists-p msg-filename)) + (error "Message %d does not exist" msg-num)) + (if (and (> mh-show-maximum-size 0) + (> (elt (file-attributes msg-filename) 7) + mh-show-maximum-size) + (not (y-or-n-p + (format + "Message %d (%d bytes) exceeds %d bytes. Display it? " + msg-num (elt (file-attributes msg-filename) 7) + mh-show-maximum-size)))) + (error "Message %d not displayed" msg-num)) + (set-buffer show-buffer) + (cond ((not (equal msg-filename buffer-file-name)) + (mh-unvisit-file) + (setq buffer-read-only nil) + (erase-buffer) + ;; Changing contents, so this hook needs to be reinitialized. + ;; pgp.el uses this. + (if (boundp 'write-contents-hooks) ;Emacs 19 + (kill-local-variable 'write-contents-hooks)) + (if formfile + (mh-exec-lib-cmd-output "mhl" "-nobell" "-noclear" + (if (stringp formfile) + (list "-form" formfile)) + msg-filename) + (insert-file-contents msg-filename)) + (if mh-decode-quoted-printable-flag + (mh-decode-quoted-printable)) + ;; Cleanup old mime handles + (mh-mime-cleanup) + ;; Use mm to display buffer + (when (and mh-decode-mime-flag (not formfile)) + (mh-add-missing-mime-version-header) + (setf (mh-buffer-data) (mh-make-buffer-data)) + (mh-mime-display)) + ;; Header cleanup + (goto-char (point-min)) + (cond (clean-message-header + (mh-clean-msg-header (point-min) + invisible-headers + visible-headers) + (goto-char (point-min))) + (t + (mh-start-of-uncleaned-message))) + ;; the parts of visiting we want to do (no locking) + (or (eq buffer-undo-list t) ;don't save undo info for prev msgs + (setq buffer-undo-list nil)) + (set-buffer-auto-saved) + ;; the parts of set-visited-file-name we want to do (no locking) + (setq buffer-file-name msg-filename) + (setq buffer-backed-up nil) + (auto-save-mode 1) + (set-mark nil) + (mh-show-mode) + (unwind-protect + (when (and mh-decode-mime-flag (not formfile)) + (setq buffer-read-only nil) + (mh-display-smileys) + (mh-display-emphasis)) + (setq buffer-read-only t)) + (set-buffer-modified-p nil) + (setq mh-show-folder-buffer folder) + (setq mode-line-buffer-identification + (list (format mh-show-buffer-mode-line-buffer-id + folder-name msg-num))) + (set-buffer folder) + (setq mh-showing-with-headers nil)))))) (defun mh-clean-msg-header (start invisible-headers visible-headers) - ;; Flush extraneous lines in a message header, from the given POINT to the - ;; end of the message header. If VISIBLE-HEADERS is non-nil, it contains a - ;; regular expression specifying the lines to display, otherwise - ;; INVISIBLE-HEADERS contains a regular expression specifying lines to - ;; delete from the header. + "Flush extraneous lines in message header. +Header is cleaned from START to the end of the message header. +INVISIBLE-HEADERS contains a regular expression specifying lines to delete +from the header. VISIBLE-HEADERS contains a regular expression specifying the +lines to display. INVISIBLE-HEADERS is ignored if VISIBLE-HEADERS is non-nil." (let ((case-fold-search t) (after-change-functions nil)) ;Work around emacs-20 font-lock bug ;causing an endless loop. @@ -824,25 +1804,13 @@ (mh-delete-line 1)))) (unlock-buffer)))) - -(defun mh-recenter (arg) - ;; Like recenter but with two improvements: - ;; - only does anything if the current buffer is in the selected - ;; window. (Commands like save-some-buffers can make this false.) - ;; - nil arg means recenter as with C-u prefix - (if (eq (get-buffer-window (current-buffer)) - (selected-window)) - ;; '(4) is the same as C-u prefix argument. - (recenter (if arg arg '(4))))) - - (defun mh-delete-line (lines) - ;; Delete version of kill-line. + "Delete the next LINES lines." (delete-region (point) (progn (forward-line lines) (point)))) (defun mh-notate (msg notation offset) - ;; Marks MESSAGE with the character NOTATION at position OFFSET. - ;; Null MESSAGE means the message that the cursor points to. + "Mark MSG with the character NOTATION at position OFFSET. +Null MSG means the message at cursor." (save-excursion (if (or (null msg) (mh-goto-msg msg t t)) @@ -852,11 +1820,10 @@ (delete-char 1) (insert notation))))) - (defun mh-find-msg-get-num (step) - ;; Return the message number of the message on the current scan line - ;; or one nearby. Jumps over non-message lines, such as inc errors. - ;; STEP tells whether to search forward or backward if we have to search. + "Return the message number of the message nearest the cursor. +Jumps over non-message lines, such as inc errors. +If we have to search, STEP tells whether to search forward or backward." (or (mh-get-msg-num nil) (let ((msg-num nil) (nreverses 0)) @@ -879,42 +1846,26 @@ cursor is positioned near where the message would have been. Non-nil third argument DONT-SHOW means not to show the message." (interactive "NGo to message: ") - (setq number (prefix-numeric-value number)) ;Emacs 19 - ;; This basic routine tries to be as fast as possible, - ;; using a binary search and minimal regexps. - (let ((cur-msg (mh-find-msg-get-num -1)) - (jump-size mh-msg-count)) - (while (and (> jump-size 1) - cur-msg - (not (eq cur-msg number))) - (cond ((< cur-msg number) - (setq jump-size (min (- number cur-msg) - (ash (1+ jump-size) -1))) - (forward-line jump-size) - (setq cur-msg (mh-find-msg-get-num 1))) - (t - (setq jump-size (min (- cur-msg number) - (ash (1+ jump-size) -1))) - (forward-line (- jump-size)) - (setq cur-msg (mh-find-msg-get-num -1))))) - (if (eq cur-msg number) - (progn - (beginning-of-line) - (or dont-show - (mh-maybe-show number) - t)) - (if (not no-error-if-no-message) - (error "No message %d" number))))) - + (setq number (prefix-numeric-value number)) + (let ((point (point)) + (return-value t)) + (goto-char (point-min)) + (unless (re-search-forward (format "^[ ]*%s[^0-9]+" number) nil t) + (goto-char point) + (unless no-error-if-no-message + (error "No message %d" number)) + (setq return-value nil)) + (beginning-of-line) + (or dont-show (not return-value) (mh-maybe-show number)) + return-value)) (defun mh-msg-search-pat (n) - ;; Return a search pattern for message N in the scan listing. + "Return a search pattern for message N in the scan listing." (format mh-scan-msg-search-regexp n)) - (defun mh-get-profile-field (field) - ;; Find and return the value of FIELD in the current buffer. - ;; Returns NIL if the field is not in the buffer. + "Find and return the value of FIELD in the current buffer. +Returns nil if the field is not in the buffer." (let ((case-fold-search t)) (goto-char (point-min)) (cond ((not (re-search-forward (format "^%s" field) nil t)) nil) @@ -932,10 +1883,11 @@ "Non-nil if `mh-find-path' has been run already.") (defun mh-find-path () - ;; Set mh-progs, mh-lib, and mh-libs-progs - ;; (This step is necessary if MH was installed after this Emacs was dumped.) - ;; From profile file, set mh-user-path, mh-draft-folder, - ;; mh-unseen-seq, mh-previous-seq, mh-inbox. + "Set `mh-progs', `mh-lib', and `mh-lib-progs' variables. +Set `mh-user-path', `mh-draft-folder', `mh-unseen-seq', `mh-previous-seq', +`mh-inbox' from user's MH profile. +The value of `mh-find-path-hook' is a list of functions to be called, with no +arguments, after these variable have been set." (mh-find-progs) (unless mh-find-path-run (setq mh-find-path-run t) @@ -978,7 +1930,7 @@ (if mh-previous-seq (setq mh-previous-seq (intern mh-previous-seq))) (run-hooks 'mh-find-path-hook))) - (and mh-auto-folder-collect + (and mh-auto-folder-collect-flag (let ((mh-no-install t)) ;only get folders if MH installed (condition-case err (mh-make-folder-list-background) @@ -991,45 +1943,48 @@ (defun mh-find-progs () "Find the directories for the installed MH/nmh binaries and config files. Set the `mh-progs' and `mh-lib', and `mh-lib-progs' variables to the -directory names and set `mh-nmh-p' if we detect nmh instead of MH." - (let ((path (or (mh-path-search exec-path "mhparam") - (mh-path-search '("/usr/local/nmh/bin" ; nmh default - "/usr/local/bin/mh/" - "/usr/local/mh/" - "/usr/bin/mh/" ;Ultrix 4.2 - "/usr/new/mh/" ;Ultrix <4.2 - "/usr/contrib/mh/bin/" ;BSDI - "/usr/pkg/bin/" ; NetBSD - "/usr/local/bin/" - ) - "mhparam")))) - (if (not path) - (error "Unable to find the `mhparam' command")) - (save-excursion - (let ((tmp-buffer (get-buffer-create mh-temp-buffer))) - (set-buffer tmp-buffer) - (unwind-protect - (progn - (call-process (expand-file-name "mhparam" path) - nil '(t nil) nil "libdir" "etcdir") - (goto-char (point-min)) - (if (search-forward-regexp "^libdir:\\s-\\(\\S-+\\)\\s-*$" nil t) - (setq mh-lib-progs (match-string 1) - mh-lib mh-lib-progs - mh-progs path)) - (goto-char (point-min)) - (if (search-forward-regexp "^etcdir:\\s-\\(\\S-+\\)\\s-*$" nil t) - (setq mh-lib (match-string 1) - mh-nmh-p t))) - (kill-buffer tmp-buffer)))) - (unless (and mh-progs mh-lib mh-lib-progs) - (error "Unable to determine paths from `mhparam' command")))) +directory names and set `mh-nmh-flag' if we detect nmh instead of MH." + (unless (and mh-progs mh-lib mh-lib-progs) + (let ((path (or (mh-path-search exec-path "mhparam") + (mh-path-search '("/usr/local/nmh/bin" ; nmh default + "/usr/local/bin/mh/" + "/usr/local/mh/" + "/usr/bin/mh/" ;Ultrix 4.2, Linux + "/usr/new/mh/" ;Ultrix <4.2 + "/usr/contrib/mh/bin/" ;BSDI + "/usr/pkg/bin/" ; NetBSD + "/usr/local/bin/" + ) + "mhparam")))) + (if (not path) + (error "Unable to find the `mhparam' command")) + (save-excursion + (let ((tmp-buffer (get-buffer-create mh-temp-buffer))) + (set-buffer tmp-buffer) + (unwind-protect + (progn + (call-process (expand-file-name "mhparam" path) + nil '(t nil) nil "libdir" "etcdir") + (goto-char (point-min)) + (if (search-forward-regexp "^libdir:\\s-\\(\\S-+\\)\\s-*$" + nil t) + (setq mh-lib-progs (match-string 1) + mh-lib mh-lib-progs + mh-progs path)) + (goto-char (point-min)) + (if (search-forward-regexp "^etcdir:\\s-\\(\\S-+\\)\\s-*$" + nil t) + (setq mh-lib (match-string 1) + mh-nmh-flag t))) + (kill-buffer tmp-buffer)))) + (unless (and mh-progs mh-lib mh-lib-progs) + (error "Unable to determine paths from `mhparam' command"))))) -(defun mh-path-search (path file &optional func-p) - ;; Search PATH, a list of directory names, for FILE. - ;; Returns the element of PATH that contains FILE, or nil if not found. +(defun mh-path-search (path file) + "Search PATH, a list of directory names, for FILE. +Returns the element of PATH that contains FILE, or nil if not found." (while (and path - (not (funcall (or func-p 'mh-file-command-p) + (not (funcall 'mh-file-command-p (expand-file-name file (car path))))) (setq path (cdr path))) (car path)) @@ -1037,8 +1992,9 @@ (defvar mh-no-install nil) ;do not run install-mh (defun mh-install (profile error-val) - ;; Called to do error recovery if we fail to read the profile file. - ;; If possible, initialize the MH environment. + "Initialize the MH environment. +This is called if we fail to read the PROFILE file. ERROR-VAL is the error +that made this call necessary." (if (or (getenv "MH") (file-exists-p profile) mh-no-install) @@ -1059,48 +2015,118 @@ (list (format "Cannot read MH profile \"%s\"" profile) (car (cdr (cdr err)))))))) - (defun mh-set-folder-modified-p (flag) - ;; Mark current folder as modified or unmodified according to FLAG. + "Mark current folder as modified or unmodified according to FLAG." (set-buffer-modified-p flag)) - -(defun mh-find-seq (name) (assoc name mh-seq-list)) +(defun mh-find-seq (name) + "Return sequence NAME." + (assoc name mh-seq-list)) (defun mh-seq-to-msgs (seq) - ;; Return a list of the messages in SEQUENCE. + "Return a list of the messages in SEQ." (mh-seq-msgs (mh-find-seq seq))) +(defun mh-update-scan-format (fmt width) + "Return a scan format with the (msg) width in the FMT replaced with WIDTH. + +The message number width portion of the format is discovered using +`mh-scan-msg-format-regexp'. Its replacement is controlled with +`mh-scan-msg-format-string'." + (or (and + (string-match mh-scan-msg-format-regexp fmt) + (let ((begin (match-beginning 1)) + (end (match-end 1))) + (concat (substring fmt 0 begin) + (format mh-scan-msg-format-string width) + (substring fmt end)))) + fmt)) + +(defun mh-set-cmd-note (width) + "Set `mh-cmd-note' to WIDTH characters (minimum of 2). + +If `mh-scan-format-file' specifies nil or a filename, then this function +will NOT update `mh-cmd-note'." + ;; Add one to the width to always have whitespace in column zero. + (setq width (max (1+ width) 2)) + (if (and (equal mh-scan-format-file t) + (not (eq mh-cmd-note width))) + (progn + (setq mh-cmd-note width) + ;; Rachet up the default value + (if (< (default-value 'mh-cmd-note) mh-cmd-note) + (setq-default mh-cmd-note mh-cmd-note)))) + mh-cmd-note) + +(defun mh-message-number-width (folder) + "Return the widest message number in this FOLDER." + (or mh-progs (mh-find-path)) + (let ((tmp-buffer (get-buffer-create mh-temp-buffer)) + (width 0)) + (save-excursion + (set-buffer tmp-buffer) + (erase-buffer) + (apply 'call-process + (expand-file-name "scan" mh-progs) nil '(t nil) nil + (list folder "last" "-format" "%(msg)")) + (goto-char (point-min)) + (if (re-search-forward mh-scan-msg-number-regexp nil 0 1) + (setq width (length (buffer-substring + (match-beginning 1) (match-end 1)))))) + width)) (defun mh-add-msgs-to-seq (msgs seq &optional internal-flag) - ;; Add MESSAGE(s) to the SEQUENCE. If optional FLAG is non-nil, do not mark - ;; the message in the scan listing or inform MH of the addition. + "Add MSGS to SEQ. +Remove duplicates and keep sequence sorted. If optional INTERNAL-FLAG is +non-nil, do not mark the message in the scan listing or inform MH of the +addition." (let ((entry (mh-find-seq seq))) (if (and msgs (atom msgs)) (setq msgs (list msgs))) (if (null entry) - (setq mh-seq-list (cons (mh-make-seq seq msgs) mh-seq-list)) - (if msgs (setcdr entry (append msgs (mh-seq-msgs entry))))) + (setq mh-seq-list + (cons (mh-make-seq seq (mh-canonicalize-sequence msgs)) + mh-seq-list)) + (if msgs (setcdr entry (mh-canonicalize-sequence + (append msgs (mh-seq-msgs entry)))))) (cond ((not internal-flag) (mh-add-to-sequence seq msgs) (mh-notate-seq seq mh-note-seq (1+ mh-cmd-note)))))) -(defvar mh-folder-hist nil) +(defun mh-canonicalize-sequence (msgs) + "Sort MSGS in decreasing order and remove duplicates." + (let* ((sorted-msgs (sort (copy-sequence msgs) '>)) + (head sorted-msgs)) + (while (cdr head) + (if (= (car head) (cadr head)) + (setcdr head (cddr head)) + (setq head (cdr head)))) + sorted-msgs)) -(defun mh-prompt-for-folder (prompt default can-create) - ;; Prompt for a folder name with PROMPT. Returns the folder's name as a - ;; string. DEFAULT is used if the folder exists and the user types return. - ;; If the CAN-CREATE flag is t, then a non-existent folder is made. +(defvar mh-folder-hist nil) +(defvar mh-speed-folder-map) + +(defun mh-prompt-for-folder (prompt default can-create + &optional default-string) + "Prompt for a folder name with PROMPT. +Returns the folder's name as a string. DEFAULT is used if the folder exists +and the user types return. If the CAN-CREATE flag is t, then a folder is +created if it doesn't already exist. If optional argument DEFAULT-STRING is +non-nil, use it in the prompt instead of DEFAULT. +The value of `mh-folder-list-change-hook' is a list of functions to be called, +with no arguments, whenever the cached folder list `mh-folder-list' is +changed." (if (null default) (setq default "")) - (let* ((prompt (format "%s folder%s" prompt - (if (equal "" default) - "? " - (format " [%s]? " default)))) + (let* ((default-string (cond (default-string (format " [%s]? " + default-string)) + ((equal "" default) "? ") + (t (format " [%s]? " default)))) + (prompt (format "%s folder%s" prompt default-string)) read-name folder-name) (if (null mh-folder-list) (mh-set-folder-list)) (while (and (setq read-name (completing-read prompt mh-folder-list nil nil - "+" 'mh-folder-hist default)) + "+" 'mh-folder-hist)) (equal read-name "") (equal default ""))) (cond ((or (equal read-name "") (equal read-name "+")) @@ -1113,16 +2139,20 @@ (cond ((and (> (length folder-name) 0) (eq (aref folder-name (1- (length folder-name))) ?/)) (setq folder-name (substring folder-name 0 -1)))) - (let ((new-file-p (not (file-exists-p (mh-expand-file-name folder-name))))) - (cond ((and new-file-p + (let ((new-file-flag + (not (file-exists-p (mh-expand-file-name folder-name))))) + (cond ((and new-file-flag (y-or-n-p - (format "Folder %s does not exist. Create it? " folder-name))) + (format "Folder %s does not exist. Create it? " + folder-name))) (message "Creating %s" folder-name) - (call-process "mkdir" nil nil nil (mh-expand-file-name folder-name)) - (message "Creating %s...done" folder-name) + (mh-exec-cmd-error nil "folder" folder-name) + (when (boundp 'mh-speed-folder-map) + (mh-speed-add-folder folder-name)) + (message "Creating %s...done" folder-name) (setq mh-folder-list (cons (list read-name) mh-folder-list)) (run-hooks 'mh-folder-list-change-hook)) - (new-file-p + (new-file-flag (error "Folder %s is not created" folder-name)) ((not (file-directory-p (mh-expand-file-name folder-name))) (error "\"%s\" is not a directory" @@ -1133,17 +2163,20 @@ (run-hooks 'mh-folder-list-change-hook)))) folder-name)) - -(defvar mh-make-folder-list-process nil) ;The background process collecting the folder list. +(defvar mh-make-folder-list-process nil) ;The background process collecting + ;the folder list. (defvar mh-folder-list-temp nil) ;mh-folder-list as it is being built. -(defvar mh-folder-list-partial-line "") ;Start of last incomplete line from folder process. +(defvar mh-folder-list-partial-line "") ;Start of last incomplete line from + ;folder process. (defun mh-set-folder-list () - ;; Sets mh-folder-list correctly. - ;; A useful function for the command line or for when you need to - ;; sync by hand. Format is in a form suitable for completing read. + "Set `mh-folder-list' correctly. +A useful function for the command line or for when you need to +sync by hand. Format is in a form suitable for completing read. +The value of `mh-folder-list-change-hook' is a list of functions to be called, +with no arguments, once the list of folders has been created." (message "Collecting folder names...") (if (not mh-make-folder-list-process) (mh-make-folder-list-background)) @@ -1157,8 +2190,8 @@ (message "Collecting folder names...done")) (defun mh-make-folder-list-background () - ;; Start a background process to compute a list of the user's folders. - ;; Call mh-set-folder-list to wait for the result. + "Start a background process to compute a list of the user's folders. +Call `mh-set-folder-list' to wait for the result." (cond ((not mh-make-folder-list-process) (unless mh-inbox @@ -1167,7 +2200,7 @@ (setq mh-make-folder-list-process (start-process "folders" nil (expand-file-name "folders" mh-progs) "-fast" - (if mh-recursive-folders + (if mh-recursive-folders-flag "-recurse" "-norecurse"))) (set-process-filter mh-make-folder-list-process @@ -1175,7 +2208,8 @@ (process-kill-without-query mh-make-folder-list-process))))) (defun mh-make-folder-list-filter (process output) - ;; parse output from "folders -fast" + "Given the PROCESS \"folders -fast\", parse OUTPUT. +See also `set-process-filter'." (let ((position 0) line-end new-folder @@ -1208,24 +2242,13 @@ (set-match-data prevailing-match-data)) (setq mh-folder-list-partial-line (substring output position)))) - -(defun mh-folder-name-p (name) - ;; Return non-NIL if NAME is possibly the name of a folder. - ;; A name (a string or symbol) can be a folder name if it begins with "+". - (if (symbolp name) - (eq (aref (symbol-name name) 0) ?+) - (and (> (length name) 0) - (eq (aref name 0) ?+)))) - - ;;; Issue commands to MH. - (defun mh-exec-cmd (command &rest args) - ;; Execute mh-command COMMAND with ARGS. - ;; The side effects are what is desired. - ;; Any output is assumed to be an error and is shown to the user. - ;; The output is not read or parsed by mh-e. + "Execute mh-command COMMAND with ARGS. +The side effects are what is desired. +Any output is assumed to be an error and is shown to the user. +The output is not read or parsed by MH-E." (save-excursion (set-buffer (get-buffer-create mh-temp-buffer)) (erase-buffer) @@ -1237,11 +2260,10 @@ (switch-to-buffer-other-window mh-temp-buffer) (sit-for 5))))) - (defun mh-exec-cmd-error (env command &rest args) - ;; In environment ENV, execute mh-command COMMAND with args ARGS. - ;; ENV is nil or a string of space-separated "var=value" elements. - ;; Signals an error if process does not complete successfully. + "In environment ENV, execute mh-command COMMAND with ARGS. +ENV is nil or a string of space-separated \"var=value\" elements. +Signals an error if process does not complete successfully." (save-excursion (set-buffer (get-buffer-create mh-temp-buffer)) (erase-buffer) @@ -1259,10 +2281,9 @@ (mh-list-to-string args))))) (mh-handle-process-error command status)))) - (defun mh-exec-cmd-daemon (command &rest args) - ;; Execute MH command COMMAND with ARGS in the background. - ;; Any output from command is displayed in an asynchronous pop-up window. + "Execute MH command COMMAND with ARGS in the background. +Any output from command is displayed in an asynchronous pop-up window." (save-excursion (set-buffer (get-buffer-create mh-temp-buffer)) (erase-buffer)) @@ -1274,19 +2295,17 @@ (set-process-filter process 'mh-process-daemon))) (defun mh-process-daemon (process output) - ;; Process daemon that puts output into a temporary buffer. + "PROCESS daemon that puts OUTPUT into a temporary buffer." (set-buffer (get-buffer-create mh-temp-buffer)) (insert-before-markers output) (display-buffer mh-temp-buffer)) - (defun mh-exec-cmd-quiet (raise-error command &rest args) - ;; Args are RAISE-ERROR, COMMANDS, ARGS.... - ;; Execute MH command COMMAND with ARGS. ARGS is a list of strings. - ;; Return at start of mh-temp buffer, where output can be parsed and used. - ;; Returns value of call-process, which is 0 for success, - ;; unless RAISE-ERROR is non-nil, in which case an error is signaled - ;; if call-process returns non-0. + "Signal RAISE-ERROR if COMMAND with ARGS fails. +Execute MH command COMMAND with ARGS. ARGS is a list of strings. +Return at start of mh-temp buffer, where output can be parsed and used. +Returns value of `call-process', which is 0 for success, unless RAISE-ERROR is +non-nil, in which case an error is signaled if `call-process' returns non-0." (set-buffer (get-buffer-create mh-temp-buffer)) (erase-buffer) (let ((value @@ -1298,29 +2317,47 @@ (mh-handle-process-error command value) value))) +(defun mh-exchange-point-and-mark-preserving-active-mark () + "Put the mark where point is now, and point where the mark is now. +This command works even when the mark is not active, and preserves whether the +mark is active or not." + (interactive nil) + (let ((is-active (and (boundp 'mark-active) mark-active))) + (let ((omark (mark t))) + (if (null omark) + (error "No mark set in this buffer")) + (set-mark (point)) + (goto-char omark) + (if (boundp 'mark-active) + (setq mark-active is-active)) + nil))) (defun mh-exec-cmd-output (command display &rest args) - ;; Execute MH command COMMAND with DISPLAY flag and ARGS. - ;; Put the output into buffer after point. Set mark after inserted text. - ;; Output is expected to be shown to user, not parsed by mh-e. + "Execute MH command COMMAND with DISPLAY flag and ARGS. +Put the output into buffer after point. Set mark after inserted text. +Output is expected to be shown to user, not parsed by MH-E." (push-mark (point) t) (apply 'call-process (expand-file-name command mh-progs) nil t display (mh-list-to-string args)) - (exchange-point-and-mark)) + ;; The following is used instead of 'exchange-point-and-mark because the + ;; latter activates the current region (between point and mark), which + ;; turns on highlighting. So prior to this bug fix, doing "inc" would + ;; highlight a region containing the new messages, which is undesirable. + ;; The bug wasn't seen in emacs21 but still occurred in XEmacs21.4. + (mh-exchange-point-and-mark-preserving-active-mark)) (defun mh-exec-lib-cmd-output (command &rest args) - ;; Execute MH library command COMMAND with ARGS. - ;; Put the output into buffer after point. Set mark after inserted text. + "Execute MH library command COMMAND with ARGS. +Put the output into buffer after point. Set mark after inserted text." (apply 'mh-exec-cmd-output (expand-file-name command mh-lib-progs) nil args)) - (defun mh-handle-process-error (command status) - ;; Raise error if COMMAND returned non-0 STATUS, otherwise return STATUS. - ;; STATUS is return value from call-process. - ;; Program output is in current buffer. - ;; If output is too long to include in error message, display the buffer. + "Raise error if COMMAND returned non-zero STATUS, otherwise return STATUS. +STATUS is return value from `call-process'. +Program output is in current buffer. +If output is too long to include in error message, display the buffer." (cond ((eq status 0) ;success status) ((stringp status) ;kill string @@ -1342,20 +2379,12 @@ (error "%s failed with status %d. See error message in other window" command status))))))) - -(defun mh-expand-file-name (filename &optional default) - ;; Just like `expand-file-name', but also handles MH folder names. - ;; Assumes that any filename that starts with '+' is a folder name. - (if (mh-folder-name-p filename) - (expand-file-name (substring filename 1) mh-user-path) - (expand-file-name filename default))) - - (defun mh-list-to-string (l) - ;; Flattens the list L and makes every element of the new list into a string. + "Flatten the list L and make every element of the new list into a string." (nreverse (mh-list-to-string-1 l))) (defun mh-list-to-string-1 (l) + "Flatten the list L and make every element of the new list into a string." (let ((new-list nil)) (while l (cond ((null (car l))) @@ -1374,4 +2403,8 @@ (provide 'mh-utils) +;;; Local Variables: +;;; sentence-end-double-space: nil +;;; End: + ;;; mh-utils.el ends here
--- a/lisp/mail/mh-xemacs-compat.el Fri Nov 29 18:02:52 2002 +0000 +++ b/lisp/mail/mh-xemacs-compat.el Fri Nov 29 18:15:21 2002 +0000 @@ -28,76 +28,35 @@ ;;; Change Log: -;; $Id: mh-xemacs-compat.el,v 1.7 2002/04/07 19:20:55 wohler Exp $ +;; $Id: mh-xemacs-compat.el,v 1.12 2002/11/02 19:56:50 wohler Exp $ ;;; Code: +;;; Some requires: +(require 'rfc822) + ;;; Simple compatibility: (unless (fboundp 'match-string-no-properties) - (defalias 'match-string-no-properties 'match-string)) - -;;; Functions from simple.el of Emacs-21.1 -;;; simple.el --- basic editing commands for Emacs - -;; Copyright (C) 1985, 86, 87, 93, 94, 95, 96, 97, 98, 99, 2000, 2001 -;; Free Software Foundation, Inc. - -(defun rfc822-goto-eoh () - ;; Go to header delimiter line in a mail message, following RFC822 rules - (goto-char (point-min)) - (while (looking-at "^[^: \n]+:\\|^[ \t]") - (forward-line 1)) - (point)) - -;;; Functions from sendmail.el of Emacs-21.1 -;;; sendmail.el --- mail sending commands for Emacs. - -;; Copyright (C) 1985, 86, 92, 93, 94, 95, 96, 98, 2000, 2001 -;; Free Software Foundation, Inc. - -(defun mail-header-end () - "Return the buffer location of the end of headers, as a number." - (save-restriction - (widen) - (save-excursion - (rfc822-goto-eoh) - (point)))) + (defsubst match-string-no-properties (match) + (buffer-substring-no-properties + (match-beginning match) (match-end match)))) -(defun mail-mode-fill-paragraph (arg) - ;; Do something special only if within the headers. - (if (< (point) (mail-header-end)) - (let (beg end fieldname) - (when (prog1 (re-search-backward "^[-a-zA-Z]+:" nil 'yes) - (setq beg (point))) - (setq fieldname - (downcase (buffer-substring beg (1- (match-end 0)))))) - (forward-line 1) - ;; Find continuation lines and get rid of their continuation markers. - (while (looking-at "[ \t]") - (delete-horizontal-space) - (forward-line 1)) - (setq end (point-marker)) - (goto-char beg) - ;; If this field contains addresses, - ;; make sure we can fill after each address. - (if (member fieldname - '("to" "cc" "bcc" "from" "reply-to" - "resent-to" "resent-cc" "resent-bcc" - "resent-from" "resent-reply-to")) - (while (search-forward "," end t) - (or (looking-at "[ \t]") - (insert " ")))) - (fill-region-as-paragraph beg end) - ;; Mark all lines except the first as continuations. - (goto-char beg) - (forward-line 1) - (while (< (point) end) - (insert " ") - (forward-line 1)) - (move-marker end nil) - t))) +(unless (fboundp 'line-beginning-position) + (defalias 'line-beginning-position 'point-at-bol)) +(unless (fboundp 'line-end-position) + (defalias 'line-end-position 'point-at-eol)) + +(unless (fboundp 'timerp) + (defalias 'timerp 'itimerp)) +(unless (fboundp 'cancel-timer) + (defalias 'cancel-timer 'delete-itimer)) + (provide 'mh-xemacs-compat) +;;; Local Variables: +;;; sentence-end-double-space: nil +;;; End: + ;;; mh-xemacs-compat.el ends here
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/toolbar/reply-all.xpm Fri Nov 29 18:15:21 2002 +0000 @@ -0,0 +1,38 @@ +/* XPM */ +static char * reply_all_xpm[] = { +/* columns rows colors chars-per-pixel */ +"24 24 9 1", +" c None", +". c black", +"X c #673e666663d4", +"o c #eb46ea1de471", +"O c #a852a7bea3d2", +"+ c #ae51c17b9b26", +"@ c #8d4d97577838", +"# c #7c7c8b8b6e6e", +"$ c #5e0868be52d3", +/* pixels */ +" ", +" ", +" .... ", +" .....XooO. ", +" .....XOooooooO. ", +" .XOooooooooooXOO. ", +" .oXXooooooooOXOo. ", +" .OoOXXooooooXOoo. ", +" .oooOOXOooXXXooO. ", +" ........XXOoOXOo. ", +" ..++++@.ooooooXO. ", +" ..+@@@.oooooooXO. ", +" ..+@@@#.oooooooO.. ", +" ..++@@@#$.ooooO... ", +" .++++@@#.$ .. ", +" .+@@@#.o .. .O .O ", +" .+@#$. .O. .O .O ", +" .#$. .O .o .O .O ", +" .$. . .O .O .O ", +" . ....O .O .O ", +" .O .O .O .O ", +" .O .O .O .O ", +" .O .O .O .O ", +" "};
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/toolbar/reply-from.xpm Fri Nov 29 18:15:21 2002 +0000 @@ -0,0 +1,38 @@ +/* XPM */ +static char * reply_from_xpm[] = { +/* columns rows colors chars-per-pixel */ +"24 24 9 1", +" c None", +". c black", +"X c #673e666663d4", +"o c #eb46ea1de471", +"O c #a852a7bea3d2", +"+ c #ae51c17b9b26", +"@ c #8d4d97577838", +"# c #7c7c8b8b6e6e", +"$ c #5e0868be52d3", +/* pixels */ +" ", +" ", +" .... ", +" .....XooO. ", +" .....XOooooooO. ", +" .XOooooooooooXOO. ", +" .oXXooooooooOXOo. ", +" .OoOXXooooooXOoo. ", +" .oooOOXOooXXXooO. ", +" ........XXOoOXOo. ", +" ..++++@.ooooooXO. ", +" ..+@@@.oooooooXO. ", +" ..+@@@#.oooooooO.. ", +" ..++@@@#$.ooooO... ", +" #.$.oO... ", +" ...O . .... ", +" ...O ", +" .O ", +" ...O ..O .... .O O. ", +" ...O ..O .OO. ..... ", +" .O .O . . . . . ", +" .O .O .OO. . . . ", +" .O .O .... . O . ", +" "};
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/toolbar/reply-to.xpm Fri Nov 29 18:15:21 2002 +0000 @@ -0,0 +1,38 @@ +/* XPM */ +static char * reply_to_xpm[] = { +/* columns rows colors chars-per-pixel */ +"24 24 9 1", +" c None", +". c black", +"X c #673e666663d4", +"o c #eb46ea1de471", +"O c #a852a7bea3d2", +"+ c #ae51c17b9b26", +"@ c #8d4d97577838", +"# c #7c7c8b8b6e6e", +"$ c #5e0868be52d3", +/* pixels */ +" ", +" ", +" .... ", +" .....XooO. ", +" .....XOooooooO. ", +" .XOooooooooooXOO. ", +" .oXXooooooooOXOo. ", +" .OoOXXooooooXOoo. ", +" .oooOOXOooXXXooO. ", +" ........XXOoOXOo. ", +" ..++++@.ooooooXO. ", +" ..+@@@.oooooooXO. ", +" ..+@@@#.oooooooO.. ", +" ..++@@@#$.ooooO... ", +" .++++@@#.$ ", +" .+@@@#.o ...... ", +" .+@#$. OO.OOO ", +" .#$. .O ", +" .$. .O .... ", +" . .O .OO. ", +" .O . . ", +" .O .OO. ", +" .O .... ", +" "};