diff options
| author | Bill Wohler <wohler@newt.com> | 2006-01-29 19:34:57 +0000 |
|---|---|---|
| committer | Bill Wohler <wohler@newt.com> | 2006-01-29 19:34:57 +0000 |
| commit | 2dedf09d1b308c34d2790aad7635d17a0b1e2702 (patch) | |
| tree | d2350aa1bd807a9a2c9b722ae3cb24ddc4ca3f2b /lisp/mh-e | |
| parent | 1b6ed1fdd4dbed8459245f8535eb0749a52cd51b (diff) | |
| download | emacs-2dedf09d1b308c34d2790aad7635d17a0b1e2702.tar.gz | |
The Great Cleanup
Remove circular dependencies.
mh-e.el now includes few require statements and stands alone. Other
files should need to require mh-e.el, which requires mh-loaddefs.el,
plus variable-only files such as mh-scan.el.
Remove unneeded require statements.
Remove unneeded load statements, or replace them with non-fatal
require statements.
Break out components into their own files that were often spread
between many files. As a result, many functions that are now only used
within a single file no longer need to be autoloaded.
Rearrange and provide consistent headings.
Untabify.
* mh-acros.el: Update commentary to reflect current usage. Add
autoload cookies to all macros.
(mh-require-cl): Merge docstring and comment.
(mh-do-in-xemacs): Fix typo in docstring.
(assoc-string): Move to new file mh-compat.el.
(with-mh-folder-updating, mh-in-show-buffer)
(mh-do-at-event-location, mh-seq-msgs): Move here from mh-utils.el.
(mh-iterate-on-messages-in-region, mh-iterate-on-range): Move here
from mh-seq.el.
* mh-alias.el (mh-address-mail-regexp)
(mh-goto-address-find-address-at-point): Move here from mh-utils.el.
(mh-folder-line-matches-show-buffer-p): Move here from mh-e.el.
* mh-buffers.el: Update descriptive text.
* mh-comp.el (mh-note-repl, mh-note-forw, mh-note-dist): Move to new
file mh-scan.el.
(mh-yank-hooks, mh-to-field-choices, mh-position-on-field)
(mh-letter-menu, mh-letter-mode-help-messages)
(mh-letter-buttons-init-flag, mh-letter-mode)
(mh-font-lock-field-data, mh-letter-header-end)
(mh-auto-fill-for-letter, mh-to-field, mh-to-fcc)
(mh-file-is-vcard-p, mh-insert-signature, mh-check-whom)
(mh-insert-letter, mh-extract-from-attribution, mh-yank-cur-msg)
(mh-filter-out-non-text, mh-insert-prefix-string)
(mh-current-fill-prefix, mh-open-line, mh-complete-word)
(mh-folder-expand-at-point, mh-letter-complete-function-alist)
(mh-letter-complete, mh-letter-complete-or-space)
(mh-letter-confirm-address, mh-letter-header-field-at-point)
(mh-letter-next-header-field-or-indent)
(mh-letter-next-header-field, mh-letter-previous-header-field)
(mh-letter-skipped-header-field-p)
(mh-letter-skip-leading-whitespace-in-header-field)
(mh-hidden-header-keymap)
(mh-letter-toggle-header-field-display-button)
(mh-letter-toggle-header-field-display)
(mh-letter-truncate-header-field, mh-letter-mode-map): Move to new
file mh-letter.el.
(mh-letter-mode-map, mh-sent-from-folder, mh-send-args)
(mh-pgp-support-flag, mh-x-mailer-string)
(mh-letter-header-field-regexp): Move to mh-e.el.
(mh-goto-header-field, mh-goto-header-end)
(mh-extract-from-header-value, mh-beginning-of-word): Move to
mh-utils.el.
(mh-insert-header-separator): Move to mh-comp.el.
(mh-display-completion-list-compat): Move to new file mh-compat.el.
* mh-compat.el: New file.
(assoc-string): Move here from mh-acros.el.
(mh-display-completion-list): Move here from mh-comp.el.
* mh-customize.el: Move content into mh-e.el and remove.
* mh-e.el (mh-folder-mode-map, mh-folder-seq-tool-bar-map)
(mh-folder-tool-bar-map, mh-inc-spool-map, mh-letter-mode-map)
(mh-letter-tool-bar-map, mh-search-mode-map, mh-show-mode-map)
(mh-show-seq-tool-bar-map, mh-show-tool-bar-map): All maps now
declared here so that they can be used in docstrings.
(mh-sent-from-folder, mh-sent-from-msg)
(mh-letter-header-field-regexp, mh-pgp-support-flag)
(mh-x-mailer-string): Move here from mh-comp.el.
(mh-folder-line-matches-show-buffer-p): Move to mh-alias.el.
(mh-thread-scan-line-map, mh-thread-scan-line-map-stack): Move here
from mh-seq.el.
(mh-draft-folder, mh-inbox, mh-user-path, mh-current-folder)
(mh-previous-window-config, mh-seen-list, mh-seq-list)
(mh-show-buffer, mh-showing-mode, mh-globals-hash)
(mh-show-folder-buffer, mh-mail-header-separator)
(mh-unseen-seq, mh-previous-seq, mh-page-to-next-msg-flag)
(mh-signature-separator, mh-signature-separator-regexp)
(mh-list-to-string, mh-list-to-string-1): Move here from mh-utils.el.
(mh-index-max-cmdline-args, mh-xargs, mh-quote-for-shell)
(mh-exec-cmd, mh-exec-cmd-error, mh-exec-cmd-daemon)
(mh-exec-cmd-env-daemon, mh-process-daemon, mh-exec-cmd-quiet)
(mh-exec-cmd-output)
(mh-exchange-point-and-mark-preserving-active-mark)
(mh-exec-lib-cmd-output, mh-handle-process-error): Move here from
deprecated file mh-exec.el.
(mh-path): Move here from deprecated file mh-customize.el.
(mh-sys-path, mh-variants, mh-variant-in-use, mh-progs, mh-lib)
(mh-flists-present-flag, mh-variants, mh-variant-mh-info)
(mh-variant-mu-mh-info, mh-variant-nmh-info, mh-file-command-p)
(mh-variant-set-variant, mh-variant-p, mh-profile-component)
(mh-profile-component-value, mh-defface-compat): Move here from
deprecated file mh-init.el.
(mh-goto-next-button, mh-folder-mime-action)
(mh-folder-toggle-mime-part, mh-folder-inline-mime-part)
(mh-folder-save-mime-part, mh-toggle-mime-buttons): Move to to
mh-mime.el.
(mh-scan-format-mh, mh-scan-format-nmh, mh-note-deleted)
(mh-note-refiled, mh-note-cur, mh-scan-good-msg-regexp)
(mh-scan-deleted-msg-regexp, mh-scan-refiled-msg-regexp)
(mh-scan-valid-regexp, mh-scan-cur-msg-number-regexp)
(mh-scan-date-regexp, mh-scan-rcpt-regexp, mh-scan-body-regexp)
(mh-scan-subject-regexp, mh-scan-sent-to-me-sender-regexp)
(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)
(mh-scan-field-destination-offset)
(mh-scan-field-from-start-offset, mh-scan-field-from-end-offset)
(mh-scan-field-subject-start-offset, mh-scan-format)
(mh-msg-num-width-to-column, mh-set-cmd-note): Move to new file
mh-scan.el.
(mh-partial-folder-mode-line-annotation)
(mh-folder-font-lock-keywords, mh-folder-font-lock-subject)
(mh-generate-sequence-font-lock, mh-last-destination)
(mh-last-destination-write, mh-first-msg-num, mh-last-msg-num)
(mh-rmail, mh-nmail, mh-delete-msg, mh-delete-msg-no-motion)
(mh-execute-commands, mh-first-msg, mh-header-display)
(mh-inc-folder, mh-last-msg, mh-next-undeleted-msg)
(mh-folder-from-address, mh-prompt-for-refile-folder)
(mh-refile-msg, mh-refile-or-write-again, mh-quit, mh-page-msg)
(mh-previous-page, mh-previous-undeleted-msg)
(mh-previous-unread-msg, mh-next-button, mh-prev-button)
(mh-reset-threads-and-narrowing, mh-rescan-folder)
(mh-write-msg-to-file, mh-toggle-showing, mh-undo)
(mh-visit-folder, mh-update-sequences, mh-delete-a-msg)
(mh-refile-a-msg, mh-next-msg, mh-next-unread-msg)
(mh-set-scan-mode, mh-undo-msg, mh-make-folder)
(mh-folder-sequence-menu, mh-folder-message-menu)
(mh-folder-folder-menu, mh-remove-xemacs-horizontal-scrollbar)
(mh-write-file-functions-compat, mh-folder-mode)
(mh-restore-desktop-buffer, mh-scan-folder)
(mh-regenerate-headers, mh-generate-new-cmd-note)
(mh-get-new-mail, mh-make-folder-mode-line, mh-goto-cur-msg)
(mh-process-or-undo-commands, mh-process-commands)
(mh-update-unseen, mh-delete-scan-msgs)
(mh-outstanding-commands-p): Move to new file mh-folder.el.
(mh-mapc, mh-colors-available-p, mh-colors-in-use-p)
(mh-make-local-vars, mh-coalesce-msg-list, mh-greaterp)
(mh-lessp): Move to mh-utils.el.
(mh-parse-flist-output-line, mh-folder-size-folder)
(mh-folder-size-flist, mh-folder-size, mh-add-sequence-notation)
(mh-remove-sequence-notation, mh-remove-cur-notation)
(mh-remove-all-notation, mh-delete-seq-locally)
(mh-read-folder-sequences, mh-read-msg-list)
(mh-notate-user-sequences, mh-internal-seqs, mh-internal-seq)
(mh-valid-seq-p, mh-delete-msg-from-seq, mh-catchup)
(mh-delete-a-msg-from-seq, mh-undefine-sequence)
(mh-define-sequence, mh-seq-containing-msg): Move to mh-seq.el.
(mh-xemacs-flag)
(mh-customize, mh-e, mh-alias, mh-folder, mh-folder-selection)
(mh-identity, mh-inc, mh-junk, mh-letter, mh-ranges)
(mh-scan-line-formats, mh-search, mh-sending-mail, mh-sequences)
(mh-show, mh-speedbar, mh-thread, mh-tool-bar, mh-hooks)
(mh-faces, mh-alias-completion-ignore-case-flag)
(mh-alias-expand-aliases-flag, mh-alias-flash-on-comma)
(mh-alias-insert-file, mh-alias-insertion-location)
(mh-alias-local-users, mh-alias-local-users-prefix)
(mh-alias-passwd-gecos-comma-separator-flag)
(mh-new-messages-folders, mh-ticked-messages-folders)
(mh-large-folder, mh-recenter-summary-flag)
(mh-recursive-folders-flag, mh-sortm-args)
(mh-default-folder-for-message-function, mh-default-folder-list)
(mh-default-folder-must-exist-flag, mh-default-folder-prefix)
(mh-identity-list, mh-auto-fields-list)
(mh-auto-fields-prompt-flag, mh-identity-default)
(mh-identity-handlers, mh-inc-prog, mh-inc-spool-list)
(mh-junk-choice, mh-junk-function-alist, mh-junk-choose)
(mh-junk-background, mh-junk-disposition, mh-junk-program)
(mh-compose-insertion, mh-compose-skipped-header-fields)
(mh-compose-space-does-completion-flag)
(mh-delete-yanked-msg-window-flag)
(mh-extract-from-attribution-verb, mh-ins-buf-prefix)
(mh-letter-complete-function, mh-letter-fill-column)
(mh-mml-method-default, mh-signature-file-name)
(mh-signature-separator-flag, mh-x-face-file, mh-yank-behavior)
(mh-interpret-number-as-range-flag, mh-adaptive-cmd-note-flag)
(mh-scan-format-file-check, mh-scan-format-file)
(mh-adaptive-cmd-note-flag-check, mh-scan-prog)
(mh-search-program, mh-compose-forward-as-mime-flag)
(mh-compose-letter-function, mh-compose-prompt-flag)
(mh-forward-subject-format, mh-insert-x-mailer-flag)
(mh-redist-full-contents-flag, mh-reply-default-reply-to)
(mh-reply-show-message-flag, mh-refile-preserves-sequences-flag)
(mh-tick-seq, mh-update-sequences-after-mh-show-flag)
(mh-bury-show-buffer-flag, mh-clean-message-header-flag)
(mh-decode-mime-flag, mh-display-buttons-for-alternatives-flag)
(mh-display-buttons-for-inline-parts-flag)
(mh-do-not-confirm-flag, mh-fetch-x-image-url)
(mh-graphical-smileys-flag, mh-graphical-emphasis-flag)
(mh-highlight-citation-style)
(mh-invisible-header-fields-internal)
(mh-delay-invisible-header-generation-flag)
(mh-invisible-header-fields, mh-invisible-header-fields-default)
(mh-invisible-header-fields-compiled, mh-invisible-headers)
(mh-lpr-command-format, mh-max-inline-image-height)
(mh-max-inline-image-width, mh-mhl-format-file)
(mh-mime-save-parts-default-directory, mh-print-background-flag)
(mh-show-maximum-size, mh-show-use-goto-addr-flag)
(mh-show-use-xface-flag, mh-store-default-directory)
(mh-summary-height, mh-speed-update-interval)
(mh-show-threads-flag, mh-tool-bar-search-function)
(mh-after-commands-processed-hook, mh-alias-reloaded-hook)
(mh-before-commands-processed-hook, mh-before-quit-hook)
(mh-before-send-letter-hook, mh-delete-msg-hook)
(mh-find-path-hook, mh-folder-mode-hook, mh-forward-hook)
(mh-inc-folder-hook, mh-insert-signature-hook)
(mh-kill-folder-suppress-prompt-hooks, mh-letter-mode-hook)
(mh-mh-to-mime-hook, mh-search-mode-hook, mh-quit-hook)
(mh-refile-msg-hook, mh-show-hook, mh-show-mode-hook)
(mh-unseen-updated-hook, mh-min-colors-defined-flag)
(mh-folder-address, mh-folder-body)
(mh-folder-cur-msg-number, mh-folder-date, mh-folder-deleted)
(mh-folder-followup, mh-folder-msg-number, mh-folder-refiled)
(mh-folder-sent-to-me-hint, mh-folder-sent-to-me-sender)
(mh-folder-subject, mh-folder-tick, mh-folder-to)
(mh-search-folder, mh-letter-header-field, mh-show-cc)
(mh-show-date, mh-show-from, mh-show-header, mh-show-pgg-bad)
(mh-show-pgg-good, mh-show-pgg-unknown, mh-show-signature)
(mh-show-subject, mh-show-to, mh-show-xface, mh-speedbar-folder)
(mh-speedbar-folder-with-unseen-messages)
(mh-speedbar-selected-folder)
(mh-speedbar-selected-folder-with-unseen-messages): Move here from
deprecated file mh-customize.el.
* mh-exec.el: Move content into mh-e.el and remove.
* mh-folder.el: New file. Contains mh-folder-mode from mh-e.el
* mh-funcs.el (mh-note-copied, mh-note-printed): Move to new file
mh-scan.el.
(mh-ephem-message, mh-help, mh-prefix-help): Move to mh-utils.el.
* mh-gnus.el (mm-uu-dissect-text-parts): Add.
(mh-mail-abbrev-make-syntax-table): Move to mh-utils.el and rename to
mail-abbrev-make-syntax-table.
* mh-identity.el (mh-identity-menu): New variable for existing menu.
(mh-identity-make-menu-no-autoload): New alias for
mh-identity-make-menu which can be called from mh-e.el.
(mh-identity-list-set): Move to mh-e.el.
(mh-identity-add-menu): New function
(mh-insert-identity): Add optional argument maybe-insert so that local
variable mh-identity-local does not have to be visible.
(mh-identity-handler-default):
* mh-inc.el (mh-inc-spool-map): Move declaration to mh-e.el (with rest
of keymaps). Update key binding for ? to call mh-help with help
messages in new argument.
(mh-inc-spool-make-no-autoload): New alias for mh-inc-spool-make which
can be called from mh-e.el.
(mh-inc-spool-list-set): Simplify update of mh-inc-spool-map-help.
* mh-init.el: Move content into mh-e.el and remove.
* mh-junk.el: Update requires, untabify, and add mh-autoload cookies.
* mh-letter.el: New file. Contains mh-letter-mode from mh-comp.el.
* mh-limit.el: New file. Contains display limit commands from
mh-mime.el.
* mh-mime.el: Rearrange for consistency with other files.
(mh-buffer-data, mh-mm-inline-media-tests): Move here from
mh-utils.el.
(mh-folder-inline-mime-part, mh-folder-save-mime-part)
(mh-folder-toggle-mime-part, mh-toggle-mime-buttons)
(mh-goto-next-button): Move here from mh-e.el.
* mh-print.el: Rearrange for consistency with other files.
* mh-scan.el: New file. Contains scan line constants and utilities
from XXX, mh-funcs, mh-utils.el.
* mh-search.el: Rearrange for consistency with other files.
(mh-search-mode-map): Drop C-c C-f {dr} bindings since these fields
which don't exist in the saved header. Replace C-c C-f f with C-c C-f
m per mail-mode consistency.
(mh-search-mode): Use mh-set-help instead of setting mh-help-messages.
* mh-seq.el (mh-thread-message, mh-thread-container)
(mh-thread-id-hash, mh-thread-subject-hash, mh-thread-id-table)
(mh-thread-id-index-map, mh-thread-index-id-map)
(mh-thread-scan-line-map, mh-thread-scan-line-map-stack)
(mh-thread-subject-container-hash, mh-thread-duplicates)
(mh-thread-history, mh-thread-body-width)
(mh-thread-find-msg-subject mh-thread-initialize-hash)
(mh-thread-initialize, mh-thread-id-container)
(mh-thread-remove-parent-link, mh-thread-add-link)
(mh-thread-ancestor-p, mh-thread-get-message-container)
(mh-thread-get-message, mh-thread-canonicalize-id)
(mh-thread-prune-subject, mh-thread-container-subject)
(mh-thread-rewind-pruning, mh-thread-prune-containers)
(mh-thread-sort-containers, mh-thread-group-by-subject)
(mh-thread-process-in-reply-to, mh-thread-set-tables)
(mh-thread-update-id-index-maps, mh-thread-generate)
(mh-thread-inc, mh-thread-generate-scan-lines)
(mh-thread-parse-scan-line, mh-thread-update-scan-line-map)
(mh-thread-add-spaces, mh-thread-print-scan-lines)
(mh-thread-folder, mh-toggle-threads, mh-thread-forget-message)
(mh-thread-current-indentation-level, mh-thread-next-sibling)
(mh-thread-previous-sibling, mh-thread-immediate-ancestor)
(mh-thread-ancestor, mh-thread-find-children)
(mh-message-id-regexp, mh-thread-delete, mh-thread-refile): Move to
new file mh-thread.el.
(mh-subject-to-sequence, mh-subject-to-sequence-unthreaded)
(mh-subject-to-sequence-threaded, mh-edit-pick-expr)
(mh-pick-args-list, mh-narrow-to-subject, mh-narrow-to-from)
(mh-narrow-to-cc, mh-narrow-to-to, mh-narrow-to-header-field)
(mh-current-message-header-field, mh-narrow-to-range)
(mh-delete-subject, mh-delete-subject-or-thread): Move to new file
mh-limit.el.
(mh-iterate-on-messages-in-region, mh-iterate-on-range): Move to
mh-acros.el.
(mh-internal-seqs, mh-catchup, mh-delete-msg-from-seq)
(mh-internal-seq, mh-valid-seq-p, mh-seq-containing-msg)
(mh-define-sequence, mh-undefine-sequence)
(mh-delete-a-msg-from-seq, mh-delete-seq-locally)
(mh-folder-size, mh-folder-size-flist, mh-folder-size-folder)
(mh-parse-flist-output-line, mh-read-folder-sequences)
(mh-read-msg-list, mh-notate-user-sequences)
(mh-remove-cur-notation, mh-add-sequence-notation)
(mh-remove-sequence-notation, mh-remove-all-notation): Move here from
mh-e.el.
(mh-make-seq, mh-seq-name, mh-find-seq, mh-seq-to-msgs)
(mh-add-msgs-to-seq, mh-notate): Move here from mh-utils.el.
* mh-show.el: New file. Contains mh-show-mode from mh-utils.el.
* mh-speed.el: Rearrange for consistency with other files.
* mh-thread.el: New file. Contains threading code from mh-seq.el.
* mh-tool-bar.el: New file. Contains tool bar creation code from
deprecated file mh-customize.el.
* mh-utils.el (recursive-load-depth-limit): Remove setting. No longer
needed.
(mh-scan-msg-number-regexp, mh-scan-msg-overflow-regexp)
(mh-scan-msg-format-regexp, mh-scan-msg-format-string)
(mh-scan-msg-search-regexp, mh-cmd-note, mh-note-seq)
(mh-update-scan-format, mh-msg-num-width): Move to new file
mh-scan.el.
(mh-show-buffer-mode-line-buffer-id, mh-letter-header-font-lock)
(mh-header-field-font-lock, mh-header-to-font-lock)
(mh-header-cc-font-lock, mh-header-subject-font-lock)
(mh-show-font-lock-keywords)
(mh-show-font-lock-keywords-with-cite)
(mh-show-font-lock-fontify-region)
(mh-gnus-article-highlight-citation, mh-showing-with-headers)
(mh-start-of-uncleaned-message, mh-invalidate-show-buffer)
(mh-unvisit-file, mh-defun-show-buffer, mh-show-mode-map)
(mh-show-sequence-menu, mh-show-message-menu)
(mh-show-folder-menu, mh-show-mode, mh-show-addr)
(mh-maybe-show, mh-show, mh-show-msg, mh-show-unquote-From)
(mh-msg-folder, mh-display-msg, mh-clean-msg-header): Move to new file
mh-show.el.
(mh-mail-header-separator, mh-signature-separator-regexp)
(mh-signature-separator, mh-globals-hash, mh-user-path)
(mh-draft-folder, mh-unseen-seq, mh-previous-seq, mh-inbox)
(mh-previous-window-config, mh-current-folder mh-show-buffer)
(mh-showing-mode, mh-show-mode-map, mh-show-folder-buffer)
(mh-showing-mode, mh-seq-list, mh-seen-list, mh-summary-height)
(mh-list-to-string, mh-list-to-string-1): Move to mh-e.el.
(mh-buffer-data, mh-mm-inline-media-tests): Move to mh-mime.el.
(mh-address-mail-regexp, mh-goto-address-find-address-at-point): Move
to mh-alias.el.
(mh-letter-font-lock-keywords): Move to new file mh-letter.el.
(mh-folder-filename, mh-msg-count, mh-recenter, mh-msg-filename)
(mh-show-mouse, mh-modify, mh-goto-msg, mh-set-folder-modified-p):
Move to new file mh-folder.el.
(with-mh-folder-updating, mh-in-show-buffer)
(mh-do-at-event-location, mh-seq-msgs): Moved to mh-acros.el.
(mh-make-seq, mh-seq-name, mh-notate, mh-find-seq)
(mh-seq-to-msgs, mh-add-msgs-to-seq, mh-canonicalize-sequence): Moved
to mh-seq.el.
(mh-show-xface-function, mh-uncompface-executable, mh-face-to-png)
(mh-uncompface, mh-icontopbm, mh-face-foreground-compat)
(mh-face-background-compat, mh-face-display-function)
(mh-show-xface, mh-picon-directory-list)
(mh-picon-existing-directory-list)
(mh-picon-cache, mh-picon-image-types)
(mh-picon-set-directory-list, mh-picon-get-image)
(mh-picon-file-contents, mh-picon-generate-path)
(mh-x-image-cache-directory, mh-x-image-scaling-function)
(mh-wget-executable, mh-wget-choice, mh-wget-option)
(mh-x-image-temp-file, mh-x-image-url, mh-x-image-marker)
(mh-x-image-url-cache-file, mh-x-image-scale-with-pnm)
(mh-x-image-scale-with-convert)
(url-unreserved-chars, url-hexify-string)
(mh-x-image-url-cache-canonicalize)
(mh-x-image-set-download-state, mh-x-image-get-download-state)
(mh-x-image-url-fetch-image, mh-x-image-display)
(mh-x-image-scale-and-display, mh-x-image-url-sane-p)
(mh-x-image-url-display): Move to new file mh-xface.el.
(mh-logo-display): Call mh-image-load-path.
(mh-find-path-run, mh-find-path): Move here from deprecated file
mh-init.el.
(mh-help-messages): Now an alist of modes to an alist of messages.
(mh-set-help): New function used to set mh-help-messages
(mh-help): Adjust for new format of mh-help-messages. Add
help-messages argument.
(mh-prefix-help): Refactor to use mh-help.
(mh-coalesce-msg-list, mh-greaterp, mh-lessp): Move here from mh-e.el.
(mh-clear-sub-folders-cache): New function added to avoid exposing
mh-sub-folders-cache variable.
* mh-xface.el: New file. Contains X-Face and Face header field display
routines from mh-utils.el.
Diffstat (limited to 'lisp/mh-e')
30 files changed, 13761 insertions, 12850 deletions
diff --git a/lisp/mh-e/.cvsignore b/lisp/mh-e/.cvsignore index 19a8825a278..2e5b1740f15 100644 --- a/lisp/mh-e/.cvsignore +++ b/lisp/mh-e/.cvsignore @@ -1,2 +1,3 @@ mh-autoloads.el +mh-cus-load.el mh-loaddefs.el diff --git a/lisp/mh-e/ChangeLog b/lisp/mh-e/ChangeLog index 3bfd7172c9b..3b7e56a571d 100644 --- a/lisp/mh-e/ChangeLog +++ b/lisp/mh-e/ChangeLog @@ -1,3 +1,430 @@ +2006-01-29 Bill Wohler <wohler@newt.com> + + The Great Cleanup + Remove circular dependencies. mh-e.el now includes few require + statements and stands alone. Other files should need to require + mh-e.el, which requires mh-loaddefs.el, plus variable-only files + such as mh-scan.el. + Remove unneeded require statements. + Remove unneeded load statements, or replace them with non-fatal + require statements. + Break out components into their own files that were often spread + between many files. + As a result, many functions that are now only used within a single + file no longer need to be autoloaded. + Rearrange and provide consistent headings. + Untabify. + + * mh-acros.el: Update commentary to reflect current usage. Add + autoload cookies to all macros. + (mh-require-cl): Merge docstring and comment. + (mh-do-in-xemacs): Fix typo in docstring. + (assoc-string): Move to new file mh-compat.el. + (with-mh-folder-updating, mh-in-show-buffer) + (mh-do-at-event-location, mh-seq-msgs): Move here from + mh-utils.el. + (mh-iterate-on-messages-in-region, mh-iterate-on-range): Move here + from mh-seq.el. + + * mh-alias.el (mh-address-mail-regexp) + (mh-goto-address-find-address-at-point): Move here from + mh-utils.el. + (mh-folder-line-matches-show-buffer-p): Move here from mh-e.el. + + * mh-buffers.el: Update descriptive text. + + * mh-comp.el (mh-note-repl, mh-note-forw, mh-note-dist): Move to + new file mh-scan.el. + (mh-yank-hooks, mh-to-field-choices, mh-position-on-field) + (mh-letter-menu, mh-letter-mode-help-messages) + (mh-letter-buttons-init-flag, mh-letter-mode) + (mh-font-lock-field-data, mh-letter-header-end) + (mh-auto-fill-for-letter, mh-to-field, mh-to-fcc) + (mh-file-is-vcard-p, mh-insert-signature, mh-check-whom) + (mh-insert-letter, mh-extract-from-attribution, mh-yank-cur-msg) + (mh-filter-out-non-text, mh-insert-prefix-string) + (mh-current-fill-prefix, mh-open-line, mh-complete-word) + (mh-folder-expand-at-point, mh-letter-complete-function-alist) + (mh-letter-complete, mh-letter-complete-or-space) + (mh-letter-confirm-address, mh-letter-header-field-at-point) + (mh-letter-next-header-field-or-indent) + (mh-letter-next-header-field, mh-letter-previous-header-field) + (mh-letter-skipped-header-field-p) + (mh-letter-skip-leading-whitespace-in-header-field) + (mh-hidden-header-keymap) + (mh-letter-toggle-header-field-display-button) + (mh-letter-toggle-header-field-display) + (mh-letter-truncate-header-field, mh-letter-mode-map): Move to new + file mh-letter.el. + (mh-letter-mode-map, mh-sent-from-folder, mh-send-args) + (mh-pgp-support-flag, mh-x-mailer-string) + (mh-letter-header-field-regexp): Move to mh-e.el. + (mh-goto-header-field, mh-goto-header-end) + (mh-extract-from-header-value, mh-beginning-of-word): Move to + mh-utils.el. + (mh-insert-header-separator): Move to mh-comp.el. + (mh-display-completion-list-compat): Move to new file + mh-compat.el. + + * mh-compat.el: New file. + (assoc-string): Move here from mh-acros.el. + (mh-display-completion-list): Move here from mh-comp.el. + + * mh-customize.el: Move content into mh-e.el and remove. + + * mh-e.el (mh-folder-mode-map, mh-folder-seq-tool-bar-map) + (mh-folder-tool-bar-map, mh-inc-spool-map, mh-letter-mode-map) + (mh-letter-tool-bar-map, mh-search-mode-map, mh-show-mode-map) + (mh-show-seq-tool-bar-map, mh-show-tool-bar-map): All maps now + declared here so that they can be used in docstrings. + (mh-sent-from-folder, mh-sent-from-msg) + (mh-letter-header-field-regexp, mh-pgp-support-flag) + (mh-x-mailer-string): Move here from mh-comp.el. + (mh-folder-line-matches-show-buffer-p): Move to mh-alias.el. + (mh-thread-scan-line-map, mh-thread-scan-line-map-stack): Move + here from mh-seq.el. + (mh-draft-folder, mh-inbox, mh-user-path, mh-current-folder) + (mh-previous-window-config, mh-seen-list, mh-seq-list) + (mh-show-buffer, mh-showing-mode, mh-globals-hash) + (mh-show-folder-buffer, mh-mail-header-separator) + (mh-unseen-seq, mh-previous-seq, mh-page-to-next-msg-flag) + (mh-signature-separator, mh-signature-separator-regexp) + (mh-list-to-string, mh-list-to-string-1): Move here from + mh-utils.el. + (mh-index-max-cmdline-args, mh-xargs, mh-quote-for-shell) + (mh-exec-cmd, mh-exec-cmd-error, mh-exec-cmd-daemon) + (mh-exec-cmd-env-daemon, mh-process-daemon, mh-exec-cmd-quiet) + (mh-exec-cmd-output) + (mh-exchange-point-and-mark-preserving-active-mark) + (mh-exec-lib-cmd-output, mh-handle-process-error): Move here from + deprecated file mh-exec.el. + (mh-path): Move here from deprecated file mh-customize.el. + (mh-sys-path, mh-variants, mh-variant-in-use, mh-progs, mh-lib) + (mh-flists-present-flag, mh-variants, mh-variant-mh-info) + (mh-variant-mu-mh-info, mh-variant-nmh-info, mh-file-command-p) + (mh-variant-set-variant, mh-variant-p, mh-profile-component) + (mh-profile-component-value, mh-defface-compat): Move here from + deprecated file mh-init.el. + (mh-goto-next-button, mh-folder-mime-action) + (mh-folder-toggle-mime-part, mh-folder-inline-mime-part) + (mh-folder-save-mime-part, mh-toggle-mime-buttons): Move to to + mh-mime.el. + (mh-scan-format-mh, mh-scan-format-nmh, mh-note-deleted) + (mh-note-refiled, mh-note-cur, mh-scan-good-msg-regexp) + (mh-scan-deleted-msg-regexp, mh-scan-refiled-msg-regexp) + (mh-scan-valid-regexp, mh-scan-cur-msg-number-regexp) + (mh-scan-date-regexp, mh-scan-rcpt-regexp, mh-scan-body-regexp) + (mh-scan-subject-regexp, mh-scan-sent-to-me-sender-regexp) + (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) + (mh-scan-field-destination-offset) + (mh-scan-field-from-start-offset, mh-scan-field-from-end-offset) + (mh-scan-field-subject-start-offset, mh-scan-format) + (mh-msg-num-width-to-column, mh-set-cmd-note): Move to new file + mh-scan.el. + (mh-partial-folder-mode-line-annotation) + (mh-folder-font-lock-keywords, mh-folder-font-lock-subject) + (mh-generate-sequence-font-lock, mh-last-destination) + (mh-last-destination-write, mh-first-msg-num, mh-last-msg-num) + (mh-rmail, mh-nmail, mh-delete-msg, mh-delete-msg-no-motion) + (mh-execute-commands, mh-first-msg, mh-header-display) + (mh-inc-folder, mh-last-msg, mh-next-undeleted-msg) + (mh-folder-from-address, mh-prompt-for-refile-folder) + (mh-refile-msg, mh-refile-or-write-again, mh-quit, mh-page-msg) + (mh-previous-page, mh-previous-undeleted-msg) + (mh-previous-unread-msg, mh-next-button, mh-prev-button) + (mh-reset-threads-and-narrowing, mh-rescan-folder) + (mh-write-msg-to-file, mh-toggle-showing, mh-undo) + (mh-visit-folder, mh-update-sequences, mh-delete-a-msg) + (mh-refile-a-msg, mh-next-msg, mh-next-unread-msg) + (mh-set-scan-mode, mh-undo-msg, mh-make-folder) + (mh-folder-sequence-menu, mh-folder-message-menu) + (mh-folder-folder-menu, mh-remove-xemacs-horizontal-scrollbar) + (mh-write-file-functions-compat, mh-folder-mode) + (mh-restore-desktop-buffer, mh-scan-folder) + (mh-regenerate-headers, mh-generate-new-cmd-note) + (mh-get-new-mail, mh-make-folder-mode-line, mh-goto-cur-msg) + (mh-process-or-undo-commands, mh-process-commands) + (mh-update-unseen, mh-delete-scan-msgs) + (mh-outstanding-commands-p): Move to new file mh-folder.el. + (mh-mapc, mh-colors-available-p, mh-colors-in-use-p) + (mh-make-local-vars, mh-coalesce-msg-list, mh-greaterp) + (mh-lessp): Move to mh-utils.el. + (mh-parse-flist-output-line, mh-folder-size-folder) + (mh-folder-size-flist, mh-folder-size, mh-add-sequence-notation) + (mh-remove-sequence-notation, mh-remove-cur-notation) + (mh-remove-all-notation, mh-delete-seq-locally) + (mh-read-folder-sequences, mh-read-msg-list) + (mh-notate-user-sequences, mh-internal-seqs, mh-internal-seq) + (mh-valid-seq-p, mh-delete-msg-from-seq, mh-catchup) + (mh-delete-a-msg-from-seq, mh-undefine-sequence) + (mh-define-sequence, mh-seq-containing-msg): Move to mh-seq.el. + (mh-xemacs-flag) + (mh-customize, mh-e, mh-alias, mh-folder, mh-folder-selection) + (mh-identity, mh-inc, mh-junk, mh-letter, mh-ranges) + (mh-scan-line-formats, mh-search, mh-sending-mail, mh-sequences) + (mh-show, mh-speedbar, mh-thread, mh-tool-bar, mh-hooks) + (mh-faces, mh-alias-completion-ignore-case-flag) + (mh-alias-expand-aliases-flag, mh-alias-flash-on-comma) + (mh-alias-insert-file, mh-alias-insertion-location) + (mh-alias-local-users, mh-alias-local-users-prefix) + (mh-alias-passwd-gecos-comma-separator-flag) + (mh-new-messages-folders, mh-ticked-messages-folders) + (mh-large-folder, mh-recenter-summary-flag) + (mh-recursive-folders-flag, mh-sortm-args) + (mh-default-folder-for-message-function, mh-default-folder-list) + (mh-default-folder-must-exist-flag, mh-default-folder-prefix) + (mh-identity-list, mh-auto-fields-list) + (mh-auto-fields-prompt-flag, mh-identity-default) + (mh-identity-handlers, mh-inc-prog, mh-inc-spool-list) + (mh-junk-choice, mh-junk-function-alist, mh-junk-choose) + (mh-junk-background, mh-junk-disposition, mh-junk-program) + (mh-compose-insertion, mh-compose-skipped-header-fields) + (mh-compose-space-does-completion-flag) + (mh-delete-yanked-msg-window-flag) + (mh-extract-from-attribution-verb, mh-ins-buf-prefix) + (mh-letter-complete-function, mh-letter-fill-column) + (mh-mml-method-default, mh-signature-file-name) + (mh-signature-separator-flag, mh-x-face-file, mh-yank-behavior) + (mh-interpret-number-as-range-flag, mh-adaptive-cmd-note-flag) + (mh-scan-format-file-check, mh-scan-format-file) + (mh-adaptive-cmd-note-flag-check, mh-scan-prog) + (mh-search-program, mh-compose-forward-as-mime-flag) + (mh-compose-letter-function, mh-compose-prompt-flag) + (mh-forward-subject-format, mh-insert-x-mailer-flag) + (mh-redist-full-contents-flag, mh-reply-default-reply-to) + (mh-reply-show-message-flag, mh-refile-preserves-sequences-flag) + (mh-tick-seq, mh-update-sequences-after-mh-show-flag) + (mh-bury-show-buffer-flag, mh-clean-message-header-flag) + (mh-decode-mime-flag, mh-display-buttons-for-alternatives-flag) + (mh-display-buttons-for-inline-parts-flag) + (mh-do-not-confirm-flag, mh-fetch-x-image-url) + (mh-graphical-smileys-flag, mh-graphical-emphasis-flag) + (mh-highlight-citation-style) + (mh-invisible-header-fields-internal) + (mh-delay-invisible-header-generation-flag) + (mh-invisible-header-fields, mh-invisible-header-fields-default) + (mh-invisible-header-fields-compiled, mh-invisible-headers) + (mh-lpr-command-format, mh-max-inline-image-height) + (mh-max-inline-image-width, mh-mhl-format-file) + (mh-mime-save-parts-default-directory, mh-print-background-flag) + (mh-show-maximum-size, mh-show-use-goto-addr-flag) + (mh-show-use-xface-flag, mh-store-default-directory) + (mh-summary-height, mh-speed-update-interval) + (mh-show-threads-flag, mh-tool-bar-search-function) + (mh-after-commands-processed-hook, mh-alias-reloaded-hook) + (mh-before-commands-processed-hook, mh-before-quit-hook) + (mh-before-send-letter-hook, mh-delete-msg-hook) + (mh-find-path-hook, mh-folder-mode-hook, mh-forward-hook) + (mh-inc-folder-hook, mh-insert-signature-hook) + (mh-kill-folder-suppress-prompt-hooks, mh-letter-mode-hook) + (mh-mh-to-mime-hook, mh-search-mode-hook, mh-quit-hook) + (mh-refile-msg-hook, mh-show-hook, mh-show-mode-hook) + (mh-unseen-updated-hook, mh-min-colors-defined-flag) + (mh-folder-address, mh-folder-body) + (mh-folder-cur-msg-number, mh-folder-date, mh-folder-deleted) + (mh-folder-followup, mh-folder-msg-number, mh-folder-refiled) + (mh-folder-sent-to-me-hint, mh-folder-sent-to-me-sender) + (mh-folder-subject, mh-folder-tick, mh-folder-to) + (mh-search-folder, mh-letter-header-field, mh-show-cc) + (mh-show-date, mh-show-from, mh-show-header, mh-show-pgg-bad) + (mh-show-pgg-good, mh-show-pgg-unknown, mh-show-signature) + (mh-show-subject, mh-show-to, mh-show-xface, mh-speedbar-folder) + (mh-speedbar-folder-with-unseen-messages) + (mh-speedbar-selected-folder) + (mh-speedbar-selected-folder-with-unseen-messages): Move here from + deprecated file mh-customize.el. + + * mh-exec.el: Move content into mh-e.el and remove. + + * mh-folder.el: New file. Contains mh-folder-mode from mh-e.el + + * mh-funcs.el (mh-note-copied, mh-note-printed): Move to new file + mh-scan.el. + (mh-ephem-message, mh-help, mh-prefix-help): Move to mh-utils.el. + + * mh-gnus.el (mm-uu-dissect-text-parts): Add. + (mh-mail-abbrev-make-syntax-table): Move to mh-utils.el and rename + to mail-abbrev-make-syntax-table. + + * mh-identity.el (mh-identity-menu): New variable for existing + menu. + (mh-identity-make-menu-no-autoload): New alias for + mh-identity-make-menu which can be called from mh-e.el. + (mh-identity-list-set): Move to mh-e.el. + (mh-identity-add-menu): New function + (mh-insert-identity): Add optional argument maybe-insert so that + local variable mh-identity-local does not have to be visible. + (mh-identity-handler-default): + + * mh-inc.el (mh-inc-spool-map): Move declaration to mh-e.el (with + rest of keymaps). Update key binding for ? to call mh-help with + help messages in new argument. + (mh-inc-spool-make-no-autoload): New alias for mh-inc-spool-make + which can be called from mh-e.el. + (mh-inc-spool-list-set): Simplify update of mh-inc-spool-map-help. + + * mh-init.el: Move content into mh-e.el and remove. + + * mh-junk.el: Update requires, untabify, and add mh-autoload + cookies. + + * mh-letter.el: New file. Contains mh-letter-mode from mh-comp.el. + + * mh-limit.el: New file. Contains display limit commands from + mh-mime.el. + + * mh-mime.el: Rearrange for consistency with other files. + (mh-buffer-data, mh-mm-inline-media-tests): Move here from + mh-utils.el. + (mh-folder-inline-mime-part, mh-folder-save-mime-part) + (mh-folder-toggle-mime-part, mh-toggle-mime-buttons) + (mh-goto-next-button): Move here from mh-e.el. + + * mh-print.el: Rearrange for consistency with other files. + + * mh-scan.el: New file. Contains scan line constants and utilities + from XXX, mh-funcs, mh-utils.el. + + * mh-search.el: Rearrange for consistency with other files. + (mh-search-mode-map): Drop C-c C-f {dr} bindings since these + fields which don't exist in the saved header. Replace C-c C-f f + with C-c C-f m per mail-mode consistency. + (mh-search-mode): Use mh-set-help instead of setting + mh-help-messages. + + * mh-seq.el (mh-thread-message, mh-thread-container) + (mh-thread-id-hash, mh-thread-subject-hash, mh-thread-id-table) + (mh-thread-id-index-map, mh-thread-index-id-map) + (mh-thread-scan-line-map, mh-thread-scan-line-map-stack) + (mh-thread-subject-container-hash, mh-thread-duplicates) + (mh-thread-history, mh-thread-body-width) + (mh-thread-find-msg-subject mh-thread-initialize-hash) + (mh-thread-initialize, mh-thread-id-container) + (mh-thread-remove-parent-link, mh-thread-add-link) + (mh-thread-ancestor-p, mh-thread-get-message-container) + (mh-thread-get-message, mh-thread-canonicalize-id) + (mh-thread-prune-subject, mh-thread-container-subject) + (mh-thread-rewind-pruning, mh-thread-prune-containers) + (mh-thread-sort-containers, mh-thread-group-by-subject) + (mh-thread-process-in-reply-to, mh-thread-set-tables) + (mh-thread-update-id-index-maps, mh-thread-generate) + (mh-thread-inc, mh-thread-generate-scan-lines) + (mh-thread-parse-scan-line, mh-thread-update-scan-line-map) + (mh-thread-add-spaces, mh-thread-print-scan-lines) + (mh-thread-folder, mh-toggle-threads, mh-thread-forget-message) + (mh-thread-current-indentation-level, mh-thread-next-sibling) + (mh-thread-previous-sibling, mh-thread-immediate-ancestor) + (mh-thread-ancestor, mh-thread-find-children) + (mh-message-id-regexp, mh-thread-delete, mh-thread-refile): Move + to new file mh-thread.el. + (mh-subject-to-sequence, mh-subject-to-sequence-unthreaded) + (mh-subject-to-sequence-threaded, mh-edit-pick-expr) + (mh-pick-args-list, mh-narrow-to-subject, mh-narrow-to-from) + (mh-narrow-to-cc, mh-narrow-to-to, mh-narrow-to-header-field) + (mh-current-message-header-field, mh-narrow-to-range) + (mh-delete-subject, mh-delete-subject-or-thread): Move to new file + mh-limit.el. + (mh-iterate-on-messages-in-region, mh-iterate-on-range): Move to + mh-acros.el. + (mh-internal-seqs, mh-catchup, mh-delete-msg-from-seq) + (mh-internal-seq, mh-valid-seq-p, mh-seq-containing-msg) + (mh-define-sequence, mh-undefine-sequence) + (mh-delete-a-msg-from-seq, mh-delete-seq-locally) + (mh-folder-size, mh-folder-size-flist, mh-folder-size-folder) + (mh-parse-flist-output-line, mh-read-folder-sequences) + (mh-read-msg-list, mh-notate-user-sequences) + (mh-remove-cur-notation, mh-add-sequence-notation) + (mh-remove-sequence-notation, mh-remove-all-notation): Move here + from mh-e.el. + (mh-make-seq, mh-seq-name, mh-find-seq, mh-seq-to-msgs) + (mh-add-msgs-to-seq, mh-notate): Move here from mh-utils.el. + + * mh-show.el: New file. Contains mh-show-mode from mh-utils.el. + + * mh-speed.el: Rearrange for consistency with other files. + + * mh-thread.el: New file. Contains threading code from mh-seq.el. + + * mh-tool-bar.el: New file. Contains tool bar creation code from + deprecated file mh-customize.el. + + * mh-utils.el (recursive-load-depth-limit): Remove setting. No + longer needed. + (mh-scan-msg-number-regexp, mh-scan-msg-overflow-regexp) + (mh-scan-msg-format-regexp, mh-scan-msg-format-string) + (mh-scan-msg-search-regexp, mh-cmd-note, mh-note-seq) + (mh-update-scan-format, mh-msg-num-width): Move to new file + mh-scan.el. + (mh-show-buffer-mode-line-buffer-id, mh-letter-header-font-lock) + (mh-header-field-font-lock, mh-header-to-font-lock) + (mh-header-cc-font-lock, mh-header-subject-font-lock) + (mh-show-font-lock-keywords) + (mh-show-font-lock-keywords-with-cite) + (mh-show-font-lock-fontify-region) + (mh-gnus-article-highlight-citation, mh-showing-with-headers) + (mh-start-of-uncleaned-message, mh-invalidate-show-buffer) + (mh-unvisit-file, mh-defun-show-buffer, mh-show-mode-map) + (mh-show-sequence-menu, mh-show-message-menu) + (mh-show-folder-menu, mh-show-mode, mh-show-addr) + (mh-maybe-show, mh-show, mh-show-msg, mh-show-unquote-From) + (mh-msg-folder, mh-display-msg, mh-clean-msg-header): Move to new + file mh-show.el. + (mh-mail-header-separator, mh-signature-separator-regexp) + (mh-signature-separator, mh-globals-hash, mh-user-path) + (mh-draft-folder, mh-unseen-seq, mh-previous-seq, mh-inbox) + (mh-previous-window-config, mh-current-folder mh-show-buffer) + (mh-showing-mode, mh-show-mode-map, mh-show-folder-buffer) + (mh-showing-mode, mh-seq-list, mh-seen-list, mh-summary-height) + (mh-list-to-string, mh-list-to-string-1): Move to mh-e.el. + (mh-buffer-data, mh-mm-inline-media-tests): Move to mh-mime.el. + (mh-address-mail-regexp, mh-goto-address-find-address-at-point): + Move to mh-alias.el. + (mh-letter-font-lock-keywords): Move to new file mh-letter.el. + (mh-folder-filename, mh-msg-count, mh-recenter, mh-msg-filename) + (mh-show-mouse, mh-modify, mh-goto-msg, mh-set-folder-modified-p): + Move to new file mh-folder.el. + (with-mh-folder-updating, mh-in-show-buffer) + (mh-do-at-event-location, mh-seq-msgs): Moved to mh-acros.el. + (mh-make-seq, mh-seq-name, mh-notate, mh-find-seq) + (mh-seq-to-msgs, mh-add-msgs-to-seq, mh-canonicalize-sequence): + Moved to mh-seq.el. + (mh-show-xface-function, mh-uncompface-executable, mh-face-to-png) + (mh-uncompface, mh-icontopbm, mh-face-foreground-compat) + (mh-face-background-compat, mh-face-display-function) + (mh-show-xface, mh-picon-directory-list) + (mh-picon-existing-directory-list) + (mh-picon-cache, mh-picon-image-types) + (mh-picon-set-directory-list, mh-picon-get-image) + (mh-picon-file-contents, mh-picon-generate-path) + (mh-x-image-cache-directory, mh-x-image-scaling-function) + (mh-wget-executable, mh-wget-choice, mh-wget-option) + (mh-x-image-temp-file, mh-x-image-url, mh-x-image-marker) + (mh-x-image-url-cache-file, mh-x-image-scale-with-pnm) + (mh-x-image-scale-with-convert) + (url-unreserved-chars, url-hexify-string) + (mh-x-image-url-cache-canonicalize) + (mh-x-image-set-download-state, mh-x-image-get-download-state) + (mh-x-image-url-fetch-image, mh-x-image-display) + (mh-x-image-scale-and-display, mh-x-image-url-sane-p) + (mh-x-image-url-display): Move to new file mh-xface.el. + (mh-logo-display): Call mh-image-load-path. + (mh-find-path-run, mh-find-path): Move here from deprecated file + mh-init.el. + (mh-help-messages): Now an alist of modes to an alist of messages. + (mh-set-help): New function used to set mh-help-messages + (mh-help): Adjust for new format of mh-help-messages. Add + help-messages argument. + (mh-prefix-help): Refactor to use mh-help. + (mh-coalesce-msg-list, mh-greaterp, mh-lessp): Move here from + mh-e.el. + (mh-clear-sub-folders-cache): New function added to avoid exposing + mh-sub-folders-cache variable. + + * mh-xface.el: New file. Contains X-Face and Face header field + display routines from mh-utils.el. + 2006-01-17 Bill Wohler <wohler@newt.com> * mh-acros.el (assoc-string): Fix typo in argument. diff --git a/lisp/mh-e/mh-acros.el b/lisp/mh-e/mh-acros.el index f126e5e3ff1..313d3f19a2d 100644 --- a/lisp/mh-e/mh-acros.el +++ b/lisp/mh-e/mh-acros.el @@ -1,4 +1,4 @@ -;;; mh-acros.el --- Macros used in MH-E +;;; mh-acros.el --- macros used in MH-E ;; Copyright (C) 2004, 2006 Free Software Foundation, Inc. @@ -26,54 +26,62 @@ ;;; Commentary: -;; This file contains most, if not all, macros. It is so named with a -;; silent "m" so that it is compiled first. Otherwise, "make -;; recompile" in CVS Emacs may use compiled files with stale macro -;; definitions. +;; This file contains all macros that are used in more than one file. +;; If you run "make recompile" in CVS Emacs and see the message +;; "Source is newer than compiled," it is a sign that macro probably +;; needs to be moved here. -;; This file must always be included like this: -;; -;; (eval-when-compile (require 'mh-acros)) +;; Historically, it was so named with a silent "m" so that it would be +;; compiled first. Otherwise, "make recompile" in CVS Emacs would use +;; compiled files with stale macro definitions. Later, no-byte-compile +;; was added to the Local Variables section to avoid this problem and +;; because it's pointless to compile a file full of macros. But we +;; kept the name. ;;; Change Log: ;;; Code: (require 'cl) -(require 'advice) -;; The Emacs coding conventions require that the cl package not be required at -;; runtime. However, the cl package in versions of Emacs prior to 21.4 left cl -;; routines in their macro expansions. Use mh-require-cl to provide the cl -;; routines in the best way possible. + + +;;; Compatibility + +;;;###mh-autoload (defmacro mh-require-cl () "Macro to load \"cl\" if needed. -Some versions of \"cl\" produce code for the expansion of -\(setf (gethash ...) ...) that uses functions in \"cl\" at run -time. This macro recognizes that and loads \"cl\" where -appropriate." + +Emacs coding conventions require that the \"cl\" package not be +required at runtime. However, the \"cl\" package in Emacs 21.4 +and earlier left \"cl\" routines in their macro expansions. In +particular, the expansion of (setf (gethash ...) ...) used +functions in \"cl\" at run time. This macro recognizes that and +loads \"cl\" appropriately." (if (eq (car (macroexpand '(setf (gethash foo bar) baz))) 'cl-puthash) `(require 'cl) `(eval-when-compile (require 'cl)))) -;; Macros to generate correct code for different emacs variants - +;;;###mh-autoload (defmacro mh-do-in-gnu-emacs (&rest body) "Execute BODY if in GNU Emacs." (unless (featurep 'xemacs) `(progn ,@body))) (put 'mh-do-in-gnu-emacs 'lisp-indent-hook 'defun) +;;;###mh-autoload (defmacro mh-do-in-xemacs (&rest body) - "Execute BODY if in GNU Emacs." + "Execute BODY if in XEmacs." (when (featurep 'xemacs) `(progn ,@body))) (put 'mh-do-in-xemacs 'lisp-indent-hook 'defun) +;;;###mh-autoload (defmacro mh-funcall-if-exists (function &rest args) "Call FUNCTION with ARGS as parameters if it exists." (when (fboundp function) `(when (fboundp ',function) (funcall ',function ,@args)))) +;;;###mh-autoload (defmacro mh-defun-compat (function arg-list &rest body) "This is a macro to define functions which are not defined. It is used for functions which were added to Emacs recently. @@ -84,6 +92,7 @@ list, ARG-LIST and body, BODY." `(defun ,function ,arg-list ,@body)))) (put 'mh-defun-compat 'lisp-indent-function 'defun) +;;;###mh-autoload (defmacro mh-defmacro-compat (function arg-list &rest body) "This is a macro to define functions which are not defined. It is used for macros which were added to Emacs recently. @@ -94,6 +103,11 @@ list, ARG-LIST and body, BODY." `(defmacro ,function ,arg-list ,@body)))) (put 'mh-defmacro-compat 'lisp-indent-function 'defun) + + +;;; Miscellaneous + +;;;###mh-autoload (defmacro mh-make-local-hook (hook) "Make HOOK local if needed. XEmacs and versions of GNU Emacs before 21.1 require @@ -102,6 +116,7 @@ XEmacs and versions of GNU Emacs before 21.1 require (not (get 'make-local-hook 'byte-obsolete-info))) `(make-local-hook ,hook))) +;;;###mh-autoload (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 @@ -114,6 +129,10 @@ check if variable `transient-mark-mode' is active." `(and (boundp 'transient-mark-mode) transient-mark-mode (boundp 'mark-active) mark-active)))) +;; Shush compiler. +(eval-when-compile (mh-do-in-xemacs (defvar struct) (defvar x) (defvar y))) + +;;;###mh-autoload (defmacro mh-defstruct (name-spec &rest fields) "Replacement for `defstruct' from the \"cl\" package. The `defstruct' in the \"cl\" library produces compiler warnings, @@ -150,15 +169,145 @@ more details." (list 'nth ,x z))) (quote ,struct-name)))) -(unless (fboundp 'assoc-string) - (defsubst assoc-string (key list case-fold) - "Like `assoc' but specifically for strings. -Case is ignored if CASE-FOLD is non-nil. -This function added by MH-E for Emacs versions that lack -`assoc-string', introduced in Emacs 22." - (if case-fold - (assoc-ignore-case key list) - (assoc key list)))) +;;;###mh-autoload +(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) + (buffer-file-name nil)) ;don't let the buffer get locked + (prog1 + (progn + ,@body) + (mh-set-folder-modified-p mh-folder-updating-mod-flag))) + ,@(if (not save-modification-flag) + '((mh-set-folder-modified-p nil))))) +(put 'with-mh-folder-updating 'lisp-indent-hook 'defun) + +;;;###mh-autoload +(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'." + (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-flag (bury-buffer (current-buffer))) + (unwind-protect + (progn + ,@body) + (select-window mh-in-show-buffer-saved-window)))) +(put 'mh-in-show-buffer 'lisp-indent-hook 'defun) + +;;;###mh-autoload +(defmacro mh-do-at-event-location (event &rest body) + "Switch to the location of EVENT and execute BODY. +After BODY has been executed return to original window. The +modification flag of the buffer in the event window is +preserved." + (let ((event-window (make-symbol "event-window")) + (event-position (make-symbol "event-position")) + (original-window (make-symbol "original-window")) + (original-position (make-symbol "original-position")) + (modified-flag (make-symbol "modified-flag"))) + `(save-excursion + (let* ((,event-window + (or (mh-funcall-if-exists posn-window (event-start ,event)) + (mh-funcall-if-exists event-window ,event))) + (,event-position + (or (mh-funcall-if-exists posn-point (event-start ,event)) + (mh-funcall-if-exists event-closest-point ,event))) + (,original-window (selected-window)) + (,original-position (progn + (set-buffer (window-buffer ,event-window)) + (set-marker (make-marker) (point)))) + (,modified-flag (buffer-modified-p)) + (buffer-read-only nil)) + (unwind-protect (progn + (select-window ,event-window) + (goto-char ,event-position) + ,@body) + (set-buffer-modified-p ,modified-flag) + (goto-char ,original-position) + (set-marker ,original-position nil) + (select-window ,original-window)))))) +(put 'mh-do-at-event-location 'lisp-indent-hook 'defun) + + + +;;; Sequences and Ranges + +;;;###mh-autoload +(defmacro mh-seq-msgs (sequence) + "Extract messages from the given SEQUENCE." + (list 'cdr sequence)) + +;;;###mh-autoload +(defmacro mh-iterate-on-messages-in-region (var begin end &rest body) + "Iterate over region. + +VAR is bound to the message on the current line as we loop +starting from BEGIN till END. In each step BODY is executed. + +If VAR is nil then the loop is executed without any binding." + (unless (symbolp var) + (error "Can not bind the non-symbol %s" var)) + (let ((binding-needed-flag var)) + `(save-excursion + (goto-char ,begin) + (beginning-of-line) + (while (and (<= (point) ,end) (not (eobp))) + (when (looking-at mh-scan-valid-regexp) + (let ,(if binding-needed-flag `((,var (mh-get-msg-num t))) ()) + ,@body)) + (forward-line 1))))) +(put 'mh-iterate-on-messages-in-region 'lisp-indent-hook 'defun) + +;;;###mh-autoload +(defmacro mh-iterate-on-range (var range &rest body) + "Iterate an operation over a region or sequence. + +VAR is bound to each message in turn in a loop over RANGE, which +can be a message number, a list of message numbers, a sequence, a +region in a cons cell, or a MH range (something like last:20) in +a string. In each iteration, BODY is executed. + +The parameter RANGE is usually created with +`mh-interactive-range' in order to provide a uniform interface to +MH-E functions." + (unless (symbolp var) + (error "Can not bind the non-symbol %s" var)) + (let ((binding-needed-flag var) + (msgs (make-symbol "msgs")) + (seq-hash-table (make-symbol "seq-hash-table"))) + `(cond ((numberp ,range) + (when (mh-goto-msg ,range t t) + (let ,(if binding-needed-flag `((,var ,range)) ()) + ,@body))) + ((and (consp ,range) + (numberp (car ,range)) (numberp (cdr ,range))) + (mh-iterate-on-messages-in-region ,var + (car ,range) (cdr ,range) + ,@body)) + (t (let ((,msgs (cond ((and ,range (symbolp ,range)) + (mh-seq-to-msgs ,range)) + ((stringp ,range) + (mh-translate-range mh-current-folder + ,range)) + (t ,range))) + (,seq-hash-table (make-hash-table))) + (dolist (msg ,msgs) + (setf (gethash msg ,seq-hash-table) t)) + (mh-iterate-on-messages-in-region v (point-min) (point-max) + (when (gethash v ,seq-hash-table) + (let ,(if binding-needed-flag `((,var v)) ()) + ,@body)))))))) +(put 'mh-iterate-on-range 'lisp-indent-hook 'defun) (provide 'mh-acros) diff --git a/lisp/mh-e/mh-alias.el b/lisp/mh-e/mh-alias.el index 081237b3b39..98c14d63302 100644 --- a/lisp/mh-e/mh-alias.el +++ b/lisp/mh-e/mh-alias.el @@ -1,5 +1,5 @@ ;;; mh-alias.el --- MH-E mail alias completion and expansion -;; + ;; Copyright (C) 1994, 1995, 1996, 1997, ;; 2001, 2002, 2003, 2004, 2005, 2006 Free Software Foundation, Inc. @@ -31,24 +31,9 @@ ;;; Code: -;;(message "> mh-alias") -(eval-when-compile (require 'mh-acros)) -(mh-require-cl) -(require 'mh-buffers) (require 'mh-e) -;;(message "< mh-alias") -(load "cmr" t t) ; Non-fatal dependency for - ; completing-read-multiple. -(eval-when-compile (defvar mail-abbrev-syntax-table)) - - - -;;; Autoloads -(eval-when (compile load eval) - (ignore-errors - (require 'mailabbrev) - (require 'multi-prompt))) +(mh-require-cl) (defvar mh-alias-alist 'not-read "Alist of MH aliases.") @@ -61,7 +46,7 @@ (defvar mh-alias-read-address-map nil) (unless mh-alias-read-address-map (setq mh-alias-read-address-map - (copy-keymap minibuffer-local-completion-map)) + (copy-keymap minibuffer-local-completion-map)) (define-key mh-alias-read-address-map "," 'mh-alias-minibuffer-confirm-address) (define-key mh-alias-read-address-map " " 'self-insert-command)) @@ -77,6 +62,11 @@ alias files listed in your \"Aliasfile:\" MH profile component are automatically included. You can update the alias list manually using \\[mh-alias-reload].") +;; Copy of `goto-address-mail-regexp'. +(defvar mh-address-mail-regexp + "[-a-zA-Z0-9._]+@\\([-a-zA-z0-9_]+\\.\\)+[a-zA-Z0-9]+" + "A regular expression probably matching an e-mail address.") + ;;; Alias Loading @@ -185,7 +175,6 @@ Exclude all aliases already in `mh-alias-alist' from \"ali\"" (forward-line 1))) passwd-alist)) -;;;###mh-autoload (defun mh-alias-reload () "Reload MH aliases. @@ -269,11 +258,14 @@ Blind aliases or users from /etc/passwd are not expanded." (t (mh-alias-ali alias)))) +(require 'crm nil t) ; completing-read-multiple +(require 'multi-prompt nil t) + ;;;###mh-autoload (defun mh-read-address (prompt) "Read an address from the minibuffer with PROMPT." (mh-alias-reload-maybe) - (if (not mh-alias-alist) ; If still no aliases, just prompt + (if (not mh-alias-alist) ; If still no aliases, just prompt (read-string prompt) (let* ((minibuffer-local-completion-map mh-alias-read-address-map) (completion-ignore-case mh-alias-completion-ignore-case-flag) @@ -308,8 +300,6 @@ Blind aliases or users from /etc/passwd are not expanded." (message "No alias for %s" the-name)))))) (self-insert-command 1)) -(mh-do-in-xemacs (defvar mail-abbrevs)) - ;;;###mh-autoload (defun mh-alias-letter-expand-alias () "Expand mail alias before point." @@ -323,9 +313,10 @@ Blind aliases or users from /etc/passwd are not expanded." (expansion (mh-alias-expand (buffer-substring begin end)))) (delete-region begin end) (insert expansion))))) + -;;; Adding addresses to alias file. +;;; Alias File Updating (defun mh-alias-suggest-alias (string &optional no-comma-swap) "Suggest an alias for STRING. @@ -451,8 +442,8 @@ contains it." (mh-alias-filenames t))))) (cond ((not autolist) - (error "No writable alias file. -Set `mh-alias-insert-file' or the \"Aliasfile:\" profile component")) + (error "No writable alias file; +set `mh-alias-insert-file' or the \"Aliasfile:\" profile component")) ((not (elt autolist 1)) ; Only one entry, use it (car autolist)) ((or (not alias) @@ -549,7 +540,6 @@ folder name hint when filing messages." (insert (format "%s: %s\n" alias address)) (save-buffer))) -;;;###mh-autoload (defun mh-alias-add-alias (alias address) "Add ALIAS for ADDRESS in personal alias file. @@ -602,7 +592,6 @@ filing messages." (alias (mh-alias-suggest-alias address))) (mh-alias-add-alias alias address)))) -;;;###mh-autoload (defun mh-alias-add-address-under-point () "Insert an alias for address under point." (interactive) @@ -611,7 +600,19 @@ filing messages." (mh-alias-add-alias nil address) (message "No email address found under point")))) -;;;###mh-autoload +;; From goto-addr.el, which we don't want to force-load on users. +(defun mh-goto-address-find-address-at-point () + "Find e-mail address around or before point. + +Then search backwards to beginning of line for the start of an +e-mail address. If no e-mail address found, return nil." + (re-search-backward "[^-_A-z0-9.@]" (line-beginning-position) 'lim) + (if (or (looking-at mh-address-mail-regexp) ; already at start + (and (re-search-forward mh-address-mail-regexp + (line-end-position) 'lim) + (goto-char (match-beginning 0)))) + (match-string-no-properties 0))) + (defun mh-alias-apropos (regexp) "Show all aliases or addresses that match a regular expression REGEXP." (interactive "sAlias regexp: ") @@ -668,6 +669,21 @@ filing messages." (princ "\nLocal User Aliases:\n\n") (princ passwd-matches)))))) +(defun mh-folder-line-matches-show-buffer-p () + "Return t if the message under point in folder-mode is in the show buffer. +Return nil in any other circumstance (no message under point, no +show buffer, the message in the show buffer doesn't match." + (and (eq major-mode 'mh-folder-mode) + (mh-get-msg-num nil) + mh-show-buffer + (get-buffer mh-show-buffer) + (buffer-file-name (get-buffer mh-show-buffer)) + (string-match ".*/\\([0-9]+\\)$" + (buffer-file-name (get-buffer mh-show-buffer))) + (string-equal + (match-string 1 (buffer-file-name (get-buffer mh-show-buffer))) + (int-to-string (mh-get-msg-num nil))))) + (provide 'mh-alias) ;; Local Variables: diff --git a/lisp/mh-e/mh-buffers.el b/lisp/mh-e/mh-buffers.el index 5412589b32a..f70c0370d0d 100644 --- a/lisp/mh-e/mh-buffers.el +++ b/lisp/mh-e/mh-buffers.el @@ -1,4 +1,4 @@ -;;; mh-buffers.el --- Temporary buffer constants and utilities used by MH-E +;;; mh-buffers.el --- MH-E buffer constants and utilities ;; Copyright (C) 1993, 1995, 1997, ;; 2000, 2001, 2002, 2003, 2004, 2005, 2006 Free Software Foundation, Inc. @@ -27,8 +27,6 @@ ;;; Commentary: -;; Temporary buffer constants and utilities used by MH-E. - ;;; Change Log: ;;; Code: diff --git a/lisp/mh-e/mh-comp.el b/lisp/mh-e/mh-comp.el index 984af4e461d..d9ce48a959b 100644 --- a/lisp/mh-e/mh-comp.el +++ b/lisp/mh-e/mh-comp.el @@ -1,4 +1,4 @@ -;;; mh-comp.el --- MH-E functions for composing messages +;;; mh-comp.el --- MH-E functions for composing and sending messages ;; Copyright (C) 1993, 1995, 1997, ;; 2000, 2001, 2002, 2003, 2004, 2005, 2006 Free Software Foundation, Inc. @@ -27,33 +27,23 @@ ;;; Commentary: -;; Internal support for MH-E package. +;; This file includes the functions in the MH-Folder maps that get us +;; into MH-Letter mode, as well the functions in the MH-Letter mode +;; that are used to send the mail. Other that those, functions that +;; are needed in mh-letter.el should be found there. ;;; Change Log: ;;; Code: -;;(message "> mh-comp") -(eval-when-compile (require 'mh-acros)) -(mh-require-cl) - -(require 'easymenu) -(require 'gnus-util) -(require 'mh-buffers) (require 'mh-e) -(require 'mh-gnus) - -(eval-when (compile load eval) - (ignore-errors (require 'mailabbrev))) -;;(message "< mh-comp") - - - -;;; Autoloads +(require 'mh-gnus) ;needed because mh-gnus.el not compiled +(require 'mh-scan) -(autoload 'mail-mode-fill-paragraph "sendmail") -(autoload 'mm-handle-displayed-p "mm-decode") +(require 'sendmail) +(autoload 'easy-menu-add "easymenu") +(autoload 'mml-insert-tag "mml") (autoload 'sc-cite-original "sc" "Workhorse citing function which performs the initial citation. This is callable from the various mail and news readers' reply @@ -80,7 +70,7 @@ before, and `sc-post-hook' is run after the guts of this function.") -;;; Site customization (see also mh-utils.el): +;;; Site Customization (defvar mh-send-prog "send" "Name of the MH send program. @@ -93,26 +83,7 @@ This allows transaction log to be visible if -watch, -verbose or -;;; Scan Line Formats - -(defvar mh-note-repl ?- - "Messages that have been replied to are marked by this character.") - -(defvar mh-note-forw ?F - "Messages that have been forwarded are marked by this character.") - -(defvar mh-note-dist ?R - "Messages that have been redistributed are marked by this character.") - -(defvar mh-yank-hooks nil - "Obsolete hook for modifying a citation just inserted in the mail buffer. - -Each hook function can find the citation between point and mark. -And each hook function should leave point and mark around the -citation text as modified. - -This is a normal hook, misnamed for historical reasons. It is -semi-obsolete and is only used if `mail-citation-hook' is nil.") +;;; Variables (defvar mh-comp-formfile "components" "Name of file to be used as a skeleton for composing messages. @@ -145,7 +116,7 @@ user's MH directory, then in the system MH lib directory.") (regexp-opt '("Content-Type: message/rfc822" ;MIME MDN "------ This is a copy of the message, including all the headers. ------";from exim - "--- Below this line is a copy of the message."; from qmail + "--- Below this line is a copy of the message."; from qmail " ----- Unsent message follows -----" ;from sendmail V5 " --------Unsent Message below:" ; from sendmail at BU " ----- Original message follows -----" ;from sendmail V8 @@ -161,21 +132,6 @@ user's MH directory, then in the system MH lib directory.") "Regexp of header lines to remove before offering a message as a new draft\\<mh-folder-mode-map>. Used by the \\[mh-edit-again] and \\[mh-extract-rejected-mail] commands.") -(defvar mh-to-field-choices '(("a" . "Mail-Reply-To:") - ("b" . "Bcc:") - ("c" . "Cc:") - ("d" . "Dcc:") - ("f" . "Fcc:") - ("l" . "Mail-Followup-To:") - ("m" . "From:") - ("r" . "Reply-To:") - ("s" . "Subject:") - ("t" . "To:")) - "Alist of (final-character . field-name) choices for `mh-to-field'.") - -(defvar mh-letter-mode-map (copy-keymap text-mode-map) - "Keymap for composing mail.") - (defvar mh-letter-mode-syntax-table nil "Syntax table used by MH-E while in MH-Letter mode.") @@ -185,12 +141,6 @@ Used by the \\[mh-edit-again] and \\[mh-extract-rejected-mail] commands.") (make-syntax-table text-mode-syntax-table)) (modify-syntax-entry ?% "." mh-letter-mode-syntax-table)) -(defvar mh-sent-from-folder nil - "Folder of msg assoc with this letter.") - -(defvar mh-sent-from-msg nil - "Number of msg assoc with this letter.") - (defvar mh-send-args nil "Extra args to pass to \"send\" command.") @@ -204,6 +154,10 @@ Used by the \\[mh-edit-again] and \\[mh-extract-rejected-mail] commands.") "Buffer-local variable set when `mh-insert-auto-fields' called successfully.") (make-variable-buffer-local 'mh-insert-auto-fields-done-local) + + +;;; MH-E Entry Points + ;;;###autoload (defun mh-smail () "Compose a message with the MH mail system. @@ -220,6 +174,18 @@ See `mh-send' for more details on composing mail." (mh-find-path) (call-interactively 'mh-send-other-window)) +(defun mh-send-other-window (to cc subject) + "Compose a message in another window. + +See `mh-send' for more information and a description of how the +TO, CC, and SUBJECT arguments are used." + (interactive (list + (mh-interactive-read-address "To: ") + (mh-interactive-read-address "Cc: ") + (mh-interactive-read-string "Subject: "))) + (let ((pop-up-windows t)) + (mh-send-sub to cc subject (current-window-configuration)))) + (defvar mh-error-if-no-draft nil) ;raise error over using old draft ;;;###autoload @@ -271,6 +237,117 @@ ignored." (cdr (car other-headers))) (setq other-headers (cdr other-headers))))) +;; Shush compiler. +(eval-when-compile (mh-do-in-xemacs (defvar sendmail-coding-system))) + +;;;###autoload +(defun mh-send-letter (&optional arg) + "Save draft and send message. + +When you are all through editing a message, you send it with this +command. You can give a prefix argument ARG to monitor the first stage +of the delivery\; this output can be found in a buffer called \"*MH-E +Mail Delivery*\". + +The hook `mh-before-send-letter-hook' is run at the beginning of +this command. For example, if you want to check your spelling in +your message before sending, add the function `ispell-message'. + +In case the MH \"send\" program is installed under a different name, +use `mh-send-prog' to tell MH-E the name." + (interactive "P") + (run-hooks 'mh-before-send-letter-hook) + (if (and (mh-insert-auto-fields t) + mh-auto-fields-prompt-flag + (goto-char (point-min))) + (if (not (y-or-n-p "Auto fields inserted, send? ")) + (error "Send aborted"))) + (cond ((mh-mh-directive-present-p) + (mh-mh-to-mime)) + ((or (mh-mml-tag-present-p) (not (mh-ascii-buffer-p))) + (mh-mml-to-mime))) + (save-buffer) + (message "Sending...") + (let ((draft-buffer (current-buffer)) + (file-name buffer-file-name) + (config mh-previous-window-config) + (coding-system-for-write + (if (and (local-variable-p 'buffer-file-coding-system + (current-buffer)) ;XEmacs needs two args + ;; We're not sure why, but buffer-file-coding-system + ;; tends to get set to undecided-unix. + (not (memq buffer-file-coding-system + '(undecided undecided-unix undecided-dos)))) + buffer-file-coding-system + (or (and (boundp 'sendmail-coding-system) sendmail-coding-system) + (and (boundp 'default-buffer-file-coding-system ) + default-buffer-file-coding-system) + 'iso-latin-1)))) + ;; Adding a Message-ID field looks good, makes it easier to search for + ;; message in your +outbox, and best of all doesn't break threading for + ;; the recipient if you reply to a message in your +outbox. + (setq mh-send-args (concat "-msgid " mh-send-args)) + ;; The default BCC encapsulation will make a MIME message unreadable. + ;; With nmh use the -mime arg to prevent this. + (if (and (mh-variant-p 'nmh) + (mh-goto-header-field "Bcc:") + (mh-goto-header-field "Content-Type:")) + (setq mh-send-args (concat "-mime " mh-send-args))) + (cond (arg + (pop-to-buffer mh-mail-delivery-buffer) + (erase-buffer) + (mh-exec-cmd-output mh-send-prog t "-watch" "-nopush" + "-nodraftfolder" mh-send-args file-name) + (goto-char (point-max)) ; show the interesting part + (recenter -1) + (set-buffer draft-buffer)) ; for annotation below + (t + (mh-exec-cmd-daemon mh-send-prog nil "-nodraftfolder" "-noverbose" + mh-send-args file-name))) + (if mh-annotate-char + (mh-annotate-msg mh-sent-from-msg + mh-sent-from-folder + mh-annotate-char + "-component" mh-annotate-field + "-text" (format "\"%s %s\"" + (mh-get-header-field "To:") + (mh-get-header-field "Cc:")))) + + (cond ((or (not arg) + (y-or-n-p "Kill draft buffer? ")) + (kill-buffer draft-buffer) + (if config + (set-window-configuration config)))) + (if arg + (message "Sending...done") + (message "Sending...backgrounded")))) + +;;;###autoload +(defun mh-fully-kill-draft () + "Quit editing and delete draft message. + +If for some reason you are not happy with the draft, you can use +this command to kill the draft buffer and delete the draft +message. Use the command \\[kill-buffer] if you don't want to +delete the draft message." + (interactive) + (if (y-or-n-p "Kill draft message? ") + (let ((config mh-previous-window-config)) + (if (file-exists-p buffer-file-name) + (delete-file buffer-file-name)) + (set-buffer-modified-p nil) + (kill-buffer (buffer-name)) + (message "") + (if config + (set-window-configuration config))) + (error "Message not killed"))) + + + +;;; MH-Folder Commands + +;; Alphabetical. + ;;;###mh-autoload (defun mh-edit-again (message) "Edit a MESSAGE to send it again. @@ -509,32 +586,6 @@ See also `mh-redist-full-contents-flag'." (kill-buffer draft) (message "Redistributing...done")))) -(defun mh-show-buffer-message-number (&optional buffer) - "Message number of displayed message in corresponding show buffer. - -Return nil if show buffer not displayed. -If in `mh-letter-mode', don't display the message number being replied -to, but rather the message number of the show buffer associated with -our originating folder buffer. -Optional argument BUFFER can be used to specify the buffer." - (save-excursion - (if buffer - (set-buffer buffer)) - (cond ((eq major-mode 'mh-show-mode) - (let ((number-start (mh-search-from-end ?/ buffer-file-name))) - (string-to-number (substring buffer-file-name - (1+ number-start))))) - ((and (eq major-mode 'mh-folder-mode) - mh-show-buffer - (get-buffer mh-show-buffer)) - (mh-show-buffer-message-number mh-show-buffer)) - ((and (eq major-mode 'mh-letter-mode) - mh-sent-from-folder - (get-buffer mh-sent-from-folder)) - (mh-show-buffer-message-number mh-sent-from-folder)) - (t - nil)))) - ;;;###mh-autoload (defun mh-reply (message &optional reply-to includep) "Reply to a MESSAGE. @@ -667,18 +718,50 @@ message." (delete-other-windows) (mh-send-sub to cc subject config))) + + +;;; Support Routines + +(defun mh-interactive-read-address (prompt) + "Read an address. +If `mh-compose-prompt-flag' is non-nil, then read an address with +PROMPT. +Otherwise return the empty string." + (if mh-compose-prompt-flag (mh-read-address prompt) "")) + +(defun mh-interactive-read-string (prompt) + "Read a string. +If `mh-compose-prompt-flag' is non-nil, then read a string with +PROMPT. +Otherwise return the empty string." + (if mh-compose-prompt-flag (read-string prompt) "")) + ;;;###mh-autoload -(defun mh-send-other-window (to cc subject) - "Compose a message in another window. +(defun mh-show-buffer-message-number (&optional buffer) + "Message number of displayed message in corresponding show buffer. -See `mh-send' for more information and a description of how the -TO, CC, and SUBJECT arguments are used." - (interactive (list - (mh-interactive-read-address "To: ") - (mh-interactive-read-address "Cc: ") - (mh-interactive-read-string "Subject: "))) - (let ((pop-up-windows t)) - (mh-send-sub to cc subject (current-window-configuration)))) +Return nil if show buffer not displayed. +If in `mh-letter-mode', don't display the message number being replied +to, but rather the message number of the show buffer associated with +our originating folder buffer. +Optional argument BUFFER can be used to specify the buffer." + (save-excursion + (if buffer + (set-buffer buffer)) + (cond ((eq major-mode 'mh-show-mode) + (let ((number-start (mh-search-from-end ?/ buffer-file-name))) + (string-to-number (substring buffer-file-name + (1+ number-start))))) + ((and (eq major-mode 'mh-folder-mode) + mh-show-buffer + (get-buffer mh-show-buffer)) + (mh-show-buffer-message-number mh-show-buffer)) + ((and (eq major-mode 'mh-letter-mode) + mh-sent-from-folder + (get-buffer mh-sent-from-folder)) + (mh-show-buffer-message-number mh-sent-from-folder)) + (t + nil)))) (defun mh-send-sub (to cc subject config) "Do the real work of composing and sending a letter. @@ -777,19 +860,6 @@ then be reused." (mh-exec-cmd-quiet t "mhpath" mh-draft-folder "new") (buffer-substring (point-min) (1- (point-max))))) -(defun mh-annotate-msg (msg buffer note &rest args) - "Mark MSG in BUFFER with character NOTE and annotate message with ARGS. -MSG can be a message number, a list of message numbers, or a -sequence." - (apply 'mh-exec-cmd "anno" buffer - (if (listp msg) (append msg args) (cons msg args))) - (save-excursion - (cond ((get-buffer buffer) ; Buffer may be deleted - (set-buffer buffer) - (mh-iterate-on-range nil msg - (mh-notate nil note - (+ mh-cmd-note mh-scan-field-destination-offset))))))) - (defun mh-insert-fields (&rest name-values) "Insert the NAME-VALUES pairs in the current buffer. If the field exists, append the value to it. @@ -808,459 +878,56 @@ Do not insert any pairs whose value is the empty string." (insert field-name " " value "\n"))) (setq name-values (cdr (cdr name-values))))))) -(defun mh-position-on-field (field &optional ignored) - "Move to the end of the FIELD in the header. -Move to end of entire header if FIELD not found. -Returns non-nil iff FIELD was found. -The optional second arg is for pre-version 4 compatibility and is -IGNORED." - (cond ((mh-goto-header-field field) - (mh-header-field-end) - t) - ((mh-goto-header-end 0) - nil))) - -;;;###mh-autoload -(defun mh-get-header-field (field) - "Find and return the body of FIELD in the mail header. -Returns the empty string if the field is not in the header of the -current buffer." - (if (mh-goto-header-field field) - (progn - (skip-chars-forward " \t") ;strip leading white space in body - (let ((start (point))) - (mh-header-field-end) - (buffer-substring-no-properties start (point)))) - "")) - -(fset 'mh-get-field 'mh-get-header-field) ;MH-E 4 compatibility - -(defun mh-goto-header-field (field) - "Move to FIELD in the message header. -Move to the end of the FIELD name, which should end in a colon. -Returns t if found, nil if not." - (goto-char (point-min)) - (let ((case-fold-search t) - (headers-end (save-excursion - (mh-goto-header-end 0) - (point)))) - (re-search-forward (format "^%s" field) headers-end t))) - -(defun mh-goto-header-end (arg) - "Move the cursor ARG lines after the header." - (if (re-search-forward "^-*$" nil nil) - (forward-line arg))) - -(defun mh-extract-from-header-value () - "Extract From: string from header." - (save-excursion - (if (not (mh-goto-header-field "From:")) - nil - (skip-chars-forward " \t") - (buffer-substring-no-properties - (point) (progn (mh-header-field-end)(point)))))) - - - -;;; Mode for composing and sending a draft message. - -(defvar mh-pgp-support-flag (not (not (locate-library "mml2015"))) - "Non-nil means PGP support is available.") - -(put 'mh-letter-mode 'mode-class 'special) - -;; Menu extracted from mh-menubar.el V1.1 (31 July 2001) -(eval-when-compile (defvar mh-letter-menu nil)) -(easy-menu-define - mh-letter-menu mh-letter-mode-map "Menu for MH-E letter mode." - '("Letter" - ["Send This Draft" mh-send-letter t] - ["Split Current Line" mh-open-line t] - ["Check Recipient" mh-check-whom t] - ["Yank Current Message" mh-yank-cur-msg t] - ["Insert a Message..." mh-insert-letter t] - ["Insert Signature" mh-insert-signature t] - ("Encrypt/Sign Message" - ["Sign Message" - mh-mml-secure-message-sign mh-pgp-support-flag] - ["Encrypt Message" - mh-mml-secure-message-encrypt mh-pgp-support-flag] - ["Sign+Encrypt Message" - mh-mml-secure-message-signencrypt mh-pgp-support-flag] - ["Disable Security" - mh-mml-unsecure-message mh-pgp-support-flag] - "--" - "Security Method" - ["PGP (MIME)" (setq mh-mml-method-default "pgpmime") - :style radio - :selected (equal mh-mml-method-default "pgpmime")] - ["PGP" (setq mh-mml-method-default "pgp") - :style radio - :selected (equal mh-mml-method-default "pgp")] - ["S/MIME" (setq mh-mml-method-default "smime") - :style radio - :selected (equal mh-mml-method-default "smime")] - "--" - ["Save Method as Default" - (customize-save-variable 'mh-mml-method-default mh-mml-method-default) t] - ) - ["Compose Insertion..." mh-compose-insertion t] - ["Compose Compressed tar (MH)..." - mh-mh-compose-external-compressed-tar t] - ["Compose Get File (MH)..." mh-mh-compose-anon-ftp t] - ["Compose Forward..." mh-compose-forward t] - ;; The next two will have to be merged. But I also need to make sure the - ;; user can't mix tags of both types. - ["Pull in All Compositions (MH)" - mh-mh-to-mime (mh-mh-directive-present-p)] - ["Pull in All Compositions (MML)" - mh-mml-to-mime (mh-mml-tag-present-p)] - ["Revert to Non-MIME Edit (MH)" - mh-mh-to-mime-undo (equal mh-compose-insertion 'mh)] - ["Kill This Draft" mh-fully-kill-draft t])) - - - -;;; Help Messages - -;; Group messages logically, more or less. -(defvar mh-letter-mode-help-messages - '((nil - "Send letter: \\[mh-send-letter]" - "\t\tOpen line: \\[mh-open-line]\n" - "Kill letter: \\[mh-fully-kill-draft]" - "\t\tInsert:\n" - "Check recipients: \\[mh-check-whom]" - "\t\t Current message: \\[mh-yank-cur-msg]\n" - "\t\t Attachment: \\[mh-compose-insertion]\n" - "\t\t Message to forward: \\[mh-compose-forward]\n" - " " - "Security:" - "\t\t Encrypt message: \\[mh-mml-secure-message-encrypt]" - "\t\t Sign+Encrypt message: \\[mh-mml-secure-message-signencrypt]" - "\t\t Sign message: \\[mh-mml-secure-message-sign]\n" - " " - "\t\t Signature: \\[mh-insert-signature]")) - "Key binding cheat sheet. - -This is an associative array which is used to show the most -common commands. The key is a prefix char. The value is one or -more strings which are concatenated together and displayed in the -minibuffer if ? is pressed after the prefix character. The -special key nil is used to display the non-prefixed commands. - -The substitutions described in `substitute-command-keys' are -performed as well.") - -;; Shush compiler. -(eval-when-compile - (defvar adaptive-fill-first-line-regexp) - (defvar tool-bar-map)) - -(defvar mh-letter-buttons-init-flag nil) - -;;;###autoload -(define-derived-mode mh-letter-mode mail-mode "MH-Letter" - "Mode for composing letters in MH-E\\<mh-letter-mode-map>. - -When you have finished composing, type \\[mh-send-letter] to send -the message using the MH mail handling system. - -There are two types of tags used by MH-E when composing MIME -messages: MML and MH. The option `mh-compose-insertion' controls -what type of tags are inserted by MH-E commands. These tags can -be converted to MIME body parts by running \\[mh-mh-to-mime] for -MH-style directives or \\[mh-mml-to-mime] for MML tags. - -Options that control this mode can be changed with -\\[customize-group]; specify the \"mh-compose\" group. - -When a message is composed, the hooks `text-mode-hook', -`mail-mode-hook', and `mh-letter-mode-hook' are run (in that -order). - -\\{mh-letter-mode-map}" - (mh-find-path) - (make-local-variable 'mh-send-args) - (make-local-variable 'mh-annotate-char) - (make-local-variable 'mh-annotate-field) - (make-local-variable 'mh-previous-window-config) - (make-local-variable 'mh-sent-from-folder) - (make-local-variable 'mh-sent-from-msg) - (mh-do-in-gnu-emacs - (unless mh-letter-buttons-init-flag - (mh-tool-bar-letter-buttons-init) - (setq mh-letter-buttons-init-flag t))) - ;; Set the local value of mh-mail-header-separator according to what is - ;; present in the buffer... - (set (make-local-variable 'mh-mail-header-separator) - (save-excursion - (goto-char (mh-mail-header-end)) - (buffer-substring-no-properties (point) (line-end-position)))) - (make-local-variable 'mail-header-separator) - (setq mail-header-separator mh-mail-header-separator) ;override sendmail.el - (make-local-variable 'mh-help-messages) - (setq mh-help-messages mh-letter-mode-help-messages) - (setq buffer-invisibility-spec '((vanish . t) t)) - (set (make-local-variable 'line-move-ignore-invisible) t) - - ;; Enable undo since a show-mode buffer might have been reused. - (buffer-enable-undo) - (set (make-local-variable 'tool-bar-map) mh-letter-tool-bar-map) - (mh-funcall-if-exists mh-tool-bar-init :letter) - (make-local-variable 'font-lock-defaults) - (cond - ((or (equal mh-highlight-citation-style 'font-lock) - (equal mh-highlight-citation-style 'gnus)) - ;; Let's use font-lock even if gnus is used in show-mode. The reason - ;; is that gnus uses static text properties which are not appropriate - ;; for a buffer that will be edited. So the choice here is either fontify - ;; the citations and header... - (setq font-lock-defaults '(mh-letter-font-lock-keywords t))) - (t - ;; ...or the header only - (setq font-lock-defaults '(mh-show-font-lock-keywords t)))) - (easy-menu-add mh-letter-menu) - (setq fill-column mh-letter-fill-column) - ;; If text-mode-hook turned on auto-fill, tune it for messages - (when auto-fill-function - (make-local-variable 'auto-fill-function) - (setq auto-fill-function 'mh-auto-fill-for-letter))) - -(defun mh-font-lock-field-data (limit) - "Find header field region between point and LIMIT." - (and (< (point) (mh-letter-header-end)) - (< (point) limit) - (let ((end (min limit (mh-letter-header-end))) - (point (point)) - data-end data-begin field) - (end-of-line) - (setq data-end (if (re-search-forward "^[^ \t]" end t) - (match-beginning 0) - end)) - (goto-char (1- data-end)) - (if (not (re-search-backward "\\(^[^ \t][^:]*\\):[ \t]*" nil t)) - (setq data-begin (point-min)) - (setq data-begin (match-end 0)) - (setq field (match-string 1))) - (setq data-begin (max point data-begin)) - (goto-char (if (equal point data-end) (1+ data-end) data-end)) - (cond ((and field (mh-letter-skipped-header-field-p field)) - (set-match-data nil) - nil) - (t (set-match-data - (list data-begin data-end data-begin data-end)) - t))))) - -(defun mh-letter-header-end () - "Find the end of the message header. -This function is to be used only for font locking. It works by -searching for `mh-mail-header-separator' in the buffer." - (save-excursion - (goto-char (point-min)) - (cond ((equal mh-mail-header-separator "") (point-min)) - ((search-forward (format "\n%s\n" mh-mail-header-separator) nil t) - (line-beginning-position 0)) - (t (point-min))))) - -(defun mh-auto-fill-for-letter () - "Perform auto-fill for message. -Header is treated specially by inserting a tab before continuation -lines." - (if (mh-in-header-p) - (let ((fill-prefix "\t")) - (do-auto-fill)) - (do-auto-fill))) - -(defun mh-insert-header-separator () - "Insert `mh-mail-header-separator', if absent." - (save-excursion - (goto-char (point-min)) - (rfc822-goto-eoh) - (if (looking-at "$") - (insert mh-mail-header-separator)))) - -;;;###mh-autoload -(defun mh-to-field () - "Move to specified header field. - -The field is indicated by the previous keystroke (the last -keystroke of the command) according to the list in the variable -`mh-to-field-choices'. -Create the field if it does not exist. -Set the mark to point before moving." - (interactive) - (expand-abbrev) - (let ((target (cdr (or (assoc (char-to-string (logior last-input-char ?`)) - mh-to-field-choices) - ;; also look for a char for version 4 compat - (assoc (logior last-input-char ?`) - mh-to-field-choices)))) - (case-fold-search t)) - (push-mark) - (cond ((mh-position-on-field target) - (let ((eol (point))) - (skip-chars-backward " \t") - (delete-region (point) eol)) - (if (and (not (eq (logior last-input-char ?`) ?s)) - (save-excursion - (backward-char 1) - (not (looking-at "[:,]")))) - (insert ", ") - (insert " "))) - (t - (if (mh-position-on-field "To:") - (forward-line 1)) - (insert (format "%s \n" target)) - (backward-char 1))))) - -;;;###mh-autoload -(defun mh-to-fcc (&optional folder) - "Move to \"Fcc:\" header field. - -This command will prompt you for the FOLDER name in which to file -a copy of the draft." - (interactive (list (mh-prompt-for-folder - "Fcc" - (or (and mh-default-folder-for-message-function - (save-excursion - (goto-char (point-min)) - (funcall - mh-default-folder-for-message-function))) - "") - t))) - (let ((last-input-char ?\C-f)) - (expand-abbrev) - (save-excursion - (mh-to-field) - (insert (if (mh-folder-name-p folder) - (substring folder 1) - folder))))) - -(defun mh-file-is-vcard-p (file) - "Return t if FILE is a .vcf vcard." - (let ((case-fold-search t)) - (and (stringp file) - (file-exists-p file) - (or (and (not (mh-have-file-command)) - (not (null (string-match "\.vcf$" file)))) - (string-equal "text/x-vcard" (mh-file-mime-type file)))))) - -;;;###mh-autoload -(defun mh-insert-signature (&optional file) - "Insert signature in message. - -This command inserts your signature at the current cursor location. - -By default, the text of your signature is taken from the file -\"~/.signature\". You can read from other sources by changing the -option `mh-signature-file-name'. - -A signature separator (\"-- \") will be added if the signature block -does not contain one and `mh-signature-separator-flag' is on. - -The hook `mh-insert-signature-hook' is run after the signature is -inserted. Hook functions may access the actual name of the file or the -function used to insert the signature with `mh-signature-file-name'. - -The signature can also be inserted using Identities (see -`mh-identity-list'). - -In a program, you can pass in a signature FILE." - (interactive) - (save-excursion - (insert "\n") - (let ((mh-signature-file-name (or file mh-signature-file-name)) - (mh-mh-p (mh-mh-directive-present-p)) - (mh-mml-p (mh-mml-tag-present-p))) - (save-restriction - (narrow-to-region (point) (point)) - (cond - ((mh-file-is-vcard-p mh-signature-file-name) - (if (equal mh-compose-insertion 'mml) - (insert "<#part type=\"text/x-vcard\" filename=\"" - mh-signature-file-name - "\" disposition=inline description=VCard>\n<#/part>") - (insert "#text/x-vcard; name=\"" - (file-name-nondirectory mh-signature-file-name) - "\" [VCard] " (expand-file-name mh-signature-file-name)))) - (t - (cond - (mh-mh-p - (insert "#\n" "Content-Description: Signature\n")) - (mh-mml-p - (mml-insert-tag 'part 'type "text/plain" 'disposition "inline" - 'description "Signature"))) - (cond ((null mh-signature-file-name)) - ((and (stringp mh-signature-file-name) - (file-readable-p mh-signature-file-name)) - (insert-file-contents mh-signature-file-name)) - ((functionp mh-signature-file-name) - (funcall mh-signature-file-name))))) - (save-restriction - (widen) - (run-hooks 'mh-insert-signature-hook)) - (goto-char (point-min)) - (when (and (not (mh-file-is-vcard-p mh-signature-file-name)) - mh-signature-separator-flag - (> (point-max) (point-min)) - (not (mh-signature-separator-p))) - (cond (mh-mh-p - (forward-line 2)) - (mh-mml-p - (forward-line 1))) - (insert mh-signature-separator)) - (if (not (> (point-max) (point-min))) - (message "No signature found"))))) - (force-mode-line-update)) - -;;;###mh-autoload -(defun mh-check-whom () - "Verify recipients, showing expansion of any aliases. - -This command expands aliases so you can check the actual address(es) -in the alias. A new buffer named \"*MH-E Recipients*\" is created with -the output of \"whom\"." - (interactive) - (let ((file-name buffer-file-name)) - (save-buffer) - (message "Checking recipients...") - (mh-in-show-buffer (mh-recipients-buffer) - (bury-buffer (current-buffer)) - (erase-buffer) - (mh-exec-cmd-output "whom" t file-name)) - (message "Checking recipients...done"))) - -(defun mh-tidy-draft-buffer () - "Run when a draft buffer is destroyed." - (let ((buffer (get-buffer mh-recipients-buffer))) - (if buffer - (kill-buffer buffer)))) +(defun mh-compose-and-send-mail (draft send-args + sent-from-folder sent-from-msg + to subject cc + annotate-char annotate-field + config) + "Edit and compose a draft message in buffer DRAFT and send or save it. +SEND-ARGS is the argument passed to the send command. +SENT-FROM-FOLDER is buffer containing scan listing of current folder, +or nil if none exists. +SENT-FROM-MSG is the message number or sequence name or nil. +The TO, SUBJECT, and CC fields are passed to the +`mh-compose-letter-function'. +If ANNOTATE-CHAR is non-null, it is used to notate the scan listing of +the message. In that case, the ANNOTATE-FIELD is used to build a +string for `mh-annotate-msg'. +CONFIG is the window configuration to restore after sending the +letter." + (pop-to-buffer draft) + (mh-letter-mode) - + ;; Insert identity. + (mh-insert-identity mh-identity-default t) + (mh-identity-make-menu) + (mh-identity-add-menu) -;;; Routines to compose and send a letter. + ;; Insert extra fields. + (mh-insert-x-mailer) + (mh-insert-x-face) -(defun mh-insert-x-face () - "Append X-Face, Face or X-Image-URL field to header. -If the field already exists, this function does nothing." - (when (and (file-exists-p mh-x-face-file) - (file-readable-p mh-x-face-file)) - (save-excursion - (unless (or (mh-position-on-field "X-Face") - (mh-position-on-field "Face") - (mh-position-on-field "X-Image-URL")) - (save-excursion - (goto-char (+ (point) (cadr (insert-file-contents mh-x-face-file)))) - (if (not (looking-at "^")) - (insert "\n"))) - (unless (looking-at "\\(X-Face\\|Face\\|X-Image-URL\\): ") - (insert "X-Face: ")))))) + (mh-letter-hide-all-skipped-fields) -(defvar mh-x-mailer-string nil - "*String containing the contents of the X-Mailer header field. -If nil, this variable is initialized to show the version of MH-E, -Emacs, and MH the first time a message is composed.") + (setq mh-sent-from-folder sent-from-folder) + (setq mh-sent-from-msg sent-from-msg) + (setq mh-send-args send-args) + (setq mh-annotate-char annotate-char) + (setq mh-annotate-field annotate-field) + (setq mh-previous-window-config config) + (setq mode-line-buffer-identification (list " {%b}")) + (mh-logo-display) + (mh-make-local-hook 'kill-buffer-hook) + (add-hook 'kill-buffer-hook 'mh-tidy-draft-buffer nil t) + (if (and (boundp 'mh-compose-letter-function) + mh-compose-letter-function) + ;; run-hooks will not pass arguments. + (let ((value mh-compose-letter-function)) + (if (and (listp value) (not (eq (car value) 'lambda))) + (while value + (funcall (car value) to subject cc) + (setq value (cdr value))) + (funcall mh-compose-letter-function to subject cc))))) (defun mh-insert-x-mailer () "Append an X-Mailer field to the header. @@ -1283,20 +950,89 @@ The versions of MH-E, Emacs, and MH are shown." (null (mh-goto-header-field "X-Mailer"))) (mh-insert-fields "X-Mailer:" mh-x-mailer-string)))) -(defun mh-regexp-in-field-p (regexp &rest fields) - "Non-nil means REGEXP was found in FIELDS." +(defun mh-insert-x-face () + "Append X-Face, Face or X-Image-URL field to header. +If the field already exists, this function does nothing." + (when (and (file-exists-p mh-x-face-file) + (file-readable-p mh-x-face-file)) + (save-excursion + (unless (or (mh-position-on-field "X-Face") + (mh-position-on-field "Face") + (mh-position-on-field "X-Image-URL")) + (save-excursion + (goto-char (+ (point) (cadr (insert-file-contents mh-x-face-file)))) + (if (not (looking-at "^")) + (insert "\n"))) + (unless (looking-at "\\(X-Face\\|Face\\|X-Image-URL\\): ") + (insert "X-Face: ")))))) + +;;;###mh-autoload +(defun mh-letter-hide-all-skipped-fields () + "Hide all skipped fields." (save-excursion - (let ((search-result nil) - (field)) - (while fields - (setq field (car fields)) - (if (and (mh-goto-header-field field) - (re-search-forward - regexp (save-excursion (mh-header-field-end)(point)) t)) - (setq fields nil - search-result t) - (setq fields (cdr fields)))) - search-result))) + (goto-char (point-min)) + (save-restriction + (narrow-to-region (point) (mh-mail-header-end)) + (while (re-search-forward mh-letter-header-field-regexp nil t) + (if (mh-letter-skipped-header-field-p (match-string 1)) + (mh-letter-toggle-header-field-display -1) + (mh-letter-toggle-header-field-display 'long)) + (beginning-of-line 2))))) + +(defun mh-tidy-draft-buffer () + "Run when a draft buffer is destroyed." + (let ((buffer (get-buffer mh-recipients-buffer))) + (if buffer + (kill-buffer buffer)))) + +(defun mh-letter-mode-message () + "Display a help message for users of `mh-letter-mode'. +This should be the last function called when composing the draft." + (message "%s" (substitute-command-keys + (concat "Type \\[mh-send-letter] to send message, " + "\\[mh-help] for help")))) + +(defun mh-letter-adjust-point () + "Move cursor to first header field if are using the no prompt mode." + (unless mh-compose-prompt-flag + (goto-char (point-max)) + (mh-letter-next-header-field))) + +(defun mh-annotate-msg (msg buffer note &rest args) + "Mark MSG in BUFFER with character NOTE and annotate message with ARGS. +MSG can be a message number, a list of message numbers, or a +sequence." + (apply 'mh-exec-cmd "anno" buffer + (if (listp msg) (append msg args) (cons msg args))) + (save-excursion + (cond ((get-buffer buffer) ; Buffer may be deleted + (set-buffer buffer) + (mh-iterate-on-range nil msg + (mh-notate nil note + (+ mh-cmd-note mh-scan-field-destination-offset))))))) + +;;;###mh-autoload +(defun mh-get-header-field (field) + "Find and return the body of FIELD in the mail header. +Returns the empty string if the field is not in the header of the +current buffer." + (if (mh-goto-header-field field) + (progn + (skip-chars-forward " \t") ;strip leading white space in body + (let ((start (point))) + (mh-header-field-end) + (buffer-substring-no-properties start (point)))) + "")) + +(fset 'mh-get-field 'mh-get-header-field) ;MH-E 4 compatibility + +(defun mh-insert-header-separator () + "Insert `mh-mail-header-separator', if absent." + (save-excursion + (goto-char (point-min)) + (rfc822-goto-eoh) + (if (looking-at "$") + (insert mh-mail-header-separator)))) ;;;###mh-autoload (defun mh-insert-auto-fields (&optional non-interactive) @@ -1332,12 +1068,13 @@ Return t if fields added; otherwise return nil." (value (cdar entry-list))) (cond ((equal ":identity" field) - (when ;;(and (not mh-identity-local) + (when + ;;(and (not mh-identity-local) ;; Bug 1204506. But do we need to be able - ;; to set an identity manually that won't be - ;; overridden by mh-insert-auto-fields? - (assoc value mh-identity-list) - ;;) + ;; to set an identity manually that won't be + ;; overridden by mh-insert-auto-fields? + (assoc value mh-identity-list) + ;;) (mh-insert-identity value))) (t (mh-modify-header-field field value @@ -1365,66 +1102,20 @@ discarded." (mh-goto-header-end 0) (insert field ": " value "\n")))) -(defun mh-compose-and-send-mail (draft send-args - sent-from-folder sent-from-msg - to subject cc - annotate-char annotate-field - config) - "Edit and compose a draft message in buffer DRAFT and send or save it. -SEND-ARGS is the argument passed to the send command. -SENT-FROM-FOLDER is buffer containing scan listing of current folder, -or nil if none exists. -SENT-FROM-MSG is the message number or sequence name or nil. -The TO, SUBJECT, and CC fields are passed to the -`mh-compose-letter-function'. -If ANNOTATE-CHAR is non-null, it is used to notate the scan listing of -the message. In that case, the ANNOTATE-FIELD is used to build a -string for `mh-annotate-msg'. -CONFIG is the window configuration to restore after sending the -letter." - (pop-to-buffer draft) - (mh-letter-mode) - - ;; Insert identity. - (if (and (boundp 'mh-identity-default) - mh-identity-default - (not mh-identity-local)) - (mh-insert-identity mh-identity-default)) - (mh-identity-make-menu) - (easy-menu-add mh-identity-menu) - - ;; Insert extra fields. - (mh-insert-x-mailer) - (mh-insert-x-face) - - (mh-letter-hide-all-skipped-fields) - - (setq mh-sent-from-folder sent-from-folder) - (setq mh-sent-from-msg sent-from-msg) - (setq mh-send-args send-args) - (setq mh-annotate-char annotate-char) - (setq mh-annotate-field annotate-field) - (setq mh-previous-window-config config) - (setq mode-line-buffer-identification (list " {%b}")) - (mh-logo-display) - (mh-make-local-hook 'kill-buffer-hook) - (add-hook 'kill-buffer-hook 'mh-tidy-draft-buffer nil t) - (if (and (boundp 'mh-compose-letter-function) - mh-compose-letter-function) - ;; run-hooks will not pass arguments. - (let ((value mh-compose-letter-function)) - (if (and (listp value) (not (eq (car value) 'lambda))) - (while value - (funcall (car value) to subject cc) - (setq value (cdr value))) - (funcall mh-compose-letter-function to subject cc))))) - -(defun mh-letter-mode-message () - "Display a help message for users of `mh-letter-mode'. -This should be the last function called when composing the draft." - (message "%s" (substitute-command-keys - (concat "Type \\[mh-send-letter] to send message, " - "\\[mh-help] for help")))) +(defun mh-regexp-in-field-p (regexp &rest fields) + "Non-nil means REGEXP was found in FIELDS." + (save-excursion + (let ((search-result nil) + (field)) + (while fields + (setq field (car fields)) + (if (and (mh-goto-header-field field) + (re-search-forward + regexp (save-excursion (mh-header-field-end)(point)) t)) + (setq fields nil + search-result t) + (setq fields (cdr fields)))) + search-result))) (defun mh-ascii-buffer-p () "Check if current buffer is entirely composed of ASCII. @@ -1435,739 +1126,6 @@ doesn't exist there." unless (eq charset 'ascii) return nil finally return t)) -;; Shush compiler. -(eval-when-compile (defvar sendmail-coding-system)) - -;;;###mh-autoload -(defun mh-send-letter (&optional arg) - "Save draft and send message. - -When you are all through editing a message, you send it with this -command. You can give a prefix argument ARG to monitor the first stage -of the delivery\; this output can be found in a buffer called \"*MH-E -Mail Delivery*\". - -The hook `mh-before-send-letter-hook' is run at the beginning of -this command. For example, if you want to check your spelling in -your message before sending, add the function `ispell-message'. - -In case the MH \"send\" program is installed under a different name, -use `mh-send-prog' to tell MH-E the name." - (interactive "P") - (run-hooks 'mh-before-send-letter-hook) - (if (and (mh-insert-auto-fields t) - mh-auto-fields-prompt-flag - (goto-char (point-min))) - (if (not (y-or-n-p "Auto fields inserted, send? ")) - (error "Send aborted"))) - (cond ((mh-mh-directive-present-p) - (mh-mh-to-mime)) - ((or (mh-mml-tag-present-p) (not (mh-ascii-buffer-p))) - (mh-mml-to-mime))) - (save-buffer) - (message "Sending...") - (let ((draft-buffer (current-buffer)) - (file-name buffer-file-name) - (config mh-previous-window-config) - (coding-system-for-write - (if (and (local-variable-p 'buffer-file-coding-system - (current-buffer)) ;XEmacs needs two args - ;; We're not sure why, but buffer-file-coding-system - ;; tends to get set to undecided-unix. - (not (memq buffer-file-coding-system - '(undecided undecided-unix undecided-dos)))) - buffer-file-coding-system - (or (and (boundp 'sendmail-coding-system) sendmail-coding-system) - (and (boundp 'default-buffer-file-coding-system ) - default-buffer-file-coding-system) - 'iso-latin-1)))) - ;; Adding a Message-ID field looks good, makes it easier to search for - ;; message in your +outbox, and best of all doesn't break threading for - ;; the recipient if you reply to a message in your +outbox. - (setq mh-send-args (concat "-msgid " mh-send-args)) - ;; The default BCC encapsulation will make a MIME message unreadable. - ;; With nmh use the -mime arg to prevent this. - (if (and (mh-variant-p 'nmh) - (mh-goto-header-field "Bcc:") - (mh-goto-header-field "Content-Type:")) - (setq mh-send-args (concat "-mime " mh-send-args))) - (cond (arg - (pop-to-buffer mh-mail-delivery-buffer) - (erase-buffer) - (mh-exec-cmd-output mh-send-prog t "-watch" "-nopush" - "-nodraftfolder" mh-send-args file-name) - (goto-char (point-max)) ; show the interesting part - (recenter -1) - (set-buffer draft-buffer)) ; for annotation below - (t - (mh-exec-cmd-daemon mh-send-prog nil "-nodraftfolder" "-noverbose" - mh-send-args file-name))) - (if mh-annotate-char - (mh-annotate-msg mh-sent-from-msg - mh-sent-from-folder - mh-annotate-char - "-component" mh-annotate-field - "-text" (format "\"%s %s\"" - (mh-get-header-field "To:") - (mh-get-header-field "Cc:")))) - - (cond ((or (not arg) - (y-or-n-p "Kill draft buffer? ")) - (kill-buffer draft-buffer) - (if config - (set-window-configuration config)))) - (if arg - (message "Sending...done") - (message "Sending...backgrounded")))) - -;;;###mh-autoload -(defun mh-insert-letter (folder message verbatim) - "Insert a message. - -This command prompts you for the FOLDER and MESSAGE number, which -defaults to the current message in that folder. It then inserts -the message, indented by `mh-ins-buf-prefix' (\"> \") unless -`mh-yank-behavior' is set to one of the supercite flavors in -which case supercite is used to format the message. Certain -undesirable header fields (see -`mh-invisible-header-fields-compiled') are removed before -insertion. - -If given a prefix argument VERBATIM, the header is left intact, the -message is not indented, and \"> \" is not inserted before each line. -This command leaves the mark before the letter and point after it." - (interactive - (let* ((folder - (mh-prompt-for-folder "Message from" - mh-sent-from-folder nil)) - (default - (if (and (equal folder mh-sent-from-folder) - (numberp mh-sent-from-msg)) - mh-sent-from-msg - (nth 0 (mh-translate-range folder "cur")))) - (message - (read-string (concat "Message number" - (or (and default - (format " (default %d): " default)) - ": "))))) - (list folder message current-prefix-arg))) - (save-restriction - (narrow-to-region (point) (point)) - (let ((start (point-min))) - (if (and (equal message "") (numberp mh-sent-from-msg)) - (setq message (int-to-string mh-sent-from-msg))) - (insert-file-contents - (expand-file-name message (mh-expand-file-name folder))) - (when (not verbatim) - (mh-clean-msg-header start mh-invisible-header-fields-compiled nil) - (goto-char (point-max)) ;Needed for sc-cite-original - (push-mark) ;Needed for sc-cite-original - (goto-char (point-min)) ;Needed for sc-cite-original - (mh-insert-prefix-string mh-ins-buf-prefix))))) - -(defun mh-extract-from-attribution () - "Extract phrase or comment from From header field." - (save-excursion - (if (not (mh-goto-header-field "From: ")) - nil - (skip-chars-forward " ") - (cond - ((looking-at "\"\\([^\"\n]+\\)\" \\(<.+>\\)") - (format "%s %s " (match-string 1)(match-string 2))) - ((looking-at "\\([^<\n]+<.+>\\)$") - (format "%s " (match-string 1))) - ((looking-at "\\([^ ]+@[^ ]+\\) +(\\(.+\\))$") - (format "%s <%s> " (match-string 2)(match-string 1))) - ((looking-at " *\\(.+\\)$") - (format "%s " (match-string 1))))))) - -;;;###mh-autoload -(defun mh-yank-cur-msg () - "Insert the current message into the draft buffer. - -It is often useful to insert a snippet of text from a letter that -someone mailed to provide some context for your reply. This -command does this by adding an attribution, yanking a portion of -text from the message to which you're replying, and inserting -`mh-ins-buf-prefix' (`> ') before each line. - -The attribution consists of the sender's name and email address -followed by the content of the option -`mh-extract-from-attribution-verb'. - -You can also turn on the option -`mh-delete-yanked-msg-window-flag' to delete the window -containing the original message after yanking it to make more -room on your screen for your reply. - -You can control how the message to which you are replying is -yanked into your reply using `mh-yank-behavior'. - -If this isn't enough, you can gain full control over the -appearance of the included text by setting `mail-citation-hook' -to a function that modifies it. For example, if you set this hook -to `trivial-cite' (which is NOT part of Emacs), set -`mh-yank-behavior' to \"Body and Header\" (see URL -`http://shasta.cs.uiuc.edu/~lrclause/tc.html'). - -Note that if `mail-citation-hook' is set, `mh-ins-buf-prefix' is -not inserted. If the option `mh-yank-behavior' is set to one of -the supercite flavors, the hook `mail-citation-hook' is ignored -and `mh-ins-buf-prefix' is not inserted." - (interactive) - (if (and mh-sent-from-folder - (save-excursion (set-buffer mh-sent-from-folder) mh-show-buffer) - (save-excursion (set-buffer mh-sent-from-folder) - (get-buffer mh-show-buffer)) - mh-sent-from-msg) - (let ((to-point (point)) - (to-buffer (current-buffer))) - (set-buffer mh-sent-from-folder) - (if mh-delete-yanked-msg-window-flag - (delete-windows-on mh-show-buffer)) - (set-buffer mh-show-buffer) ; Find displayed message - (let* ((from-attr (mh-extract-from-attribution)) - (yank-region (mh-mark-active-p nil)) - (mh-ins-str - (cond ((and yank-region - (or (eq 'supercite mh-yank-behavior) - (eq 'autosupercite mh-yank-behavior) - (eq t mh-yank-behavior))) - ;; supercite needs the full header - (concat - (buffer-substring (point-min) (mh-mail-header-end)) - "\n" - (buffer-substring (region-beginning) (region-end)))) - (yank-region - (buffer-substring (region-beginning) (region-end))) - ((or (eq 'body mh-yank-behavior) - (eq 'attribution mh-yank-behavior) - (eq 'autoattrib mh-yank-behavior)) - (buffer-substring - (save-excursion - (goto-char (point-min)) - (mh-goto-header-end 1) - (point)) - (point-max))) - ((or (eq 'supercite mh-yank-behavior) - (eq 'autosupercite mh-yank-behavior) - (eq t mh-yank-behavior)) - (buffer-substring (point-min) (point-max))) - (t - (buffer-substring (point) (point-max)))))) - (set-buffer to-buffer) - (save-restriction - (narrow-to-region to-point to-point) - (insert (mh-filter-out-non-text mh-ins-str)) - (goto-char (point-max)) ;Needed for sc-cite-original - (push-mark) ;Needed for sc-cite-original - (goto-char (point-min)) ;Needed for sc-cite-original - (mh-insert-prefix-string mh-ins-buf-prefix) - (when (or (eq 'attribution mh-yank-behavior) - (eq 'autoattrib mh-yank-behavior)) - (insert from-attr) - (mh-identity-insert-attribution-verb nil) - (insert "\n\n")) - ;; If the user has selected a region, he has already "edited" the - ;; text, so leave the cursor at the end of the yanked text. In - ;; either case, leave a mark at the opposite end of the included - ;; text to make it easy to jump or delete to the other end of the - ;; text. - (push-mark) - (goto-char (point-max)) - (if (null yank-region) - (mh-exchange-point-and-mark-preserving-active-mark))))) - (error "There is no current message"))) - -(defun mh-filter-out-non-text (string) - "Return STRING but without adornments such as MIME buttons and smileys." - (with-temp-buffer - ;; Insert the string to filter - (insert string) - (goto-char (point-min)) - - ;; Remove the MIME buttons - (let ((can-move-forward t) - (in-button nil)) - (while can-move-forward - (cond ((and (not (get-text-property (point) 'mh-data)) - in-button) - (delete-region (1- (point)) (point)) - (setq in-button nil)) - ((get-text-property (point) 'mh-data) - (delete-region (point) - (save-excursion (forward-line) (point))) - (setq in-button t)) - (t (setq can-move-forward (= (forward-line) 0)))))) - - ;; Return the contents without properties... This gets rid of emphasis - ;; and smileys - (buffer-substring-no-properties (point-min) (point-max)))) - -(defun mh-insert-prefix-string (mh-ins-string) - "Insert prefix string before each line in buffer. -The inserted letter is cited using `sc-cite-original' if -`mh-yank-behavior' is one of 'supercite or 'autosupercite. -Otherwise, simply insert MH-INS-STRING before each line." - (goto-char (point-min)) - (cond ((or (eq mh-yank-behavior 'supercite) - (eq mh-yank-behavior 'autosupercite)) - (sc-cite-original)) - (mail-citation-hook - (run-hooks 'mail-citation-hook)) - (mh-yank-hooks ;old hook name - (run-hooks 'mh-yank-hooks)) - (t - (or (bolp) (forward-line 1)) - (while (< (point) (point-max)) - (insert mh-ins-string) - (forward-line 1)) - (goto-char (point-min))))) ;leave point like sc-cite-original - -;;;###mh-autoload -(defun mh-fully-kill-draft () - "Quit editing and delete draft message. - -If for some reason you are not happy with the draft, you can use -this command to kill the draft buffer and delete the draft -message. Use the command \\[kill-buffer] if you don't want to -delete the draft message." - (interactive) - (if (y-or-n-p "Kill draft message? ") - (let ((config mh-previous-window-config)) - (if (file-exists-p buffer-file-name) - (delete-file buffer-file-name)) - (set-buffer-modified-p nil) - (kill-buffer (buffer-name)) - (message "") - (if config - (set-window-configuration config))) - (error "Message not killed"))) - -(defun mh-current-fill-prefix () - "Return the `fill-prefix' on the current line as a string." - (save-excursion - (beginning-of-line) - ;; This assumes that the major-mode sets up adaptive-fill-regexp - ;; correctly such as mh-letter-mode or sendmail.el's mail-mode. But - ;; perhaps I should use the variable and simply inserts its value here, - ;; and set it locally in a let scope. --psg - (if (re-search-forward adaptive-fill-regexp nil t) - (match-string 0) - ""))) - -;;;###mh-autoload -(defun mh-open-line () - "Insert a newline and leave point before it. - -This command is similar to the command \\[open-line] in that it -inserts a newline after point. It differs in that it also inserts -the right number of quoting characters and spaces so that the -next line begins in the same column as it was. This is useful -when breaking up paragraphs in replies." - (interactive) - (let ((column (current-column)) - (prefix (mh-current-fill-prefix))) - (if (> (length prefix) column) - (message "Sorry, point seems to be within the line prefix") - (newline 2) - (insert prefix) - (while (> column (current-column)) - (insert " ")) - (forward-line -1)))) - -(mh-do-in-xemacs (defvar mail-abbrevs)) - -(defmacro mh-display-completion-list-compat (word choices) - "Completes WORD from CHOICES using `display-completion-list'. -Calls `display-completion-list' correctly in older environments. -Versions of Emacs prior to version 22 lacked a COMMON-SUBSTRING -argument which is used to highlight the next possible character you -can enter in the current list of completions." - (if (>= emacs-major-version 22) - `(display-completion-list (all-completions ,word ,choices) ,word) - `(display-completion-list (all-completions ,word ,choices)))) - -;;;###mh-autoload -(defun mh-complete-word (word choices begin end) - "Complete WORD at from CHOICES. -Any match found replaces the text from BEGIN to END." - (let ((completion (try-completion word choices)) - (completions-buffer "*Completions*")) - (cond ((eq completion t) - (ignore-errors - (kill-buffer completions-buffer)) - (message "Completed: %s" word)) - ((null completion) - (ignore-errors - (kill-buffer completions-buffer)) - (message "No completion for %s" word)) - ((stringp completion) - (if (equal word completion) - (with-output-to-temp-buffer completions-buffer - (mh-display-completion-list-compat word choices)) - (ignore-errors - (kill-buffer completions-buffer)) - (delete-region begin end) - (insert completion)))))) - -;;;###mh-autoload -(defun mh-beginning-of-word (&optional n) - "Return position of the N th word backwards." - (unless n (setq n 1)) - (let ((syntax-table (syntax-table))) - (unwind-protect - (save-excursion - (mh-mail-abbrev-make-syntax-table) - (set-syntax-table mail-abbrev-syntax-table) - (backward-word n) - (point)) - (set-syntax-table syntax-table)))) - -(defun mh-folder-expand-at-point () - "Do folder name completion in Fcc header field." - (let* ((end (point)) - (beg (mh-beginning-of-word)) - (folder (buffer-substring beg end)) - (leading-plus (and (> (length folder) 0) (equal (aref folder 0) ?+))) - (last-slash (mh-search-from-end ?/ folder)) - (prefix (and last-slash (substring folder 0 last-slash))) - (choices (mapcar #'(lambda (x) - (list (cond (prefix (format "%s/%s" prefix x)) - (leading-plus (format "+%s" x)) - (t x)))) - (mh-folder-completion-function folder nil t)))) - (mh-complete-word folder choices beg end))) - -(defvar mh-letter-complete-function-alist - '((bcc . mh-alias-letter-expand-alias) - (cc . mh-alias-letter-expand-alias) - (dcc . mh-alias-letter-expand-alias) - (fcc . mh-folder-expand-at-point) - (from . mh-alias-letter-expand-alias) - (mail-followup-to . mh-alias-letter-expand-alias) - (mail-reply-to . mh-alias-letter-expand-alias) - (reply-to . mh-alias-letter-expand-alias) - (to . mh-alias-letter-expand-alias)) - "Alist of header fields and completion functions to use.") - -(defun mh-letter-complete (arg) - "Perform completion on header field or word preceding point. - -If the field contains addresses (for example, \"To:\" or \"Cc:\") -or folders (for example, \"Fcc:\") then this command will provide -alias completion. In the body of the message, this command runs -`mh-letter-complete-function' instead, which is set to -`ispell-complete-word' by default. This command takes a prefix -argument ARG that is passed to the -`mh-letter-complete-function'." - (interactive "P") - (let ((func nil)) - (cond ((not (mh-in-header-p)) - (funcall mh-letter-complete-function arg)) - ((setq func (cdr (assoc (mh-letter-header-field-at-point) - mh-letter-complete-function-alist))) - (funcall func)) - (t (funcall mh-letter-complete-function arg))))) - -(defun mh-letter-complete-or-space (arg) - "Perform completion or insert space. - -Turn on the option `mh-compose-space-does-completion-flag' to use -this command to perform completion in the header. Otherwise, a -space is inserted; use a prefix argument ARG to specify more than -one space." - (interactive "p") - (let ((func nil) - (end-of-prev (save-excursion - (goto-char (mh-beginning-of-word)) - (mh-beginning-of-word -1)))) - (cond ((not mh-compose-space-does-completion-flag) - (self-insert-command arg)) - ((not (mh-in-header-p)) (self-insert-command arg)) - ((> (point) end-of-prev) (self-insert-command arg)) - ((setq func (cdr (assoc (mh-letter-header-field-at-point) - mh-letter-complete-function-alist))) - (funcall func)) - (t (self-insert-command arg))))) - -(defun mh-letter-confirm-address () - "Flash alias expansion. - -Addresses are separated by a comma\; when you press the comma, -this command flashes the alias expansion in the minibuffer if -`mh-alias-flash-on-comma' is turned on." - (interactive) - (cond ((not (mh-in-header-p)) (self-insert-command 1)) - ((eq (cdr (assoc (mh-letter-header-field-at-point) - mh-letter-complete-function-alist)) - 'mh-alias-letter-expand-alias) - (mh-alias-reload-maybe) - (mh-alias-minibuffer-confirm-address)) - (t (self-insert-command 1)))) - -(defvar mh-letter-header-field-regexp "^\\([A-Za-z][A-Za-z0-9-]*\\):") - -(defun mh-letter-header-field-at-point () - "Return the header field name at point. -A symbol is returned whose name is the string obtained by -downcasing the field name." - (save-excursion - (end-of-line) - (and (re-search-backward mh-letter-header-field-regexp nil t) - (intern (downcase (match-string 1)))))) - -;;;###mh-autoload -(defun mh-letter-next-header-field-or-indent (arg) - "Cycle to next field. - -Within the header of the message, this command moves between -fields that are highlighted with the face -`mh-letter-header-field', skipping those fields listed in -`mh-compose-skipped-header-fields'. After the last field, this -command then moves point to the message body before cycling back -to the first field. If point is already past the first line of -the message body, then this command indents by calling -`indent-relative' with the given prefix argument ARG." - (interactive "P") - (let ((header-end (save-excursion - (goto-char (mh-mail-header-end)) - (forward-line) - (point)))) - (if (> (point) header-end) - (indent-relative arg) - (mh-letter-next-header-field)))) - -(defun mh-letter-next-header-field () - "Cycle to the next header field. -If we are at the last header field go to the start of the message -body." - (let ((header-end (mh-mail-header-end))) - (cond ((>= (point) header-end) (goto-char (point-min))) - ((< (point) (progn - (beginning-of-line) - (re-search-forward mh-letter-header-field-regexp - (line-end-position) t) - (point))) - (beginning-of-line)) - (t (end-of-line))) - (cond ((re-search-forward mh-letter-header-field-regexp header-end t) - (if (mh-letter-skipped-header-field-p (match-string 1)) - (mh-letter-next-header-field) - (mh-letter-skip-leading-whitespace-in-header-field))) - (t (goto-char header-end) - (forward-line))))) - -;;;###mh-autoload -(defun mh-letter-previous-header-field () - "Cycle to the previous header field. - -This command moves backwards between the fields and cycles to the -body of the message after the first field. Unlike the command -\\[mh-letter-next-header-field-or-indent], it will always take -point to the last field from anywhere in the body." - (interactive) - (let ((header-end (mh-mail-header-end))) - (if (>= (point) header-end) - (goto-char header-end) - (mh-header-field-beginning)) - (cond ((re-search-backward mh-letter-header-field-regexp nil t) - (if (mh-letter-skipped-header-field-p (match-string 1)) - (mh-letter-previous-header-field) - (goto-char (match-end 0)) - (mh-letter-skip-leading-whitespace-in-header-field))) - (t (goto-char header-end) - (forward-line))))) - -(defun mh-letter-skipped-header-field-p (field) - "Check if FIELD is to be skipped." - (let ((field (downcase field))) - (loop for x in mh-compose-skipped-header-fields - when (equal (downcase x) field) return t - finally return nil))) - -(defun mh-letter-skip-leading-whitespace-in-header-field () - "Skip leading whitespace in a header field. -If the header field doesn't have at least one space after the -colon then a space character is added." - (let ((need-space t)) - (while (memq (char-after) '(?\t ?\ )) - (forward-char) - (setq need-space nil)) - (when need-space (insert " ")))) - -(defvar mh-hidden-header-keymap - (let ((map (make-sparse-keymap))) - (mh-do-in-gnu-emacs - (define-key map [mouse-2] 'mh-letter-toggle-header-field-display-button)) - (mh-do-in-xemacs - (define-key map '(button2) - 'mh-letter-toggle-header-field-display-button)) - map)) - -(defun mh-letter-toggle-header-field-display-button (event) - "Toggle header field display at location of EVENT. -This function does the same thing as -`mh-letter-toggle-header-field-display' except that it is -callable from a mouse button." - (interactive "e") - (mh-do-at-event-location event - (mh-letter-toggle-header-field-display nil))) - -(defun mh-letter-toggle-header-field-display (arg) - "Toggle display of header field at point. - -Use this command to display truncated header fields. This command -is a toggle so entering it again will hide the field. This -command takes a prefix argument ARG: if negative then the field -is hidden, if positive then the field is displayed." - (interactive (list nil)) - (when (and (mh-in-header-p) - (progn - (end-of-line) - (re-search-backward mh-letter-header-field-regexp nil t))) - (let ((buffer-read-only nil) - (modified-flag (buffer-modified-p)) - (begin (point)) - end) - (end-of-line) - (setq end (1- (if (re-search-forward "^[^ \t]" nil t) - (match-beginning 0) - (point-max)))) - (goto-char begin) - ;; Make it clickable... - (add-text-properties begin end `(keymap ,mh-hidden-header-keymap - mouse-face highlight)) - (unwind-protect - (cond ((or (and (not arg) - (text-property-any begin end 'invisible 'vanish)) - (and (numberp arg) (>= arg 0)) - (and (eq arg 'long) (> (line-beginning-position 5) end))) - (remove-text-properties begin end '(invisible nil)) - (search-forward ":" (line-end-position) t) - (mh-letter-skip-leading-whitespace-in-header-field)) - ;; XXX Redesign to make usable by user. Perhaps use a positive - ;; numeric prefix to make that many lines visible. - ((eq arg 'long) - (end-of-line 4) - (mh-letter-truncate-header-field end) - (beginning-of-line)) - (t (end-of-line) - (mh-letter-truncate-header-field end) - (beginning-of-line))) - (set-buffer-modified-p modified-flag))))) - -(defun mh-letter-truncate-header-field (end) - "Replace text from current line till END with an ellipsis. -If the current line is too long truncate a part of it as well." - (let ((max-len (min (window-width) 62))) - (when (> (+ (current-column) 4) max-len) - (backward-char (- (+ (current-column) 5) max-len))) - (when (> end (point)) - (add-text-properties (point) end '(invisible vanish))))) - -(defun mh-letter-hide-all-skipped-fields () - "Hide all skipped fields." - (save-excursion - (goto-char (point-min)) - (save-restriction - (narrow-to-region (point) (mh-mail-header-end)) - (while (re-search-forward mh-letter-header-field-regexp nil t) - (if (mh-letter-skipped-header-field-p (match-string 1)) - (mh-letter-toggle-header-field-display -1) - (mh-letter-toggle-header-field-display 'long)) - (beginning-of-line 2))))) - -(defun mh-interactive-read-address (prompt) - "Read an address. -If `mh-compose-prompt-flag' is non-nil, then read an address with -PROMPT. -Otherwise return the empty string." - (if mh-compose-prompt-flag (mh-read-address prompt) "")) - -(defun mh-interactive-read-string (prompt) - "Read a string. -If `mh-compose-prompt-flag' is non-nil, then read a string with -PROMPT. -Otherwise return the empty string." - (if mh-compose-prompt-flag (read-string prompt) "")) - -(defun mh-letter-adjust-point () - "Move cursor to first header field if are using the no prompt mode." - (unless mh-compose-prompt-flag - (goto-char (point-max)) - (mh-letter-next-header-field))) - - - -;;; Build mh-letter-mode keymap - -;; If this changes, modify mh-letter-mode-help-messages accordingly, above. -(gnus-define-keys mh-letter-mode-map - " " mh-letter-complete-or-space - "," mh-letter-confirm-address - "\C-c?" mh-help - "\C-c\C-\\" mh-fully-kill-draft ;if no C-q - "\C-c\C-^" mh-insert-signature ;if no C-s - "\C-c\C-c" mh-send-letter - "\C-c\C-d" mh-insert-identity - "\C-c\C-e" mh-mh-to-mime - "\C-c\C-f\C-a" mh-to-field - "\C-c\C-f\C-b" mh-to-field - "\C-c\C-f\C-c" mh-to-field - "\C-c\C-f\C-d" mh-to-field - "\C-c\C-f\C-f" mh-to-fcc - "\C-c\C-f\C-l" mh-to-field - "\C-c\C-f\C-m" mh-to-field - "\C-c\C-f\C-r" mh-to-field - "\C-c\C-f\C-s" mh-to-field - "\C-c\C-f\C-t" mh-to-field - "\C-c\C-fa" mh-to-field - "\C-c\C-fb" mh-to-field - "\C-c\C-fc" mh-to-field - "\C-c\C-fd" mh-to-field - "\C-c\C-ff" mh-to-fcc - "\C-c\C-fl" mh-to-field - "\C-c\C-fm" mh-to-field - "\C-c\C-fr" mh-to-field - "\C-c\C-fs" mh-to-field - "\C-c\C-ft" mh-to-field - "\C-c\C-i" mh-insert-letter - "\C-c\C-m\C-e" mh-mml-secure-message-encrypt - "\C-c\C-m\C-f" mh-compose-forward - "\C-c\C-m\C-g" mh-mh-compose-anon-ftp - "\C-c\C-m\C-i" mh-compose-insertion - "\C-c\C-m\C-m" mh-mml-to-mime - "\C-c\C-m\C-n" mh-mml-unsecure-message - "\C-c\C-m\C-s" mh-mml-secure-message-sign - "\C-c\C-m\C-t" mh-mh-compose-external-compressed-tar - "\C-c\C-m\C-u" mh-mh-to-mime-undo - "\C-c\C-m\C-x" mh-mh-compose-external-type - "\C-c\C-mee" mh-mml-secure-message-encrypt - "\C-c\C-mes" mh-mml-secure-message-signencrypt - "\C-c\C-mf" mh-compose-forward - "\C-c\C-mg" mh-mh-compose-anon-ftp - "\C-c\C-mi" mh-compose-insertion - "\C-c\C-mm" mh-mml-to-mime - "\C-c\C-mn" mh-mml-unsecure-message - "\C-c\C-mse" mh-mml-secure-message-signencrypt - "\C-c\C-mss" mh-mml-secure-message-sign - "\C-c\C-mt" mh-mh-compose-external-compressed-tar - "\C-c\C-mu" mh-mh-to-mime-undo - "\C-c\C-mx" mh-mh-compose-external-type - "\C-c\C-o" mh-open-line - "\C-c\C-q" mh-fully-kill-draft - "\C-c\C-s" mh-insert-signature - "\C-c\C-t" mh-letter-toggle-header-field-display - "\C-c\C-w" mh-check-whom - "\C-c\C-y" mh-yank-cur-msg - "\C-c\M-d" mh-insert-auto-fields - "\M-\t" mh-letter-complete - "\t" mh-letter-next-header-field-or-indent - [backtab] mh-letter-previous-header-field) - -;; "C-c /" prefix is used in mh-letter-mode by pgp.el and mailcrypt.el. - (provide 'mh-comp) ;; Local Variables: diff --git a/lisp/mh-e/mh-compat.el b/lisp/mh-e/mh-compat.el new file mode 100644 index 00000000000..c57e38f1b48 --- /dev/null +++ b/lisp/mh-e/mh-compat.el @@ -0,0 +1,72 @@ +;;; mh-compat.el --- make MH-E compatibile with various versions of Emacs + +;; Copyright (C) 2006 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., 51 Franklin Street, Fifth Floor, +;; Boston, MA 02110-1301, USA. + +;;; Commentary: + +;;; Change Log: + +;;; Code: + +;; This is a good place to gather code that is used for compatibility +;; between different versions of Emacs. Please document which versions +;; of Emacs that the defsubst, defalias, or defmacro applies. That +;; way, it's easy to occasionally go through this file and see which +;; macros we can retire. + +;; See also mh-gnus.el for compatibility macros used to span different +;; versions of Gnus. + +;; Macros are listed alphabetically. + +(unless (fboundp 'assoc-string) + (defsubst assoc-string (key list case-fold) + "Like `assoc' but specifically for strings. +Case is ignored if CASE-FOLD is non-nil. +This function added by MH-E for Emacs versions that lack +`assoc-string', introduced in Emacs 22." + (if case-fold + (assoc-ignore-case key list) + (assoc key list)))) + +(defmacro mh-display-completion-list (completions &optional common-substring) + "Display the list of COMPLETIONS. +Calls `display-completion-list' correctly in older environments. +Versions of Emacs prior to version 22 lacked a COMMON-SUBSTRING +argument which is used to highlight the next possible character you +can enter in the current list of completions." + (if (< emacs-major-version 22) + `(display-completion-list ,completions) + `(display-completion-list ,completions ,common-substring))) + +(provide 'mh-compat) + +;; Local Variables: +;; no-byte-compile: t +;; indent-tabs-mode: nil +;; sentence-end-double-space: nil +;; End: + +;;; mh-compat.el ends here diff --git a/lisp/mh-e/mh-customize.el b/lisp/mh-e/mh-customize.el deleted file mode 100644 index 7089636d9fb..00000000000 --- a/lisp/mh-e/mh-customize.el +++ /dev/null @@ -1,2902 +0,0 @@ -;;; mh-customize.el --- MH-E customization - -;; Copyright (C) 2002, 2003, 2004, 2005, 2006 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., 51 Franklin Street, Fifth Floor, -;; Boston, MA 02110-1301, USA. - -;;; Commentary: - -;; All of the defgroups, defcustoms, and deffaces in MH-E are found -;; here. This makes it possible to customize modules that aren't loaded -;; yet. It also makes it easier to organize the customization groups. - -;; This file contains the following sections: -;; -;; 1. MH-E Customization Groups -;; -;; These are the customization group definitions. Every group has a -;; associated manual node. The ordering is alphabetical, except for the -;; groups mh-faces and mh-hooks which are last . -;; -;; 2. MH-E Customization -;; -;; These are the actual customization variables. There is a sub-section for -;; each group in the MH-E Customization Groups section, in the same order, -;; separated by page breaks. Within each section, variables are sorted -;; alphabetically. -;; -;; 3. Hooks -;; -;; All hooks must be placed in the mh-hook group; in addition, add the -;; group associated with the manual node in which the hook is described. -;; Since the mh-hook group appears near the end of this file, the hooks -;; will appear at the end of these other groups. -;; -;; 4. Faces -;; -;; All faces must be placed in the mh-faces group; in addition, add the -;; group associated with the manual node in which the face is described. -;; Since the mh-faces group appears near the end of this file, the faces -;; will appear at the end of these other groups. -;; -;;; Change Log: - -;;; Code: - -;;(message "> mh-customize") -(provide 'mh-customize) - -(eval-when-compile (require 'mh-acros)) -(mh-require-cl) - -(eval-and-compile - (defvar mh-xemacs-flag (featurep 'xemacs) - "Non-nil means the current Emacs is XEmacs.") - (when mh-xemacs-flag - (require 'mh-xemacs))) - -(eval-and-compile - (require 'mh-identity) - (require 'mh-init) - (require 'mh-loaddefs)) -;;(message "< mh-customize") - -;; For compiler warnings... -(eval-when-compile - (defvar mh-show-buffer) - (defvar mh-show-folder-buffer)) - -(defun mh-customize (&optional delete-other-windows-flag) - "Customize MH-E variables. -If optional argument DELETE-OTHER-WINDOWS-FLAG is non-nil, other -windows in the frame are removed." - (interactive "P") - (customize-group 'mh-e) - (when delete-other-windows-flag - (delete-other-windows))) - - - -;;; MH-E Customization Groups - -(defgroup mh-e nil - "Emacs interface to the MH mail system. -MH is the Rand Mail Handler. Other implementations include nmh -and GNU mailutils." - :link '(custom-manual "(mh-e)Top") - :group 'mail) - -(defgroup mh-alias nil - "Aliases." - :link '(custom-manual "(mh-e)Aliases") - :prefix "mh-alias-" - :group 'mh-e) - -(defgroup mh-folder nil - "Organizing your mail with folders." - :prefix "mh-" - :link '(custom-manual "(mh-e)Folders") - :group 'mh-e) - -(defgroup mh-folder-selection nil - "Folder selection." - :prefix "mh-" - :link '(custom-manual "(mh-e)Folder Selection") - :group 'mh-e) - -(defgroup mh-identity nil - "Identities." - :link '(custom-manual "(mh-e)Identities") - :prefix "mh-identity-" - :group 'mh-e) - -(defgroup mh-inc nil - "Incorporating your mail." - :prefix "mh-inc-" - :link '(custom-manual "(mh-e)Incorporating Mail") - :group 'mh-e) - -(defgroup mh-junk nil - "Dealing with junk mail." - :link '(custom-manual "(mh-e)Junk") - :prefix "mh-junk-" - :group 'mh-e) - -(defgroup mh-letter nil - "Editing a draft." - :prefix "mh-" - :link '(custom-manual "(mh-e)Editing Drafts") - :group 'mh-e) - -(defgroup mh-ranges nil - "Ranges." - :prefix "mh-" - :link '(custom-manual "(mh-e)Ranges") - :group 'mh-e) - -(defgroup mh-scan-line-formats nil - "Scan line formats." - :link '(custom-manual "(mh-e)Scan Line Formats") - :prefix "mh-" - :group 'mh-e) - -(defgroup mh-search nil - "Searching." - :link '(custom-manual "(mh-e)Searching") - :prefix "mh-search-" - :group 'mh-e) - -(defgroup mh-sending-mail nil - "Sending mail." - :prefix "mh-" - :link '(custom-manual "(mh-e)Sending Mail") - :group 'mh-e) - -(defgroup mh-sequences nil - "Sequences." - :prefix "mh-" - :link '(custom-manual "(mh-e)Sequences") - :group 'mh-e) - -(defgroup mh-show nil - "Reading your mail." - :prefix "mh-" - :link '(custom-manual "(mh-e)Reading Mail") - :group 'mh-e) - -(defgroup mh-speedbar nil - "The speedbar." - :prefix "mh-speed-" - :link '(custom-manual "(mh-e)Speedbar") - :group 'mh-e) - -(defgroup mh-thread nil - "Threading." - :prefix "mh-thread-" - :link '(custom-manual "(mh-e)Threading") - :group 'mh-e) - -(defgroup mh-tool-bar nil - "The tool bar" - :link '(custom-manual "(mh-e)Tool Bar") - :prefix "mh-" - :group 'mh-e) - -(defgroup mh-hooks nil - "MH-E hooks." - :link '(custom-manual "(mh-e)Top") - :prefix "mh-" - :group 'mh-e) - -(defgroup mh-faces nil - "Faces used in MH-E." - :link '(custom-manual "(mh-e)Top") - :prefix "mh-" - :group 'faces - :group 'mh-e) - - - -;;; Emacs interface to the MH mail system (:group mh-e) -(eval-when (compile) - (setq mh-variant 'none)) - -(defcustom mh-path nil - "*Additional list of directories to search for MH. -See `mh-variant'." - :group 'mh-e - :type '(repeat (directory))) - -(defcustom mh-variant 'autodetect - "*Specifies the variant used by MH-E. - -The default setting of this option is \"Auto-detect\" which means -that MH-E will automatically choose the first of nmh, MH, or GNU -mailutils that it finds in the directories listed in -`mh-path' (which you can customize), `mh-sys-path', and -`exec-path'. If, for example, you have both nmh and mailutils -installed and `mh-variant-in-use' was initialized to nmh but you -want to use mailutils, then you can set this option to -\"mailutils\". - -When this variable is changed, MH-E resets `mh-progs', `mh-lib', -`mh-lib-progs', `mh-flists-present-flag', and `mh-variant-in-use' -accordingly." - :type `(radio - (const :tag "Auto-detect" autodetect) - ,@(mapcar (lambda (x) `(const ,(car x))) (mh-variants))) - :set (lambda (symbol value) - (set-default symbol value) ;Done in mh-variant-set-variant! - (mh-variant-set value)) - :group 'mh-e) - - - -;;; Aliases (:group 'mh-alias) - -(defcustom mh-alias-completion-ignore-case-flag t - "*Non-nil means don't consider case significant in MH alias completion. - -As MH ignores case in the aliases, so too does MH-E. However, you -may turn off this option to make case significant which can be -used to segregate completion of your aliases. You might use -lowercase for mailing lists and uppercase for people." - :type 'boolean - :group 'mh-alias) - -(defcustom mh-alias-expand-aliases-flag nil - "*Non-nil means to expand aliases entered in the minibuffer. - -In other words, aliases entered in the minibuffer will be -expanded to the full address in the message draft. By default, -this expansion is not performed." - :type 'boolean - :group 'mh-alias) - -(defcustom mh-alias-flash-on-comma t - "*Specify whether to flash address or warn on translation. - -This option controls the behavior when a [comma] is pressed while -entering aliases or addresses. The default setting flashes the -address associated with an address in the minibuffer briefly, but -does not display a warning if the alias is not found." - :type '(choice (const :tag "Flash but Don't Warn If No Alias" t) - (const :tag "Flash and Warn If No Alias" 1) - (const :tag "Don't Flash Nor Warn If No Alias" nil)) - :group 'mh-alias) - -(defcustom mh-alias-insert-file nil - "*Filename used to store a new MH-E alias. - -The default setting of this option is \"Use Aliasfile Profile -Component\". This option can also hold the name of a file or a -list a file names. If this option is set to a list of file names, -or the \"Aliasfile:\" profile component contains more than one file -name, MH-E will prompt for one of them when MH-E adds an alias." - :type '(choice (const :tag "Use Aliasfile Profile Component" nil) - (file :tag "Alias File") - (repeat :tag "List of Alias Files" file)) - :group 'mh-alias) - -(defcustom mh-alias-insertion-location 'sorted - "Specifies where new aliases are entered in alias files. - -This option is set to \"Alphabetical\" by default. If you organize -your alias file in other ways, then adding aliases to the \"Top\" -or \"Bottom\" of your alias file might be more appropriate." - :type '(choice (const :tag "Alphabetical" sorted) - (const :tag "Top" top) - (const :tag "Bottom" bottom)) - :group 'mh-alias) - -(defcustom mh-alias-local-users t - "*If on, local users are added to alias completion. - -Aliases are created from \"/etc/passwd\" entries with a user ID -larger than a magical number, typically 200. This can be a handy -tool on a machine where you and co-workers exchange messages. -These aliases have the form \"local.first.last\" if a real name is -present in the password file. Otherwise, the alias will have the -form \"local.login\". - -If you're on a system with thousands of users you don't know, and -the loading of local aliases slows MH-E down noticeably, then -turn this option off. - -This option also takes a string which is executed to generate the -password file. For example, use \"ypcat passwd\" to obtain the -NIS password file." - :type '(choice (boolean) (string)) - :group 'mh-alias) - -(defcustom mh-alias-local-users-prefix "local." - "*String prefixed to the real names of users from the password file. -This option can also be set to \"Use Login\". - -For example, consider the following password file entry: - - psg:x:1000:1000:Peter S Galbraith,,,:/home/psg:/bin/tcsh - -The following settings of this option will produce the associated -aliases: - - \"local.\" local.peter.galbraith - \"\" peter.galbraith - Use Login psg - -This option has no effect if variable `mh-alias-local-users' is -turned off." - :type '(choice (const :tag "Use Login" nil) - (string)) - :group 'mh-alias) - -(defcustom mh-alias-passwd-gecos-comma-separator-flag t - "*Non-nil means the gecos field in the password file uses a comma separator. - -In the example in `mh-alias-local-users-prefix', commas are used -to separate different values within the so-called gecos field. -This is a fairly common usage. However, in the rare case that the -gecos field in your password file is not separated by commas and -whose contents may contain commas, you can turn this option off." - :type 'boolean - :group 'mh-alias) - - - -;;; Organizing Your Mail with Folders (:group 'mh-folder) - -(defcustom mh-new-messages-folders t - "Folders searched for the \"unseen\" sequence. - -Set this option to \"Inbox\" to search the \"+inbox\" folder or -\"All\" to search all of the top level folders. Otherwise, list -the folders that should be searched with the \"Choose Folders\" -menu item. - -See also `mh-recursive-folders-flag'." - :type '(choice (const :tag "Inbox" t) - (const :tag "All" nil) - (repeat :tag "Choose Folders" (string :tag "Folder"))) - :group 'mh-folder) - -(defcustom mh-ticked-messages-folders t - "Folders searched for `mh-tick-seq'. - -Set this option to \"Inbox\" to search the \"+inbox\" folder or -\"All\" to search all of the top level folders. Otherwise, list -the folders that should be searched with the \"Choose Folders\" -menu item. - -See also `mh-recursive-folders-flag'." - :type '(choice (const :tag "Inbox" t) - (const :tag "All" nil) - (repeat :tag "Choose Folders" (string :tag "Folder"))) - :group 'mh-folder) - -(defcustom mh-large-folder 200 - "The number of messages that indicates a large folder. - -If a folder is deemed to be large, that is the number of messages -in it exceed this value, then confirmation is needed when it is -visited. Even when `mh-show-threads-flag' is non-nil, the folder -is not automatically threaded, if it is large. If set to nil all -folders are treated as if they are small." - :type '(choice (const :tag "No Limit") integer) - :group 'mh-folder) - -(defcustom mh-recenter-summary-flag nil - "*Non-nil means to recenter the summary window. - -If this option is turned on, recenter the summary window when the -show window is toggled off." - :type 'boolean - :group 'mh-folder) - -(defcustom mh-recursive-folders-flag nil - "*Non-nil means that commands which operate on folders do so recursively." - :type 'boolean - :group 'mh-folder) - -(defcustom mh-sortm-args nil - "*Additional arguments for \"sortm\"\\<mh-folder-mode-map>. - -This option is consulted when a prefix argument is used with -\\[mh-sort-folder]. Normally default arguments to \"sortm\" are -specified in the MH profile. This option may be used to provide -an alternate view. For example, \"'(\"-nolimit\" \"-textfield\" -\"subject\")\" is a useful setting." - :type 'string - :group 'mh-folder) - - - -;;; Folder Selection (:group 'mh-folder-selection) - -(defcustom mh-default-folder-for-message-function nil - "Function to select a default folder for refiling or \"Fcc:\". - -The current buffer is set to the message being refiled with point -at the start of the message. This function should return the -default folder as a string with a leading \"+\" sign. It can also -return nil so that the last folder name is used as the default, -or an empty string to suppress the default entirely." - :type 'function - :group 'mh-folder-selection) - -(defcustom mh-default-folder-list nil - "*List of addresses and folders. - -The folder name associated with the first address found in this -list is used as the default for `mh-refile-msg' and similar -functions. Each element in this list contains a \"Check Recipient\" -item. If this item is turned on, then the address is checked -against the recipient instead of the sender. This is useful for -mailing lists. - -See `mh-prompt-for-refile-folder' and `mh-folder-from-address' -for more information." - :type '(repeat (list (regexp :tag "Address") - (string :tag "Folder") - (boolean :tag "Check Recipient"))) - :group 'mh-folder-selection) - -(defcustom mh-default-folder-must-exist-flag t - "*Non-nil means guessed folder name must exist to be used. - -If the derived folder does not exist, and this option is on, then -the last folder name used is suggested. This is useful if you get -mail from various people for whom you have an alias, but file -them all in the same project folder. - -See `mh-prompt-for-refile-folder' and `mh-folder-from-address' -for more information." - :type 'boolean - :group 'mh-folder-selection) - -(defcustom mh-default-folder-prefix "" - "*Prefix used for folder names generated from aliases. -The prefix is used to prevent clutter in your mail directory. - -See `mh-prompt-for-refile-folder' and `mh-folder-from-address' -for more information." - :type 'string - :group 'mh-folder-selection) - - - -;;; Identities (:group 'mh-identity) - -(defcustom mh-identity-list nil - "*List of identities. - -To customize this option, click on the \"INS\" button and enter a label -such as \"Home\" or \"Work\". Then click on the \"INS\" button with the -label \"Add at least one item below\". Then choose one of the items in -the \"Value Menu\". - -You can specify an alternate \"From:\" header field using the \"From -Field\" menu item. You must include a valid email address. A standard -format is \"First Last <login@@host.domain>\". If you use an initial -with a period, then you must quote your name as in '\"First I. Last\" -<login@@host.domain>'. People usually list the name of the company -where they work using the \"Organization Field\" menu item. Set any -arbitrary header field and value in the \"Other Field\" menu item. -Unless the header field is a standard one, precede the name of your -field's label with \"X-\", as in \"X-Fruit-of-the-Day:\". The value of -\"Attribution Verb\" overrides the setting of -`mh-extract-from-attribution-verb'. Set your signature with the -\"Signature\" menu item. You can specify the contents of -`mh-signature-file-name', a file, or a function. Specify a different -key to sign or encrypt messages with the \"GPG Key ID\" menu item. - -You can select the identities you have added via the menu called -\"Identity\" in the MH-Letter buffer. You can also use -\\[mh-insert-identity]. To clear the fields and signature added by the -identity, select the \"None\" identity. - -The \"Identity\" menu contains two other items to save you from having -to set the identity on every message. The menu item \"Set Default for -Session\" can be used to set the default identity to the current -identity until you exit Emacs. The menu item \"Save as Default\" sets -the option `mh-identity-default' to the current identity setting. You -can also customize the `mh-identity-default' option in the usual -fashion." - :type '(repeat (list :tag "" - (string :tag "Label") - (repeat :tag "Add at least one item below" - (choice - (cons :tag "From Field" - (const "From") - (string :tag "Value")) - (cons :tag "Organization Field" - (const "Organization") - (string :tag "Value")) - (cons :tag "Other Field" - (string :tag "Field") - (string :tag "Value")) - (cons :tag "Attribution Verb" - (const ":attribution-verb") - (string :tag "Value")) - (cons :tag "Signature" - (const :tag "Signature" - ":signature") - (choice - (const :tag "mh-signature-file-name" - nil) - (file) - (function))) - (cons :tag "GPG Key ID" - (const :tag "GPG Key ID" - ":pgg-default-user-id") - (string :tag "Value")))))) - :set 'mh-identity-list-set - :group 'mh-identity) - -(defcustom mh-auto-fields-list nil - "List of recipients for which header lines are automatically inserted. - -This option can be used to set the identity depending on the -recipient. To customize this option, click on the \"INS\" button and -enter a regular expression for the recipient's address. Click on the -\"INS\" button with the \"Add at least one item below\" label. Then choose -one of the items in the \"Value Menu\". - -The \"Identity\" menu item is used to select an identity from those -configured in `mh-identity-list'. All of the information for that -identity will be added if the recipient matches. The \"Fcc Field\" menu -item is used to select a folder that is used in the \"Fcc:\" header. -When you send the message, MH will put a copy of your message in this -folder. The \"Mail-Followup-To Field\" menu item is used to insert an -\"Mail-Followup-To:\" header field with the recipients you provide. If -the recipient's mail user agent supports this header field (as nmh -does), then their replies will go to the addresses listed. This is -useful if their replies go both to the list and to you and you don't -have a mechanism to suppress duplicates. If you reply to someone not -on the list, you must either remove the \"Mail-Followup-To:\" field, or -ensure the recipient is also listed there so that he receives replies -to your reply. Other header fields may be added using the \"Other -Field\" menu item. - -These fields can only be added after the recipient is known. Once the -header contains one or more recipients, run the -\\[mh-insert-auto-fields] command or choose the \"Identity -> Insert -Auto Fields\" menu item to insert these fields manually. However, you -can just send the message and the fields will be added automatically. -You are given a chance to see these fields and to confirm them before -the message is actually sent. You can do away with this confirmation -by turning off the option `mh-auto-fields-prompt-flag'. - -You should avoid using the same header field in `mh-auto-fields-list' -and `mh-identity-list' definitions that may apply to the same message -as the result is undefined." - :type `(repeat - (list :tag "" - (string :tag "Recipient") - (repeat :tag "Add at least one item below" - (choice - (cons :tag "Identity" - (const ":identity") - ,(append - '(radio) - (mapcar - (function (lambda (arg) `(const ,arg))) - (mapcar 'car mh-identity-list)))) - (cons :tag "Fcc Field" - (const "fcc") - (string :tag "Value")) - (cons :tag "Mail-Followup-To Field" - (const "Mail-Followup-To") - (string :tag "Value")) - (cons :tag "Other Field" - (string :tag "Field") - (string :tag "Value")))))) - :group 'mh-identity) - -(defcustom mh-auto-fields-prompt-flag t - "*Non-nil means to prompt before sending if fields inserted. -See `mh-auto-fields-list'." - :type 'boolean - :group 'mh-identity) - -(defcustom mh-identity-default nil - "Default identity to use when `mh-letter-mode' is called. -See `mh-identity-list'." - :type (append - '(radio) - (cons '(const :tag "None" nil) - (mapcar (function (lambda (arg) `(const ,arg))) - (mapcar 'car mh-identity-list)))) - :group 'mh-identity) - -(defcustom mh-identity-handlers - '(("From" . mh-identity-handler-top) - (":default" . mh-identity-handler-bottom) - (":attribution-verb" . mh-identity-handler-attribution-verb) - (":signature" . mh-identity-handler-signature) - (":pgg-default-user-id" . mh-identity-handler-gpg-identity)) - "Handler functions for fields in `mh-identity-list'. - -This option is used to change the way that fields, signatures, -and attributions in `mh-identity-list' are added. To customize -`mh-identity-handlers', replace the name of an existing handler -function associated with the field you want to change with the -name of a function you have written. You can also click on an -\"INS\" button and insert a field of your choice and the name of -the function you have written to handle it. - -The \"Field\" field can be any field that you've used in your -`mh-identity-list'. The special fields \":attribution-verb\", -\":signature\", or \":pgg-default-user-id\" are used for the -`mh-identity-list' choices \"Attribution Verb\", \"Signature\", and -\"GPG Key ID\" respectively. - -The handler associated with the \":default\" field is used when no -other field matches. - -The handler functions are passed two or three arguments: the -FIELD itself (for example, \"From\"), or one of the special -fields (for example, \":signature\"), and the ACTION 'remove or -'add. If the action is 'add, an additional argument -containing the VALUE for the field is given." - :type '(repeat (cons (string :tag "Field") function)) - :group 'mh-identity) - - - -;;; Incorporating Your Mail (:group 'mh-inc) - -(defcustom mh-inc-prog "inc" - "*Program to incorporate new mail into a folder. - -This program generates a one-line summary for each of the new -messages. Unless it is an absolute pathname, the file is assumed -to be in the `mh-progs' directory. You may also link a file to -\"inc\" that uses a different format. You'll then need to modify -several scan line format variables appropriately." - :type 'string - :group 'mh-inc) - -(defcustom mh-inc-spool-list nil - "*Alternate spool files. - -You can use the `mh-inc-spool-list' variable to direct MH-E to -retrieve mail from arbitrary spool files other than your system -mailbox, file it in folders other than your \"+inbox\", and assign -key bindings to incorporate this mail. - -Suppose you are subscribed to the \"mh-e-devel\" mailing list and -you use \"procmail\" to filter this mail into \"~/mail/mh-e\" with -the following recipe in \".procmailrc\": - - MAILDIR=$HOME/mail - :0: - * ^From mh-e-devel-admin@stop.mail-abuse.org - mh-e - -In order to incorporate \"~/mail/mh-e\" into \"+mh-e\" with an -\"I m\" (mh-inc-spool-mh-e) command, customize this option, and click -on the \"INS\" button. Enter a \"Spool File\" of \"~/mail/mh-e\", a -\"Folder\" of \"mh-e\", and a \"Key Binding\" of \"m\". - -You can use \"xbuffy\" to automate the incorporation of this mail -using the \"gnudoit\" command in the \"gnuserv\" package as follows: - - box ~/mail/mh-e - title mh-e - origMode - polltime 10 - headertime 0 - command gnudoit -q '(mh-inc-spool-mh-e)'" - :type '(repeat (list (file :tag "Spool File") - (string :tag "Folder") - (character :tag "Key Binding"))) - :set 'mh-inc-spool-list-set - :group 'mh-inc) - - - -;;; Dealing with Junk Mail (:group 'mh-junk) - -;; Spam fighting program chosen -(defvar mh-junk-choice nil) - -;; Available spam filter interfaces -(defvar mh-junk-function-alist - '((spamassassin mh-spamassassin-blacklist mh-spamassassin-whitelist) - (bogofilter mh-bogofilter-blacklist mh-bogofilter-whitelist) - (spamprobe mh-spamprobe-blacklist mh-spamprobe-whitelist)) - "Available choices of spam programs to use. - -This is an alist. For each element there are functions that -blacklist a message as spam and whitelist a message incorrectly -classified as spam.") - -(defun mh-junk-choose (symbol value) - "Choose spam program to use. - -The function is always called with SYMBOL bound to -`mh-junk-program' and VALUE bound to the new value of -`mh-junk-program'. The function sets the variable -`mh-junk-choice' in addition to `mh-junk-program'." - (set symbol value) - (setq mh-junk-choice - (or value - (loop for element in mh-junk-function-alist - until (executable-find (symbol-name (car element))) - finally return (car element))))) - -;; User customizable variables -(defcustom mh-junk-background nil - "If on, spam programs are run in background. - -By default, the programs are run in the foreground, but this can -be slow when junking large numbers of messages. If you have -enough memory or don't junk that many messages at the same time, -you might try turning on this option." - :type '(choice (const :tag "Off" nil) - (const :tag "On" 0)) - :group 'mh-junk) - -(defcustom mh-junk-disposition nil - "Disposition of junk mail." - :type '(choice (const :tag "Delete Spam" nil) - (string :tag "Spam Folder")) - :group 'mh-junk) - -(defcustom mh-junk-program nil - "Spam program that MH-E should use. - -The default setting of this option is \"Auto-detect\" which means -that MH-E will automatically choose one of SpamAssassin, -bogofilter, or SpamProbe in that order. If, for example, you have -both SpamAssassin and bogofilter installed and you want to use -bogofilter, then you can set this option to \"Bogofilter\"." - :type '(choice (const :tag "Auto-detect" nil) - (const :tag "SpamAssassin" spamassassin) - (const :tag "Bogofilter" bogofilter) - (const :tag "SpamProbe" spamprobe)) - :set 'mh-junk-choose - :group 'mh-junk) - - - -;;; Editing a Draft (:group 'mh-letter) - -(defcustom mh-compose-insertion (if (locate-library "mml") 'mml 'mh) - "Type of tags used when composing MIME messages. - -In addition to MH-style directives, MH-E also supports MML (MIME -Meta Language) tags. (see Info node `(emacs-mime)Composing'). -This option can be used to choose between them. By default, this -option is set to \"MML\" if it is supported since it provides a -lot more functionality. This option can also be set to \"MH\" if -MH-style directives are preferred." - :type '(choice (const :tag "MML" mml) - (const :tag "MH" mh)) - :group 'mh-letter) - -(defcustom mh-compose-skipped-header-fields - '("From" "Organization" "References" "In-Reply-To" - "X-Face" "Face" "X-Image-URL" "X-Mailer") - "List of header fields to skip over when navigating in draft." - :type '(repeat (string :tag "Field")) - :group 'mh-letter) - -(defcustom mh-compose-space-does-completion-flag nil - "*Non-nil means \\<mh-letter-mode-map>\\[mh-letter-complete-or-space] does completion in message header." - :type 'boolean - :group 'mh-letter) - -(defcustom mh-delete-yanked-msg-window-flag nil - "*Non-nil means delete any window displaying the message. - -This deletes the window containing the original message after -yanking it with \\<mh-letter-mode-map>\\[mh-yank-cur-msg] to make -more room on your screen for your reply." - :type 'boolean - :group 'mh-letter) - -(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]. - -The attribution consists of the sender's name and email address -followed by the content of this option. This option can be set to -\"wrote:\", \"a écrit:\", and \"schrieb:\". You can also use the -\"Custom String\" menu item to enter your own verb." - :type '(choice (const "wrote:") - (const "a écrit:") - (const "schrieb:") - (string :tag "Custom String")) - :group 'mh-letter) - -(defcustom mh-ins-buf-prefix "> " - "*String to put before each line of a yanked or inserted message. - -The prefix \"> \" is the default setting of this option. I -suggest that you not modify this option since it is used by many -mailers and news readers: messages are far easier to read if -several included messages have all been indented by the same -string. - -This prefix is not inserted if you use one of the supercite -flavors of `mh-yank-behavior' or you have added a -`mail-citation-hook'." - :type 'string - :group 'mh-letter) - -(defcustom mh-letter-complete-function 'ispell-complete-word - "*Function to call when completing outside of address or folder fields. - -In the body of the message, -\\<mh-letter-mode-map>\\[mh-letter-complete] runs this function, -which is set to \"ispell-complete-word\" by default." - :type '(choice function (const nil)) - :group 'mh-letter) - -(defcustom mh-letter-fill-column 72 - "*Fill column to use in MH Letter mode. - -By default, this option is 72 to allow others to quote your -message without line wrapping." - :type 'integer - :group 'mh-letter) - -(defcustom mh-mml-method-default (if mh-pgp-support-flag "pgpmime" "none") - "Default method to use in security tags. - -This option is used to select between a variety of mail security -mechanisms. The default is \"PGP (MIME)\" if it is supported\; -otherwise, the default is \"None\". Other mechanisms include -vanilla \"PGP\" and \"S/MIME\". - -The `pgg' customization group may have some settings which may -interest you (see Info node `(pgg)'). - -In particular, I turn on the option `pgg-encrypt-for-me' so that -all messages I encrypt are encrypted with my public key as well. -If you keep a copy of all of your outgoing mail with a \"Fcc:\" -header field, this setting is vital so that you can read the mail -you write!" - :type '(choice (const :tag "PGP (MIME)" "pgpmime") - (const :tag "PGP" "pgp") - (const :tag "S/MIME" "smime") - (const :tag "None" "none")) - :group 'mh-letter) - -(defcustom mh-signature-file-name "~/.signature" - "*Source of user's signature. - -By default, the text of your signature is taken from the file -\"~/.signature\". You can read from other sources by changing this -option. This file may contain a vCard in which case an attachment is -added with the vCard. - -This option may also be a symbol, in which case that function is -called. You may not want a signature separator to be added for you; -instead you may want to insert one yourself. Options that you may find -useful to do this include `mh-signature-separator' (when inserting a -signature separator) and `mh-signature-separator-regexp' (for finding -said separator). The function `mh-signature-separator-p', which -reports t if the buffer contains a separator, may be useful as well. - -The signature is inserted into your message with the command -\\<mh-letter-mode-map>\\[mh-insert-signature] or with the option -`mh-identity-list'." - :type 'file - :group 'mh-letter) - -(defcustom mh-signature-separator-flag t - "*Non-nil means a signature separator should be inserted. - -It is not recommended that you change this option since various -mail user agents, including MH-E, use the separator to present -the signature differently, and to suppress the signature when -replying or yanking a letter into a draft." - :type 'boolean - :group 'mh-letter) - -(defcustom mh-x-face-file "~/.face" - "*File containing face header field to insert in outgoing mail. - -If the file starts with either of the strings \"X-Face:\", \"Face:\" -or \"X-Image-URL:\" then the contents are added to the message header -verbatim. Otherwise it is assumed that the file contains the value of -the \"X-Face:\" header field. - -The \"X-Face:\" header field, which is a low-resolution, black and -white image, can be generated using the \"compface\" command (see URL -`ftp://ftp.cs.indiana.edu/pub/faces/compface/compface.tar.Z'). The -\"Online X-Face Converter\" is a useful resource for quick conversion -of images into \"X-Face:\" header fields (see URL -`http://www.dairiki.org/xface/'). - -Use the \"make-face\" script to convert a JPEG image to the higher -resolution, color, \"Face:\" header field (see URL -`http://quimby.gnus.org/circus/face/make-face'). - -The URL of any image can be used for the \"X-Image-URL:\" field and no -processing of the image is required. - -To prevent the setting of any of these header fields, either set -`mh-x-face-file' to nil, or simply ensure that the file defined by -this option doesn't exist." - :type 'file - :group 'mh-letter) - -(defcustom mh-yank-behavior 'attribution - "*Controls which part of a message is yanked by \\<mh-letter-mode-map>\\[mh-yank-cur-msg]. - -To include the entire message, including the entire header, use -\"Body and Header\". Use \"Body\" to yank just the body without -the header. To yank only the portion of the message following the -point, set this option to \"Below Point\". - -Choose \"Invoke supercite\" to pass the entire message and header -through supercite. - -If the \"Body With Attribution\" setting is used, then the -message minus the header is yanked and a simple attribution line -is added at the top using the value of the option -`mh-extract-from-attribution-verb'. This is the default. - -If the \"Invoke supercite\" or \"Body With Attribution\" settings -are used, the \"-noformat\" argument is passed to the \"repl\" -program to override a \"-filter\" or \"-format\" argument. These -settings also have \"Automatically\" variants that perform the -action automatically when you reply so that you don't need to use -\\[mh-yank-cur-msg] at all. Note that this automatic action is -only performed if the show buffer matches the message being -replied to. People who use the automatic variants tend to turn on -the option `mh-delete-yanked-msg-window-flag' as well so that the -show window is never displayed. - -If the show buffer has a region, the option `mh-yank-behavior' is -ignored unless its value is one of Attribution variants in which -case the attribution is added to the yanked region. - -If this option is set to one of the supercite flavors, the hook -`mail-citation-hook' is ignored and `mh-ins-buf-prefix' is not -inserted." - :type '(choice (const :tag "Body and Header" t) - (const :tag "Body" body) - (const :tag "Below Point" nil) - (const :tag "Invoke supercite" supercite) - (const :tag "Invoke supercite, Automatically" autosupercite) - (const :tag "Body With Attribution" attribution) - (const :tag "Body With Attribution, Automatically" - autoattrib)) - :group 'mh-letter) - - - -;;; Ranges (:group 'mh-ranges) - -(defcustom mh-interpret-number-as-range-flag t - "*Non-nil means interpret a number as a range. - -Since one of the most frequent ranges used is \"last:N\", MH-E -will interpret input such as \"200\" as \"last:200\" if this -option is on (which is the default). If you need to scan just the -message 200, then use the range \"200:200\"." - :type 'boolean - :group 'mh-ranges) - - - -;;; Scan Line Formats (:group 'mh-scan-line-formats) - -;; Forward definition. -(defvar mh-scan-format-file t) - -(defun mh-adaptive-cmd-note-flag-check (symbol value) - "Check if desired setting is legal. -Throw an error if user tries to turn on -`mh-adaptive-cmd-note-flag' when `mh-scan-format-file' isn't t. -Otherwise, set SYMBOL to VALUE." - (if (and value - (not (eq mh-scan-format-file t))) - (error "%s %s" "Can't turn on unless `mh-scan-format-file'" - "is set to \"Use MH-E scan Format\"") - (set-default symbol value))) - -;; Forward definition. -(defvar mh-adaptive-cmd-note-flag) - -(defun mh-scan-format-file-check (symbol value) - "Check if desired setting is legal. -Throw an error if user tries to set `mh-scan-format-file' to -anything but t when `mh-adaptive-cmd-note-flag' is on. Otherwise, -set SYMBOL to VALUE." - (if (and (not (eq value t)) - (eq mh-adaptive-cmd-note-flag t)) - (error "%s %s" "You must turn off `mh-adaptive-cmd-note-flag'" - "unless you use \"Use MH-E scan Format\"") - (set-default symbol value))) - -(defcustom mh-adaptive-cmd-note-flag t - "*Non-nil means that the message number width is determined dynamically. - -If you've created your own format to handle long message numbers, -you'll be pleased to know you no longer need it since MH-E adapts its -internal format based upon the largest message number if this option -is on (the default). This option may only be turned on when -`mh-scan-format-file' is set to \"Use MH-E scan Format\". - -If you prefer fixed-width message numbers, turn off this option and -call `mh-set-cmd-note' with the width specified by your format file -\(see `mh-scan-format-file'). For example, the default width is 4, so -you would use \"(mh-set-cmd-note 4)\"." - :type 'boolean - :group 'mh-scan-line-formats - :set 'mh-adaptive-cmd-note-flag-check) - -;; Update forward definition above if default changes. -(defcustom mh-scan-format-file t - "Specifies the format file to pass to the scan program. - -The default setting for this option is \"Use MH-E scan Format\". This -means that the format string will be taken from the either -`mh-scan-format-mh' or `mh-scan-format-nmh' depending on whether MH or -nmh (or GNU mailutils) is in use. This setting also enables you to -turn on the `mh-adaptive-cmd-note-flag' option. - -You can also set this option to \"Use Default scan Format\" to get the -same output as you would get if you ran \"scan\" from the shell. If -you have a format file that you want MH-E to use but not MH, you can -set this option to \"Specify a scan Format File\" and enter the name -of your format file. - -If you change the format of the scan lines you'll need to tell MH-E -how to parse the new format. As you will see, quite a lot of variables -are involved to do that. Use \"\\[apropos] RET mh-scan.*regexp\" to -obtain a list of these variables. You will also have to call -`mh-set-cmd-note' if your notations are not in column 4 (columns in -Emacs start with 0)." - :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-scan-line-formats - :set 'mh-scan-format-file-check) - -(defcustom mh-scan-prog "scan" - "*Program used to scan messages. - -The name of the program that generates a listing of one line per -message is held in this option. Unless this variable contains an -absolute pathname, it is assumed to be in the `mh-progs' -directory. You may link another program to `scan' (see -\"mh-profile(5)\") to produce a different type of listing." - :type 'string - :group 'mh-scan-line-formats) -(make-variable-buffer-local 'mh-scan-prog) - - - -;;; Searching (:group 'mh-search) - -(defcustom mh-search-program nil - "Search program that MH-E shall use. - -The default setting of this option is \"Auto-detect\" which means -that MH-E will automatically choose one of swish++, swish-e, -mairix, namazu, pick and grep in that order. If, for example, you -have both swish++ and mairix installed and you want to use -mairix, then you can set this option to \"mairix\". - -More information about setting up an indexing program to use with -MH-E can be found in the documentation of `mh-search'." - :type '(choice (const :tag "Auto-detect" nil) - (const :tag "swish++" swish++) - (const :tag "swish-e" swish) - (const :tag "mairix" mairix) - (const :tag "namazu" namazu) - (const :tag "pick" pick) - (const :tag "grep" grep)) - :group 'mh-search) - - - -;;; Sending Mail (:group 'mh-sending-mail) - -(defcustom mh-compose-forward-as-mime-flag t - "*Non-nil means that messages are forwarded as attachments. - -By default, this option is on which means that the forwarded -messages are included as attachments. If you would prefer to -forward your messages verbatim (as text, inline), then turn off -this option. Forwarding messages verbatim works well for short, -textual messages, but your recipient won't be able to view any -non-textual attachments that were in the forwarded message. Be -aware that if you have \"forw: -mime\" in your MH profile, then -forwarded messages will always be included as attachments -regardless of the settings of this option." - :type 'boolean - :group 'mh-sending-mail) - -(defcustom mh-compose-letter-function nil - "Invoked when starting a new draft. - -However, it is the last function called before you edit your -message. The consequence of this is that you can write a function -to write and send the message for you. This function is passed -three arguments: the contents of the TO, SUBJECT, and CC header -fields." - :type '(choice (const nil) function) - :group 'mh-sending-mail) - -(defcustom mh-compose-prompt-flag nil - "*Non-nil means prompt for header fields when composing a new draft." - :type 'boolean - :group 'mh-sending-mail) - -(defcustom mh-forward-subject-format "%s: %s" - "*Format string for forwarded message subject. - -This option is a string which includes two escapes (\"%s\"). The -first \"%s\" is replaced with the sender of the original message, -and the second one is replaced with the original \"Subject:\"." - :type 'string - :group 'mh-sending-mail) - -(defcustom mh-insert-x-mailer-flag t - "*Non-nil means append an \"X-Mailer:\" header field to the header. - -This header field includes the version of MH-E and Emacs that you -are using. If you don't want to participate in our marketing, you -can turn this option off." - :type 'boolean - :group 'mh-sending-mail) - -(defcustom mh-redist-full-contents-flag nil - "*Non-nil means the \"dist\" command needs entire letter for redistribution. - -This option must be turned on if \"dist\" requires the whole -letter for redistribution, which is the case if \"send\" is -compiled with the BERK option (which many people abhor). If you -find that MH will not allow you to redistribute a message that -has been redistributed before, turn off this option." - :type 'boolean - :group 'mh-sending-mail) - -(defcustom mh-reply-default-reply-to nil - "*Sets the person or persons to whom a reply will be sent. - -This option is set to \"Prompt\" by default so that you are -prompted for the recipient of a reply. If you find that most of -the time that you specify \"cc\" when you reply to a message, set -this option to \"cc\". Other choices include \"from\", \"to\", or -\"all\". You can always edit the recipients in the draft." - :type '(choice (const :tag "Prompt" nil) - (const "from") - (const "to") - (const "cc") - (const "all")) - :group 'mh-sending-mail) - -(defcustom mh-reply-show-message-flag t - "*Non-nil means the MH-Show buffer is displayed when replying. - -If you include the message automatically, you can hide the -MH-Show buffer by turning off this option. - -See also `mh-reply'." - :type 'boolean - :group 'mh-sending-mail) - - - -;;; Sequences (:group 'mh-sequences) - -;; If `mh-unpropagated-sequences' becomes a defcustom, add the following to -;; the docstring: "Additional sequences that should not to be preserved can be -;; specified by setting `mh-unpropagated-sequences' appropriately." XXX - -(defcustom mh-refile-preserves-sequences-flag t - "*Non-nil means that sequences are preserved when messages are refiled. - -If a message is in any sequence (except \"Previous-Sequence:\" -and \"cur\") when it is refiled, then it will still be in those -sequences in the destination folder. If this behavior is not -desired, then turn off this option." - :type 'boolean - :group 'mh-sequences) - -(defcustom mh-tick-seq 'tick - "The name of the MH sequence for ticked messages. - -You can customize this option if you already use the \"tick\" -sequence for your own use. You can also disable all of the -ticking functions by choosing the \"Disable Ticking\" item but -there isn't much advantage to that." - :type '(choice (const :tag "Disable Ticking" nil) - symbol) - :group 'mh-sequences) - -(defcustom mh-update-sequences-after-mh-show-flag t - "*Non-nil means flush MH sequences to disk after message is shown\\<mh-folder-mode-map>. - -Three sequences are maintained internally by MH-E and pushed out -to MH when a message is shown. They include the sequence -specified by your \"Unseen-Sequence:\" profile entry, \"cur\", -and the sequence listed by the option `mh-tick-seq' which is -\"tick\" by default. If you do not like this behavior, turn off -this option. You can then update the state manually with the -\\[mh-execute-commands], \\[mh-quit], or \\[mh-update-sequences] -commands." - :type 'boolean - :group 'mh-sequences) - - - -;;; Reading Your Mail (:group 'mh-show) - -(defcustom mh-bury-show-buffer-flag t - "*Non-nil means show buffer is buried. - -One advantage of not burying the show buffer is that one can -delete the show buffer more easily in an electric buffer list -because of its proximity to its associated MH-Folder buffer. Try -running \\[electric-buffer-list] to see what I mean." - :type 'boolean - :group 'mh-show) - -(defcustom mh-clean-message-header-flag t - "*Non-nil means remove extraneous header fields. - -See also `mh-invisible-header-fields-default' and -`mh-invisible-header-fields'." - :type 'boolean - :group 'mh-show) - -(defcustom mh-decode-mime-flag (not (not (locate-library "mm-decode"))) - "*Non-nil means attachments are handled\\<mh-folder-mode-map>. - -MH-E can handle attachments as well if the Gnus `mm-decode' -library is present. If so, this option will be on. Otherwise, -you'll see the MIME body parts rather than text or attachments. -There isn't much point in turning off this option; however, you -can inspect it if it appears that the body parts are not being -interpreted correctly or toggle it with the command -\\[mh-toggle-mh-decode-mime-flag] to view the raw message. - -This option also controls the display of quoted-printable -messages and other graphical widgets. See the options -`mh-graphical-smileys-flag' and `mh-graphical-emphasis-flag'." - :type 'boolean - :group 'mh-show) - -(defcustom mh-display-buttons-for-alternatives-flag nil - "*Non-nil means display buttons for all alternative attachments. - -Sometimes, a mail program will produce multiple alternatives of -the attachment in increasing degree of faithfulness to the -original content. By default, only the preferred alternative is -displayed. If this option is on, then the preferred part is shown -inline and buttons are shown for each of the other alternatives." - :type 'boolean - :group 'mh-show) - -(defcustom mh-display-buttons-for-inline-parts-flag nil - "*Non-nil means display buttons for all inline attachments\\<mh-folder-mode-map>. - -The sender can request that attachments should be viewed inline so -that they do not really appear like an attachment at all to the -reader. Most of the time, this is desirable, so by default MH-E -suppresses the buttons for inline attachments. On the other hand, you -may receive code or HTML which the sender has added to his message as -inline attachments so that you can read them in MH-E. In this case, it -is useful to see the buttons so that you know you don't have to cut -and paste the code into a file; you can simply save the attachment. - -If you want to make the buttons visible for inline attachments, you -can use the command \\[mh-toggle-mime-buttons] to toggle the -visibility of these buttons. You can turn on these buttons permanently -by turning on this option. - -MH-E cannot display all attachments inline however. It can display -text (including HTML) and images." - :type 'boolean - :group 'mh-show) - -(defcustom mh-do-not-confirm-flag nil - "*Non-nil means non-reversible commands 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. -Turning on this option means that these actions will be -performed--which is usually desired but cannot be -retracted--without question." - :type 'boolean - :group 'mh-show) - -(defcustom mh-fetch-x-image-url nil - "*Control fetching of \"X-Image-URL:\" header field image. - -Ths option controls the fetching of the \"X-Image-URL:\" header -field image with the following values: - -Ask Before Fetching - You are prompted before the image is fetched. MH-E will - remember your reply and will either use the already fetched - image the next time the same URL is encountered or silently - skip it if you didn't fetch it the first time. This is a - good setting. - -Never Fetch - Images are never fetched and only displayed if they are - already present in the cache. This is the default. - -There isn't a value of \"Always Fetch\" for privacy and DOS (denial of -service) reasons. For example, fetching a URL can tip off a spammer -that you've read his email (which is why you shouldn't blindly answer -yes if you've set this option to \"Ask Before Fetching\"). Someone may -also flood your network and fill your disk drive by sending a torrent -of messages, each specifying a unique URL to a very large file. - -The cache of images is found in the directory \".mhe-x-image-cache\" -within your MH directory. You can add your own face to the \"From:\" -field too. See Info node `(mh-e)Picture'. - -This setting only has effect if the option `mh-show-use-xface-flag' is -turned on." - - :type '(choice (const :tag "Ask Before Fetching" ask) - (const :tag "Never Fetch" nil)) - :group 'mh-show) - -(defcustom mh-graphical-smileys-flag t - "*Non-nil means graphical smileys are displayed. - -It is a long standing custom to inject body language using a -cornucopia of punctuation, also known as the \"smileys\". MH-E -can render these as graphical widgets if this option is turned -on, which it is by default. Smileys include patterns such as :-) -and ;-). - -This option is disabled if the option `mh-decode-mime-flag' is -turned off." - :type 'boolean - :group 'mh-show) - -(defcustom mh-graphical-emphasis-flag t - "*Non-nil means graphical emphasis is displayed. - -A few typesetting features are indicated in ASCII text with -certain characters. If your terminal supports it, MH-E can render -these typesetting directives naturally if this option is turned -on, which it is by default. For example, _underline_ will be -underlined, *bold* will appear in bold, /italics/ will appear in -italics, and so on. See the option `gnus-emphasis-alist' for the -whole list. - -This option is disabled if the option `mh-decode-mime-flag' is -turned off." - :type 'boolean - :group 'mh-show) - -(defcustom mh-highlight-citation-style 'gnus - "Style for highlighting citations. - -If the sender of the message has cited other messages in his -message, then MH-E will highlight these citations to emphasize -the sender's actual response. This option can be customized to -change the highlighting style. The \"Multicolor\" method uses a -different color for each indentation while the \"Monochrome\" -method highlights all citations in red. To disable highlighting -of citations entirely, choose \"None\"." - :type '(choice (const :tag "Multicolor" gnus) - (const :tag "Monochrome" font-lock) - (const :tag "None" nil)) - :group 'mh-show) - -;; Keep fields alphabetized. Mention source, if known. -(defvar mh-invisible-header-fields-internal - '("Approved:" - "Autoforwarded:" - "Bestservhost:" - "Cancel-Lock:" ; NNTP posts - "Content-" ; RFC 2045 - "Delivered-To:" ; Egroups/yahoogroups mailing list manager - "Delivery-Date:" ; MH - "Delivery:" - "DomainKey-Signature:" ;http://antispam.yahoo.com/domainkeys - "Encoding:" - "Envelope-to:" - "Errors-To:" - "Face:" ; Gnus Face header - "Forwarded:" ; MH - "From " ; sendmail - "Importance:" ; MS Outlook - "In-Reply-To:" ; MH - "Lines:" - "List-" ; Mailman mailing list manager - "List-" ; Unknown mailing list managers - "List-Subscribe:" ; Unknown mailing list managers - "List-Unsubscribe:" ; Unknown mailing list managers - "Mail-from:" ; MH - "Mailing-List:" ; Egroups/yahoogroups mailing list manager - "Message-Id:" ; RFC 822 - "Mime-Version" ; RFC 2045 - "NNTP-" ; News - "Old-Return-Path:" - "Original-Encoded-Information-Types:" ; X400 - "Original-Lines:" ; mail to news - "Original-NNTP-" ; mail to news - "Original-Newsgroups:" ; mail to news - "Original-Path:" ; mail to news - "Original-Received:" ; mail to news - "Original-To:" ; mail to news - "Original-X-" ; mail to news - "Originator:" - "P1-Content-Type:" ; X400 - "P1-Message-Id:" ; X400 - "P1-Recipient:" ; X400 - "Path:" - "Precedence:" - "Prev-Resent" ; MH - "Priority:" - "Received:" ; RFC 822 - "Received-SPF:" ; Gmail - "References:" - "Remailed-" ; MH - "Replied:" ; MH - "Resent" ; MH - "Return-Path:" ; RFC 822 - "Sensitivity:" ; MS Outlook - "Status:" ; sendmail - "Thread-" - "Ua-Content-Id:" ; X400 -;; "User-Agent:" ; Similar to X-Mailer, so display it. - "Via:" ; MH - "X-Abuse-Info:" - "X-Abuse-and-DMCA-" - "X-Accept-Language:" - "X-Accept-Language:" ; Netscape/Mozilla - "X-Ack:" - "X-Administrivia-To:" - "X-AntiAbuse:" ; cPanel - "X-Apparently-From:" ; MS Outlook - "X-Apparently-To:" ; Egroups/yahoogroups mailing list manager - "X-Authentication-Warning:" ; sendmail - "X-Beenthere:" ; Mailman mailing list manager - "X-Bogosity:" ; bogofilter - "X-Bugzilla-*" ; Bugzilla - "X-Complaints-To:" - "X-ContentStamp:" ; NetZero - "X-Cron-Env:" - "X-DMCA" - "X-Delivered" - "X-ELNK-Trace:" ; Earthlink mailer - "X-Envelope-Date:" ; GNU mailutils - "X-Envelope-From:" - "X-Envelope-Sender:" - "X-Envelope-To:" - "X-Evolution:" ; Evolution mail client - "X-Face:" - "X-Folder:" ; Spam - "X-From-Line" - "X-Gmail-" ; Gmail - "X-Gnus-Mail-Source:" ; gnus - "X-Greylist:" ; milter-greylist-1.2.1 - "X-Habeas-SWE-1:" ; Spam - "X-Habeas-SWE-2:" ; Spam - "X-Habeas-SWE-3:" ; Spam - "X-Habeas-SWE-4:" ; Spam - "X-Habeas-SWE-5:" ; Spam - "X-Habeas-SWE-6:" ; Spam - "X-Habeas-SWE-7:" ; Spam - "X-Habeas-SWE-8:" ; Spam - "X-Habeas-SWE-9:" ; Spam - "X-Info:" ; NTMail - "X-Juno-" ; Juno - "X-List-Host:" ; Unknown mailing list managers - "X-List-Subscribe:" ; Unknown mailing list managers - "X-List-Unsubscribe:" ; Unknown mailing list managers - "X-Listprocessor-" ; ListProc(tm) by CREN - "X-Listserver:" ; Unknown mailing list managers - "X-Loop:" ; Unknown mailing list managers - "X-Lumos-SenderID:" ; Roving ConstantContact - "X-MAIL-INFO:" ; NetZero - "X-MHE-Checksum" ; Checksum added during index search - "X-MIME-Autoconverted:" ; sendmail - "X-MIMETrack:" - "X-MS-" ; MS Outlook - "X-MailScanner" ; ListProc(tm) by CREN - "X-Mailing-List:" ; Unknown mailing list managers - "X-Mailman-Version:" ; Mailman mailing list manager - "X-Majordomo:" ; Majordomo mailing list manager - "X-Message-Id" - "X-MessageWall-Score:" ; Unknown mailing list manager, AUC TeX - "X-MimeOLE:" ; MS Outlook - "X-Mms-" ; T-Mobile pictures - "X-Mozilla-Status:" ; Netscape/Mozilla - "X-Msmail-" ; MS Outlook - "X-NAI-Spam-" ; Network Associates Inc. SpamKiller - "X-News:" ; News - "X-No-Archive:" - "X-Notes-Item:" ; Lotus Notes Domino structured header - "X-OperatingSystem:" - ;;"X-Operator:" ; Similar to X-Mailer, so display it - "X-Orcl-Content-Type:" - "X-Original-Complaints-To:" - "X-Original-Date:" ; SourceForge mailing list manager - "X-Original-To:" - "X-Original-Trace:" - "X-OriginalArrivalTime:" ; Hotmail - "X-Originating-IP:" ; Hotmail - "X-Postfilter:" - "X-Priority:" ; MS Outlook - "X-Qotd-" ; User added - "X-RM" - "X-Received-Date:" - "X-Received:" - "X-Request-" - "X-Return-Path-Hint:" ; Roving ConstantContact - "X-Roving-*" ; Roving ConstantContact - "X-SBClass:" ; Spam - "X-SBNote:" ; Spam - "X-SBPass:" ; Spam - "X-SBRule:" ; Spam - "X-SMTP-" - "X-Scanned-By" - "X-Sender:" - "X-Server-Date:" - "X-Server-Uuid:" - "X-Sieve:" ; Sieve filtering - "X-Source" - "X-Spam-" ; Spamassassin - "X-SpamBouncer:" ; Spam - "X-Status" - "X-Submissions-To:" - "X-Telecom-Digest" - "X-Trace:" - "X-UID" - "X-UIDL:" - "X-UNTD-" ; NetZero - "X-USANET-" ; usa.net - "X-UserInfo1:" - "X-VSMLoop:" ; NTMail - "X-Virus-Scanned" ; amavisd-new - "X-Vms-To:" - "X-WebTV-Signature:" - "X-Wss-Id:" ; Worldtalk gateways - "X-Yahoo" - "X-eGroups-" ; Egroups/yahoogroups mailing list manager - "X-pgp:" - "X-submission-address:" - "X400-" ; X400 - "Xref:") - "List of default header fields that are not to be shown. - -Do not alter this variable directly. Instead, add entries from -here that you would like to be displayed in -`mh-invisible-header-fields-default' and add entries to hide in -`mh-invisible-header-fields'.") - -(defvar mh-invisible-header-fields-compiled nil - "*Regexp matching lines in a message header that are not to be shown. -Do not alter this variable directly. Instead, customize -`mh-invisible-header-fields-default' checking for fields normally -hidden that you wish to display, and add extra entries to hide in -`mh-invisible-header-fields'.") - -;; Forward definition. -(defvar mh-invisible-header-fields) -(defvar mh-invisible-header-fields-default nil) - -(defun mh-invisible-headers () - "Make or remake the variable `mh-invisible-header-fields-compiled'. -Done using `mh-invisible-header-fields-internal' as input, from -which entries from `mh-invisible-header-fields-default' are -removed and entries from `mh-invisible-header-fields' are added." - (let ((fields mh-invisible-header-fields-internal)) - (when mh-invisible-header-fields-default - ;; Remove entries from `mh-invisible-header-fields-default' - (setq fields - (loop for x in fields - unless (member x mh-invisible-header-fields-default) - collect x))) - (when (and (boundp 'mh-invisible-header-fields) - mh-invisible-header-fields) - (dolist (x mh-invisible-header-fields) - (unless (member x fields) (setq fields (cons x fields))))) - (if fields - (setq mh-invisible-header-fields-compiled - (concat - "^" - ;; workaround for insufficient default - (let ((max-specpdl-size 1000)) - (regexp-opt fields t)))) - (setq mh-invisible-header-fields-compiled nil)))) - -(defcustom mh-invisible-header-fields nil - "*Additional header fields to hide. - -Header fields that you would like to hide that aren't listed in -`mh-invisible-header-fields-default' can be added to this option -with a couple of caveats. Regular expressions are not allowed. -Unique fields should have a \":\" suffix; otherwise, the element -can be used to render invisible an entire class of fields that -start with the same prefix. If you think a header field should be -generally ignored, report a bug (see URL -`https://sourceforge.net/tracker/?group_id=13357&atid=113357'). - -See also `mh-clean-message-header-flag'." - - :type '(repeat (string :tag "Header field")) - :set (lambda (symbol value) - (set-default symbol value) - (mh-invisible-headers)) - :group 'mh-show) - -;; Update forward definition above if default changes. -(defcustom mh-invisible-header-fields-default nil - "*List of hidden header fields. - -The header fields listed in this option are hidden, although you -can check off any field that you would like to see. - -Header fields that you would like to hide that aren't listed can -be added to the option `mh-invisible-header-fields'. - -See also `mh-clean-message-header-flag'." - :type `(set ,@(mapcar (lambda (x) `(const ,x)) - mh-invisible-header-fields-internal)) - :set (lambda (symbol value) - (set-default symbol value) - (mh-invisible-headers)) - :group 'mh-show) - -(defcustom mh-lpr-command-format "lpr -J '%s'" - "*Command used to print\\<mh-folder-mode-map>. - -This option contains the Unix command line which performs the -actual printing for the \\[mh-print-msg] command. The string can -contain one escape, \"%s\", which is replaced by the name of the -folder and the message number and is useful for print job names. -I use \"mpage -h'%s' -b Letter -H1of -mlrtb -P\" which produces a -nice header and adds a bit of margin so the text fits within my -printer's margins. - -This options is not used by the commands \\[mh-ps-print-msg] or -\\[mh-ps-print-msg-file]." - :type 'string - :group 'mh-show) - -(defcustom mh-max-inline-image-height nil - "*Maximum inline image height if \"Content-Disposition:\" is not present. - -Some older mail programs do not insert this needed plumbing to -tell MH-E whether to display the attachments inline or not. If -this is the case, MH-E will display these images inline if they -are smaller than the window. However, you might want to allow -larger images to be displayed inline. To do this, you can change -the options `mh-max-inline-image-width' and -`mh-max-inline-image-height' from their default value of zero to -a large number. The size of your screen is a good choice for -these numbers." - :type '(choice (const nil) integer) - :group 'mh-show) - -(defcustom mh-max-inline-image-width nil - "*Maximum inline image width if \"Content-Disposition:\" is not present. - -Some older mail programs do not insert this needed plumbing to -tell MH-E whether to display the attachments inline or not. If -this is the case, MH-E will display these images inline if they -are smaller than the window. However, you might want to allow -larger images to be displayed inline. To do this, you can change -the options `mh-max-inline-image-width' and -`mh-max-inline-image-height' from their default value of zero to -a large number. The size of your screen is a good choice for -these numbers." - :type '(choice (const nil) integer) - :group 'mh-show) - -(defcustom mh-mhl-format-file nil - "*Specifies the format file to pass to the \"mhl\" program. - -Normally MH-E takes care of displaying messages itself (rather than -calling an MH program to do the work). If you'd rather have \"mhl\" -display the message (within MH-E), change this option from its default -value of \"Use Default mhl Format (Printing Only)\". - -You can set this option to \"Use Default mhl Format\" to get the same -output as you would get if you ran \"mhl\" from the shell. - -If you have a format file that you want MH-E to use, you can set this -option to \"Specify an mhl Format File\" and enter the name of your -format file. Your format file should specify a non-zero value for -\"overflowoffset\" to allow MH-E to parse the header. Note that -\"mhl\" is always used for printing and forwarding; in this case, the -value of this option is consulted if you have specified a format -file." - :type '(choice (const :tag "Use Default mhl Format (Printing Only)" nil) - (const :tag "Use Default mhl Format" t) - (file :tag "Specify an mhl Format File")) - :group 'mh-show) - -(defcustom mh-mime-save-parts-default-directory t - "Default directory to use for \\<mh-folder-mode-map>\\[mh-mime-save-parts]. - -The default value for this option is \"Prompt Always\" so that -you are always prompted for the directory in which to save the -attachments. However, if you usually use the same directory -within a session, then you can set this option to \"Prompt the -First Time\" to avoid the prompt each time. you can make this -directory permanent by choosing \"Directory\" and entering the -directory's name." - :type '(choice (const :tag "Prompt the First Time" nil) - (const :tag "Prompt Always" t) - directory) - :group 'mh-show) - -(defcustom mh-print-background-flag nil - "*Non-nil means messages should be printed in the background\\<mh-folder-mode-map>. - -Normally messages are printed in the foreground. If this is slow on -your system, you may elect to turn off this option to print in the -background. - -WARNING: If you do this, do not delete the message until it is printed -or else the output may be truncated. - -This option is not used by the commands \\[mh-ps-print-msg] or -\\[mh-ps-print-msg-file]." - :type 'boolean - :group 'mh-show) - -(defcustom mh-show-maximum-size 0 - "*Maximum size of message (in bytes) to display automatically. - -This option provides an opportunity to skip over large messages -which may be slow to load. The default value of 0 means that all -message are shown regardless of size." - :type 'integer - :group 'mh-show) - -(defcustom mh-show-use-goto-addr-flag (and (boundp 'goto-address-highlight-p) - goto-address-highlight-p) - "*Non-nil means highlight URLs and email addresses\\<goto-address-highlight-keymap>. - -To send a message using the highlighted email address or to view -the web page for the highlighted URL, use the middle mouse button -or \\[goto-address-at-point]. - -See Info node `(mh-e)Sending Mail' to see how to configure Emacs -to send the message using MH-E. - -The default value of this option comes from the value of -`goto-address-highlight-p'." - :type 'boolean - :group 'mh-show) - -(defcustom mh-show-use-xface-flag (>= emacs-major-version 21) - "*Non-nil means display face images in MH-show buffers. - -MH-E can display the content of \"Face:\", \"X-Face:\", and -\"X-Image-URL:\" header fields. If any of these fields occur in the -header of your message, the sender's face will appear in the \"From:\" -header field. If more than one of these fields appear, then the first -field found in the order \"Face:\", \"X-Face:\", and \"X-Image-URL:\" -will be used. - -The option `mh-show-use-xface-flag' is used to turn this feature on -and off. This feature will be turned on by default if your system -supports it. - -The first header field used, if present, is the Gnus-specific -\"Face:\" field. The \"Face:\" field appeared in GNU Emacs 21 and -XEmacs. For more information, see URL -`http://quimby.gnus.org/circus/face/'. Next is the traditional -\"X-Face:\" header field. The display of this field requires the -\"uncompface\" program (see URL -`ftp://ftp.cs.indiana.edu/pub/faces/compface/compface.tar.z'). Recent -versions of XEmacs have internal support for \"X-Face:\" images. If -your version of XEmacs does not, then you'll need both \"uncompface\" -and the x-face package (see URL `ftp://ftp.jpl.org/pub/elisp/'). - -Finally, MH-E will display images referenced by the \"X-Image-URL:\" -header field if neither the \"Face:\" nor the \"X-Face:\" fields are -present. The display of the images requires \"wget\" (see URL -`http://www.gnu.org/software/wget/wget.html'), \"fetch\", or \"curl\" -to fetch the image and the \"convert\" program from the ImageMagick -suite (see URL `http://www.imagemagick.org/'). Of the three header -fields this is the most efficient in terms of network usage since the -image doesn't need to be transmitted with every single mail. - -The option `mh-fetch-x-image-url' controls the fetching of the -\"X-Image-URL:\" header field image." - :type 'boolean - :group 'mh-show) - -(defcustom mh-store-default-directory nil - "*Default directory for \\<mh-folder-mode-map>\\[mh-store-msg]. - -If you would like to change the initial default directory, -customize this option, change the value from \"Current\" to -\"Directory\", and then enter the name of the directory for storing -the content of these messages." - :type '(choice (const :tag "Current" nil) - directory) - :group 'mh-show) - -(defcustom mh-summary-height nil - "*Number of lines in MH-Folder buffer (including the mode line). - -The default value of this option is \"Automatic\" which means -that the MH-Folder buffer will maintain the same proportional -size if the frame is resized. If you'd prefer a fixed height, -then choose the \"Fixed Size\" option and enter the number of -lines you'd like to see." - :type '(choice (const :tag "Automatic" nil) - (integer :tag "Fixed Size")) - :group 'mh-show) - - - -;;; The Speedbar (:group 'mh-speedbar) - -(defcustom mh-speed-update-interval 60 - "Time between speedbar updates in seconds. -Set to 0 to disable automatic update." - :type 'integer - :group 'mh-speedbar) - - - -;;; Threading (:group 'mh-thread) - -(defcustom mh-show-threads-flag nil - "*Non-nil means new folders start in threaded mode. - -Threading large number of messages can be time consuming so this -option is turned off by default. If you turn this option on, then -threading will be done only if the number of messages being -threaded is less than `mh-large-folder'." - :type 'boolean - :group 'mh-thread) - - - -;;; The Tool Bar (:group 'mh-tool-bar) - -(defcustom mh-tool-bar-search-function 'mh-search - "*Function called by the tool bar search button. - -By default, this is set to `mh-search'. You can also choose -\"Other Function\" from the \"Value Menu\" and enter a function -of your own choosing." - :type '(choice (const mh-search) - (function :tag "Other Function")) - :group 'mh-tool-bar) - -;; Functions called from the tool bar -(defun mh-tool-bar-search (&optional arg) - "Interactively call `mh-tool-bar-search-function'. -Optional argument ARG is not used." - (interactive "P") - (call-interactively mh-tool-bar-search-function)) - -(defun mh-tool-bar-customize () - "Call `mh-customize' from the tool bar." - (interactive) - (mh-customize t)) - -(defun mh-tool-bar-folder-help () - "Visit \"(mh-e)Top\"." - (interactive) - (info "(mh-e)Top") - (delete-other-windows)) - -(defun mh-tool-bar-letter-help () - "Visit \"(mh-e)Editing Drafts\"." - (interactive) - (info "(mh-e)Editing Drafts") - (delete-other-windows)) - -(defmacro mh-tool-bar-reply-generator (function recipient folder-buffer-flag) - "Generate FUNCTION that replies to RECIPIENT. -If FOLDER-BUFFER-FLAG is nil then the function generated... -When INCLUDE-FLAG is non-nil, include message body being replied to." - `(defun ,function (&optional arg) - ,(format "Reply to \"%s\".\nWhen ARG is non-nil include message in reply." - recipient) - (interactive "P") - ,(if folder-buffer-flag nil '(set-buffer mh-show-folder-buffer)) - (mh-reply (mh-get-msg-num nil) ,recipient arg))) - -(mh-tool-bar-reply-generator mh-tool-bar-reply-from "from" t) -(mh-tool-bar-reply-generator mh-show-tool-bar-reply-from "from" nil) -(mh-tool-bar-reply-generator mh-tool-bar-reply-to "to" t) -(mh-tool-bar-reply-generator mh-show-tool-bar-reply-to "to" nil) -(mh-tool-bar-reply-generator mh-tool-bar-reply-all "all" t) -(mh-tool-bar-reply-generator mh-show-tool-bar-reply-all "all" nil) - -;; XEmacs has a couple of extra customizations... -(mh-do-in-xemacs - (defcustom mh-xemacs-use-tool-bar-flag mh-xemacs-has-tool-bar-flag - "*If non-nil, use tool bar. - -This option controls whether to show the MH-E icons at all. By -default, this option is turned on if the window system supports -tool bars. If your system doesn't support tool bars, then you -won't be able to turn on this option." - :type 'boolean - :group 'mh-tool-bar - :set (lambda (symbol value) - (if (and (eq value t) - (not mh-xemacs-has-tool-bar-flag)) - (error "Tool bar not supported")) - (set-default symbol value))) - - (defcustom mh-xemacs-tool-bar-position nil - "*Tool bar location. - -This option controls the placement of the tool bar along the four -edges of the frame. You can choose from one of \"Same As Default -Tool Bar\", \"Top\", \"Bottom\", \"Left\", or \"Right\". If this -variable is set to anything other than \"Same As Default Tool -Bar\" and the default tool bar is in a different location, then -two tool bars will be displayed: the MH-E tool bar and the -default tool bar." - :type '(radio (const :tag "Same As Default Tool Bar" :value nil) - (const :tag "Top" :value top) - (const :tag "Bottom" :value bottom) - (const :tag "Left" :value left) - (const :tag "Right" :value right)) - :group 'mh-tool-bar)) - -(defun mh-buffer-exists-p (mode) - "Test whether a buffer with major mode MODE is present." - (loop for buf in (buffer-list) - when (save-excursion - (set-buffer buf) - (eq major-mode mode)) - return t)) - -(defmacro mh-tool-bar-define (defaults &rest buttons) - "Define a tool bar for MH-E. -DEFAULTS is the list of buttons that are present by default. It -is a list of lists where the sublists are of the following form: - - (:KEYWORD FUNC1 FUNC2 FUNC3 ...) - -Here :KEYWORD is one of :folder or :letter. If it is :folder then -the default buttons in the folder and show mode buffers are being -specified. If it is :letter then the default buttons in the -letter mode are listed. FUNC1, FUNC2, FUNC3, ... are the names of -the functions that the buttons would execute. - -Each element of BUTTONS is a list consisting of four mandatory -items and one optional item as follows: - - (FUNCTION MODES ICON DOC &optional ENABLE-EXPR) - -where, - - FUNCTION is the name of the function that will be executed when - the button is clicked. - - MODES is a list of symbols. List elements must be from \"folder\", - \"letter\" and \"sequence\". If \"folder\" is present then the button is - available in the folder and show buffer. If the name of FUNCTION is - of the form \"mh-foo\", where foo is some arbitrary string, then we - check if the function `mh-show-foo' exists. If it exists then that - function is used in the show buffer. Otherwise the original function - `mh-foo' is used in the show buffer as well. Presence of \"sequence\" - is handled similar to the above. The only difference is that the - button is shown only when the folder is narrowed to a sequence. If - \"letter\" is present in MODES, then the button is available during - draft editing and runs FUNCTION when clicked. - - ICON is the icon that is drawn in the button. - - DOC is the documentation for the button. It is used in tool-tips and - in providing other help to the user. GNU Emacs uses only the first - line of the string. So the DOC should be formatted such that the - first line is useful and complete without the rest of the string. - - Optional item ENABLE-EXPR is an arbitrary lisp expression. If it - evaluates to nil, then the button is deactivated, otherwise it is - active. If it isn't present then the button is always active." - ;; The following variable names have been carefully chosen to make code - ;; generation easier. Modifying the names should be done carefully. - (let (folder-buttons folder-docs folder-button-setter sequence-button-setter - show-buttons show-button-setter show-seq-button-setter - letter-buttons letter-docs letter-button-setter - folder-defaults letter-defaults - folder-vectors show-vectors letter-vectors) - (dolist (x defaults) - (cond ((eq (car x) :folder) (setq folder-defaults (cdr x))) - ((eq (car x) :letter) (setq letter-defaults (cdr x))))) - (dolist (button buttons) - (unless (and (listp button) - (or (equal (length button) 4) (equal (length button) 5))) - (error "Incorrect MH-E tool-bar button specification: %s" button)) - (let* ((name (nth 0 button)) - (name-str (symbol-name name)) - (icon (nth 2 button)) - (xemacs-icon (mh-do-in-xemacs - (cdr (assoc (intern icon) mh-xemacs-icon-map)))) - (full-doc (nth 3 button)) - (doc (if (string-match "\\(.*\\)\n" full-doc) - (match-string 1 full-doc) - full-doc)) - (enable-expr (or (nth 4 button) t)) - (modes (nth 1 button)) - functions show-sym) - (when (memq 'letter modes) (setq functions `(:letter ,name))) - (when (or (memq 'folder modes) (memq 'sequence modes)) - (setq functions - (append `(,(if (memq 'folder modes) :folder :sequence) ,name) - functions)) - (setq show-sym - (if (string-match "^mh-\\(.*\\)$" name-str) - (intern (concat "mh-show-" (match-string 1 name-str))) - name)) - (setq functions - (append `(,(if (memq 'folder modes) :show :show-seq) - ,(if (fboundp show-sym) show-sym name)) - functions))) - (do ((functions functions (cddr functions))) - ((null functions)) - (let* ((type (car functions)) - (function (cadr functions)) - (type1 (substring (symbol-name type) 1)) - (vector-list (cond ((eq type :show) 'show-vectors) - ((eq type :show-seq) 'show-vectors) - ((eq type :letter) 'letter-vectors) - (t 'folder-vectors))) - (list (cond ((eq type :letter) 'mh-tool-bar-letter-buttons) - (t 'mh-tool-bar-folder-buttons))) - (key (intern (concat "mh-" type1 "tool-bar-" name-str))) - (setter (intern (concat type1 "-button-setter"))) - (mbuttons (cond ((eq type :letter) 'letter-buttons) - ((eq type :show) 'show-buttons) - ((eq type :show-seq) 'show-buttons) - (t 'folder-buttons))) - (docs (cond ((eq mbuttons 'letter-buttons) 'letter-docs) - ((eq mbuttons 'folder-buttons) 'folder-docs)))) - (add-to-list vector-list `[,xemacs-icon ,function t ,full-doc]) - (add-to-list - setter `(when (member ',name ,list) - (mh-funcall-if-exists - tool-bar-add-item ,icon ',function ',key - :help ,doc :enable ',enable-expr))) - (add-to-list mbuttons name) - (if docs (add-to-list docs doc)))))) - (setq folder-buttons (nreverse folder-buttons) - letter-buttons (nreverse letter-buttons) - show-buttons (nreverse show-buttons) - letter-docs (nreverse letter-docs) - folder-docs (nreverse folder-docs) - folder-vectors (nreverse folder-vectors) - show-vectors (nreverse show-vectors) - letter-vectors (nreverse letter-vectors)) - (dolist (x folder-defaults) - (unless (memq x folder-buttons) - (error "Folder defaults contains unknown button '%s'" x))) - (dolist (x letter-defaults) - (unless (memq x letter-buttons) - (error "Letter defaults contains unknown button '%s'" x))) - `(eval-when (compile load eval) - (defvar mh-folder-tool-bar-map nil) - (defvar mh-folder-seq-tool-bar-map nil) - (defvar mh-show-tool-bar-map nil) - (defvar mh-show-seq-tool-bar-map nil) - (defvar mh-letter-tool-bar-map nil) - ;; GNU Emacs tool bar specific code - (mh-do-in-gnu-emacs - ;; Tool bar initialization functions - (defun mh-tool-bar-folder-buttons-init () - (when (mh-buffer-exists-p 'mh-folder-mode) - (mh-image-load-path) - (setq mh-folder-tool-bar-map - (let ((tool-bar-map (make-sparse-keymap))) - ,@(nreverse folder-button-setter) - tool-bar-map)) - (setq mh-show-tool-bar-map - (let ((tool-bar-map (make-sparse-keymap))) - ,@(nreverse show-button-setter) - tool-bar-map)) - (setq mh-show-seq-tool-bar-map - (let ((tool-bar-map (copy-keymap mh-show-tool-bar-map))) - ,@(nreverse show-seq-button-setter) - tool-bar-map)) - (setq mh-folder-seq-tool-bar-map - (let ((tool-bar-map (copy-keymap mh-folder-tool-bar-map))) - ,@(nreverse sequence-button-setter) - tool-bar-map)))) - (defun mh-tool-bar-letter-buttons-init () - (when (mh-buffer-exists-p 'mh-letter-mode) - (mh-image-load-path) - (setq mh-letter-tool-bar-map - (let ((tool-bar-map (make-sparse-keymap))) - ,@(nreverse letter-button-setter) - tool-bar-map)))) - ;; Custom setter functions - (defun mh-tool-bar-folder-buttons-set (symbol value) - "Construct tool bar for `mh-folder-mode' and `mh-show-mode'." - (set-default symbol value) - (mh-tool-bar-folder-buttons-init)) - (defun mh-tool-bar-letter-buttons-set (symbol value) - "Construct tool bar for `mh-letter-mode'." - (set-default symbol value) - (mh-tool-bar-letter-buttons-init))) - ;; XEmacs specific code - (mh-do-in-xemacs - (defvar mh-tool-bar-folder-vector-map - ',(loop for button in folder-buttons - for vector in folder-vectors - collect (cons button vector))) - (defvar mh-tool-bar-show-vector-map - ',(loop for button in show-buttons - for vector in show-vectors - collect (cons button vector))) - (defvar mh-tool-bar-letter-vector-map - ',(loop for button in letter-buttons - for vector in letter-vectors - collect (cons button vector))) - (defvar mh-tool-bar-folder-buttons nil) - (defvar mh-tool-bar-show-buttons nil) - (defvar mh-tool-bar-letter-buttons nil) - ;; Custom setter functions - (defun mh-tool-bar-letter-buttons-set (symbol value) - (set-default symbol value) - (when mh-xemacs-has-tool-bar-flag - (setq mh-tool-bar-letter-buttons - (loop for b in value - collect (cdr (assoc b mh-tool-bar-letter-vector-map)))))) - (defun mh-tool-bar-folder-buttons-set (symbol value) - (set-default symbol value) - (when mh-xemacs-has-tool-bar-flag - (setq mh-tool-bar-folder-buttons - (loop for b in value - collect (cdr (assoc b mh-tool-bar-folder-vector-map)))) - (setq mh-tool-bar-show-buttons - (loop for b in value - collect (cdr (assoc b mh-tool-bar-show-vector-map)))))) - (defun mh-tool-bar-init (mode) - "Install tool bar in MODE." - (let ((tool-bar (cond ((eq mode :folder) mh-tool-bar-folder-buttons) - ((eq mode :letter) mh-tool-bar-letter-buttons) - ((eq mode :show) mh-tool-bar-show-buttons))) - (height 37) - (width 40) - (buffer (current-buffer))) - (when mh-xemacs-use-tool-bar-flag - (cond - ((eq mh-xemacs-tool-bar-position 'top) - (set-specifier top-toolbar tool-bar buffer) - (set-specifier top-toolbar-visible-p t) - (set-specifier top-toolbar-height height)) - ((eq mh-xemacs-tool-bar-position 'bottom) - (set-specifier bottom-toolbar tool-bar buffer) - (set-specifier bottom-toolbar-visible-p t) - (set-specifier bottom-toolbar-height height)) - ((eq mh-xemacs-tool-bar-position 'left) - (set-specifier left-toolbar tool-bar buffer) - (set-specifier left-toolbar-visible-p t) - (set-specifier left-toolbar-width width)) - ((eq mh-xemacs-tool-bar-position 'right) - (set-specifier right-toolbar tool-bar buffer) - (set-specifier right-toolbar-visible-p t) - (set-specifier right-toolbar-width width)) - (t (set-specifier default-toolbar tool-bar buffer))))))) - ;; Declare customizable tool bars - (custom-declare-variable - 'mh-tool-bar-folder-buttons - '(list ,@(mapcar (lambda (x) `(quote ,x)) folder-defaults)) - "List of buttons to include in MH-Folder tool bar." - :group 'mh-tool-bar :set 'mh-tool-bar-folder-buttons-set - :type '(set ,@(loop for x in folder-buttons - for y in folder-docs - collect `(const :tag ,y ,x)))) - (custom-declare-variable - 'mh-tool-bar-letter-buttons - '(list ,@(mapcar (lambda (x) `(quote ,x)) letter-defaults)) - "List of buttons to include in MH-Letter tool bar." - :group 'mh-tool-bar :set 'mh-tool-bar-letter-buttons-set - :type '(set ,@(loop for x in letter-buttons - for y in letter-docs - collect `(const :tag ,y ,x))))))) - -(mh-tool-bar-define - ((:folder mh-inc-folder mh-mime-save-parts mh-previous-undeleted-msg - mh-page-msg mh-next-undeleted-msg mh-delete-msg mh-refile-msg - mh-undo mh-execute-commands mh-toggle-tick mh-reply - mh-alias-grab-from-field mh-send mh-rescan-folder - mh-tool-bar-search mh-visit-folder - mh-tool-bar-customize mh-tool-bar-folder-help mh-widen) - (:letter mh-send-letter mh-compose-insertion ispell-message save-buffer - undo kill-region menu-bar-kill-ring-save yank mh-fully-kill-draft - mh-tool-bar-customize mh-tool-bar-letter-help)) - ;; Folder/Show buffer buttons - (mh-inc-folder (folder) "mail" - "Incorporate new mail in Inbox -This button runs `mh-inc-folder' which drags any -new mail into your Inbox folder.") - (mh-mime-save-parts (folder) "attach" - "Save MIME parts from this message -This button runs `mh-mime-save-parts' which saves a message's -different parts into separate files.") - (mh-previous-undeleted-msg (folder) "left-arrow" - "Go to the previous undeleted message -This button runs `mh-previous-undeleted-msg'") - (mh-page-msg (folder) "page-down" - "Page the current message forwards\nThis button runs `mh-page-msg'") - (mh-next-undeleted-msg (folder) "right-arrow" - "Go to the next undeleted message\nThe button runs `mh-next-undeleted-msg'") - (mh-delete-msg (folder) "close" - "Mark this message for deletion\nThis button runs `mh-delete-msg'") - (mh-refile-msg (folder) "mail/refile" - "Refile this message\nThis button runs `mh-refile-msg'") - (mh-undo (folder) "undo" "Undo last operation\nThis button runs `undo'" - (mh-outstanding-commands-p)) - (mh-execute-commands (folder) "execute" - "Perform moves and deletes\nThis button runs `mh-execute-commands'" - (mh-outstanding-commands-p)) - (mh-toggle-tick (folder) "highlight" - "Toggle tick mark\nThis button runs `mh-toggle-tick'") - (mh-toggle-showing (folder) "show" - "Toggle showing message\nThis button runs `mh-toggle-showing'") - (mh-tool-bar-reply-from (folder) "mail/reply-from" "Reply to \"from\"") - (mh-tool-bar-reply-to (folder) "mail/reply-to" "Reply to \"to\"") - (mh-tool-bar-reply-all (folder) "mail/reply-all" "Reply to \"all\"") - (mh-reply (folder) "mail/reply" - "Reply to this message\nThis button runs `mh-reply'") - (mh-alias-grab-from-field (folder) "mail/alias" - "Grab From alias\nThis button runs `mh-alias-grab-from-field'" - (and (mh-extract-from-header-value) (not (mh-alias-for-from-p)))) - (mh-send (folder) "mail/compose" - "Compose new message\nThis button runs `mh-send'") - (mh-rescan-folder (folder) "refresh" - "Rescan this folder\nThis button runs `mh-rescan-folder'") - (mh-pack-folder (folder) "mail/repack" - "Repack this folder\nThis button runs `mh-pack-folder'") - (mh-tool-bar-search (folder) "search" - "Search\nThis button runs `mh-tool-bar-search-function'") - (mh-visit-folder (folder) "fld-open" - "Visit other folder\nThis button runs `mh-visit-folder'") - ;; Letter buffer buttons - (mh-send-letter (letter) "mail/send" "Send this letter") - (mh-compose-insertion (letter) "attach" "Insert attachment") - (ispell-message (letter) "spell" "Check spelling") - (save-buffer (letter) "save" "Save current buffer to its file" - (buffer-modified-p)) - (undo (letter) "undo" "Undo last operation") - (kill-region (letter) "cut" - "Cut (kill) text in region between mark and current position") - (menu-bar-kill-ring-save (letter) "copy" - "Copy text in region between mark and current position") - (yank (letter) "paste" "Paste (yank) text cut or copied earlier") - (mh-fully-kill-draft (letter) "close" "Kill this draft") - ;; Common buttons - (mh-tool-bar-customize (folder letter) "preferences" "MH-E Preferences") - (mh-tool-bar-folder-help (folder) "help" - "Help! (general help)\nThis button runs `info'") - (mh-tool-bar-letter-help (letter) "help" - "Help! (general help)\nThis button runs `info'") - ;; Folder narrowed to sequence buttons - (mh-widen (sequence) "widen" - "Widen from the sequence\nThis button runs `mh-widen'")) - - - -;;; Hooks (:group 'mh-hooks + group where hook described) - -(defcustom mh-after-commands-processed-hook nil - "Hook run by \\<mh-folder-mode-map>\\[mh-execute-commands] after performing outstanding requests. - -Variables that are useful in this hook include -`mh-folders-changed', which lists which folders were affected by -deletes and refiles. This list will always include the current -folder, which is also available in `mh-current-folder'." - :type 'hook - :group 'mh-hooks - :group 'mh-folder) - -(defcustom mh-alias-reloaded-hook nil - "Hook run by `mh-alias-reload' after loading aliases." - :type 'hook - :group 'mh-hooks - :group 'mh-alias) - -(defcustom mh-before-commands-processed-hook nil - "Hook run by \\<mh-folder-mode-map>\\[mh-execute-commands] before performing outstanding requests. - -Variables that are useful in this hook include `mh-delete-list' -and `mh-refile-list' which can be used to see which changes will -be made to the current folder, `mh-current-folder'." - :type 'hook - :group 'mh-hooks - :group 'mh-folder) - -(defcustom mh-before-quit-hook nil - "Hook run by \\<mh-folder-mode-map>\\[mh-quit] before quitting MH-E. - -This hook is called before the quit occurs, so you might use it -to perform any MH-E operations; you could perform some query and -abort the quit or call `mh-execute-commands', for example. - -See also `mh-quit-hook'." - :type 'hook - :group 'mh-hooks - :group 'mh-folder) - -(defcustom mh-before-send-letter-hook nil - "Hook run at the beginning of the \\<mh-letter-mode-map>\\[mh-send-letter] command. - -For example, if you want to check your spelling in your message -before sending, add the `ispell-message' function." - :type 'hook - :options '(ispell-message) - :group 'mh-hooks - :group 'mh-letter) - -(defcustom mh-delete-msg-hook nil - "Hook run by \\<mh-letter-mode-map>\\[mh-delete-msg] after marking each message for deletion. - -For example, a past maintainer of MH-E used this once when he -kept statistics on his mail usage." - :type 'hook - :group 'mh-hooks - :group 'mh-show) - -(defcustom mh-find-path-hook nil - "Hook run by `mh-find-path' after reading the user's MH profile. - -This hook can be used the change the value of the variables that -`mh-find-path' sets if you need to run with different values -between MH and MH-E." - :type 'hook - :group 'mh-hooks - :group 'mh-e) - -(defcustom mh-folder-mode-hook nil - "Hook run by `mh-folder-mode' when visiting a new folder." - :type 'hook - :group 'mh-hooks - :group 'mh-folder) - -(defcustom mh-forward-hook nil - "Hook run by `mh-forward' on a forwarded letter." - :type 'hook - :group 'mh-hooks - :group 'mh-sending-mail) - -(defcustom mh-inc-folder-hook nil - "Hook run by \\<mh-folder-mode-map>\\[mh-inc-folder] after incorporating mail into a folder." - :type 'hook - :group 'mh-hooks - :group 'mh-inc) - -(defcustom mh-insert-signature-hook nil - "Hook run by \\<mh-letter-mode-map>\\[mh-insert-signature] after signature has been inserted. - -Hook functions may access the actual name of the file or the -function used to insert the signature with -`mh-signature-file-name'." - :type 'hook - :group 'mh-hooks - :group 'mh-letter) - -(defcustom mh-kill-folder-suppress-prompt-hooks '(mh-search-p) - "Abnormal hook run at the beginning of \\<mh-folder-mode-map>\\[mh-kill-folder]. - -The hook functions are called with no arguments and should return -a non-nil value to suppress the normal prompt when you remove a -folder. This is useful for folders that are easily regenerated. - -The default value of `mh-search-p' suppresses the prompt on -folders generated by searching. - -WARNING: Use this hook with care. If there is a bug in your hook -which returns t on \"+inbox\" and you hit \\[mh-kill-folder] by -accident in the \"+inbox\" folder, you will not be happy." - :type 'hook - :group 'mh-hooks - :group 'mh-folder) - -(defcustom mh-letter-mode-hook nil - "Hook run by `mh-letter-mode' on a new letter. - -This hook allows you to do some processing before editing a -letter. For example, you may wish to modify the header after -\"repl\" has done its work, or you may have a complicated -\"components\" file and need to tell MH-E where the cursor should -go." - :type 'hook - :group 'mh-hooks - :group 'mh-sending-mail) - -(defcustom mh-mh-to-mime-hook nil - "Hook run on the formatted letter by \\<mh-letter-mode-map>\\[mh-mh-to-mime]." - :type 'hook - :group 'mh-hooks - :group 'mh-letter) - -(defcustom mh-search-mode-hook nil - "Hook run upon entry to `mh-search-mode'\\<mh-folder-mode-map>. - -If you find that you do the same thing over and over when editing -the search template, you may wish to bind some shortcuts to keys. -This can be done with this hook which is called when -\\[mh-search] is run on a new pattern." - :type 'hook - :group 'mh-hooks - :group 'mh-search) - -(defcustom mh-quit-hook nil - "Hook run by \\<mh-folder-mode-map>\\[mh-quit] after quitting MH-E. - -This hook is not run in an MH-E context, so you might use it to -modify the window setup. - -See also `mh-before-quit-hook'." - :type 'hook - :group 'mh-hooks - :group 'mh-folder) - -(defcustom mh-refile-msg-hook nil - "Hook run by \\<mh-folder-mode-map>\\[mh-refile-msg] after marking each message for refiling." - :type 'hook - :group 'mh-hooks - :group 'mh-folder) - -(defcustom mh-show-hook nil - "Hook run after \\<mh-folder-mode-map>\\[mh-show] shows a message. - -It is the last thing called after messages are displayed. It's -used to affect the behavior of MH-E in general or when -`mh-show-mode-hook' is too early. See `mh-show-mode-hook'." - :type 'hook - :group 'mh-hooks - :group 'mh-show) - -(defcustom mh-show-mode-hook nil - "Hook run upon entry to `mh-show-mode'. - -This hook is called early on in the process of the message -display. It is usually used to perform some action on the -message's content. See `mh-show-hook'." - :type 'hook - :group 'mh-hooks - :group 'mh-show) - -(defcustom mh-unseen-updated-hook nil - "Hook run after the unseen sequence has been updated. - -The variable `mh-seen-list' can be used by this hook to obtain -the list of messages which were removed from the unseen -sequence." - :type 'hook - :group 'mh-hooks - :group 'mh-sequences) - - - -;;; Faces (:group 'mh-faces + group where faces described) - -(if (boundp 'facemenu-unlisted-faces) - (add-to-list 'facemenu-unlisted-faces "^mh-")) - -(defface mh-folder-address '((t (:inherit mh-folder-subject))) - "Recipient face." - :group 'mh-faces - :group 'mh-folder) - -(defface mh-folder-body - '((((class color)) - (:inherit mh-folder-msg-number)) - (t - (:inherit mh-folder-msg-number :italic t))) - "Body text face." - :group 'mh-faces - :group 'mh-folder) - -(defface mh-folder-cur-msg-number - '((t - (:inherit mh-folder-msg-number :bold t))) - "Current message number face." - :group 'mh-faces - :group 'mh-folder) - -(defface mh-folder-date '((t (:inherit mh-folder-msg-number))) - "Date face." - :group 'mh-faces - :group 'mh-folder) - -(defface mh-folder-deleted '((t (:inherit mh-folder-msg-number))) - "Deleted message face." - :group 'mh-faces - :group 'mh-folder) - -(defface mh-folder-followup - '((((class color) (background light)) - (:foreground "blue3")) - (((class color) (background dark)) - (:foreground "LightGoldenRod")) - (t - (:bold t))) - "\"Re:\" face." - :group 'mh-faces - :group 'mh-folder) - -(defface mh-folder-msg-number - (mh-defface-compat - '((((class color) (min-colors 88) (background light)) - (:foreground "snow4")) - (((class color) (min-colors 88) (background dark)) - (:foreground "snow3")) - (((class color)) - (:foreground "cyan")))) - - "Message number face." - :group 'mh-faces - :group 'mh-folder) - -(defface mh-folder-refiled - (mh-defface-compat - '((((class color) (min-colors 88) (background light)) - (:foreground "DarkGoldenrod")) - (((class color) (min-colors 88) (background dark)) - (:foreground "LightGoldenrod")) - (((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)) - (t - (:bold t :italic t)))) - "Refiled message face." - :group 'mh-faces - :group 'mh-folder) - -(defface mh-folder-sent-to-me-hint '((t (:inherit mh-folder-date))) - "Fontification hint face in messages sent directly to us. -The detection of messages sent to us is governed by the scan -format `mh-scan-format-nmh' and the regular expression -`mh-scan-sent-to-me-sender-regexp'." - :group 'mh-faces - :group 'mh-folder) - -(defface mh-folder-sent-to-me-sender '((t (:inherit mh-folder-followup))) - "Sender face in messages sent directly to us. -The detection of messages sent to us is governed by the scan -format `mh-scan-format-nmh' and the regular expression -`mh-scan-sent-to-me-sender-regexp'." - :group 'mh-faces - :group 'mh-folder) - -(defface mh-folder-subject - '((((class color) (background light)) - (:foreground "blue4")) - (((class color) (background dark)) - (:foreground "yellow")) - (t - (:bold t))) - "Subject face." - :group 'mh-faces - :group 'mh-folder) - -(defface mh-folder-tick - '((((class color) (background dark)) - (:background "#dddf7e")) - (((class color) (background light)) - (:background "#dddf7e")) - (t - (:underline t))) - "Ticked message face." - :group 'mh-faces - :group 'mh-folder) - -(defface mh-folder-to - (mh-defface-compat - '((((class color) (min-colors 88) (background light)) - (:foreground "RosyBrown")) - (((class color) (min-colors 88) (background dark)) - (:foreground "LightSalmon")) - (((class color)) - (:foreground "green")) - (((class grayscale) (background light)) - (:foreground "DimGray" :italic t)) - (((class grayscale) (background dark)) - (:foreground "LightGray" :italic t)) - (t - (:italic t)))) - "\"To:\" face." - :group 'mh-faces - :group 'mh-folder) - -(defface mh-search-folder - '((((class color) (background light)) - (:foreground "dark green" :bold t)) - (((class color) (background dark)) - (:foreground "indian red" :bold t)) - (t - (:bold t))) - "Folder heading face in MH-Folder buffers created by searches." - :group 'mh-faces - :group 'mh-search) - -(defface mh-letter-header-field - '((((class color) (background light)) - (:background "gray90")) - (((class color) (background dark)) - (:background "gray10")) - (t - (:bold t))) - "Editable header field value face in draft buffers." - :group 'mh-faces - :group 'mh-letter) - -(defface mh-show-cc - (mh-defface-compat - '((((class color) (min-colors 88) (background light)) - (:foreground "DarkGoldenrod")) - (((class color) (min-colors 88) (background dark)) - (:foreground "LightGoldenrod")) - (((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)) - (t - (:bold t :italic t)))) - "Face used to highlight \"cc:\" header fields." - :group 'mh-faces - :group 'mh-show) - -(defface mh-show-date - (mh-defface-compat - '((((class color) (min-colors 88) (background light)) - (:foreground "ForestGreen")) - (((class color) (min-colors 88) (background dark)) - (:foreground "PaleGreen")) - (((class color)) - (:foreground "green")) - (((class grayscale) (background light)) - (:foreground "Gray90" :bold t)) - (((class grayscale) (background dark)) - (:foreground "DimGray" :bold t)) - (t - (:bold t :underline t)))) - "Face used to highlight \"Date:\" header fields." - :group 'mh-faces - :group 'mh-show) - -(defface mh-show-from - '((((class color) (background light)) - (:foreground "red3")) - (((class color) (background dark)) - (:foreground "cyan")) - (t - (:bold t))) - "Face used to highlight \"From:\" header fields." - :group 'mh-faces - :group 'mh-show) - -(defface mh-show-header - (mh-defface-compat - '((((class color) (min-colors 88) (background light)) - (:foreground "RosyBrown")) - (((class color) (min-colors 88) (background dark)) - (:foreground "LightSalmon")) - (((class color)) - (:foreground "green")) - (((class grayscale) (background light)) - (:foreground "DimGray" :italic t)) - (((class grayscale) (background dark)) - (:foreground "LightGray" :italic t)) - (t - (:italic t)))) - "Face used to deemphasize less interesting header fields." - :group 'mh-faces - :group 'mh-show) - -(defface mh-show-pgg-bad '((t (:bold t :foreground "DeepPink1"))) - "Bad PGG signature face." - :group 'mh-faces - :group 'mh-show) - -(defface mh-show-pgg-good '((t (:bold t :foreground "LimeGreen"))) - "Good PGG signature face." - :group 'mh-faces - :group 'mh-show) - -(defface mh-show-pgg-unknown '((t (:bold t :foreground "DarkGoldenrod2"))) - "Unknown or untrusted PGG signature face." - :group 'mh-faces - :group 'mh-show) - -(defface mh-show-signature '((t (:italic t))) - "Signature face." - :group 'mh-faces - :group 'mh-show) - -(defface mh-show-subject '((t (:inherit mh-folder-subject))) - "Face used to highlight \"Subject:\" header fields." - :group 'mh-faces - :group 'mh-show) - -(defface mh-show-to - '((((class color) (background light)) - (:foreground "SaddleBrown")) - (((class color) (background dark)) - (:foreground "burlywood")) - (((class grayscale) (background light)) - (:foreground "DimGray" :underline t)) - (((class grayscale) (background dark)) - (:foreground "LightGray" :underline t)) - (t (:underline t))) - "Face used to highlight \"To:\" header fields." - :group 'mh-faces - :group 'mh-show) - -(defface mh-show-xface '((t (:inherit (mh-show-from highlight)))) - "X-Face image face. -The background and foreground are used in the image." - :group 'mh-faces - :group 'mh-show) - -(defface mh-speedbar-folder - '((((class color) (background light)) - (:foreground "blue4")) - (((class color) (background dark)) - (:foreground "light blue"))) - "Basic folder face." - :group 'mh-faces - :group 'mh-speedbar) - -(defface mh-speedbar-folder-with-unseen-messages - '((t - (:inherit mh-speedbar-folder :bold t))) - "Folder face when folder contains unread messages." - :group 'mh-faces - :group 'mh-speedbar) - -(defface mh-speedbar-selected-folder - '((((class color) (background light)) - (:foreground "red1" :underline t)) - (((class color) (background dark)) - (:foreground "red1" :underline t)) - (t - (:underline t))) - "Selected folder face." - :group 'mh-faces - :group 'mh-speedbar) - -(defface mh-speedbar-selected-folder-with-unseen-messages - '((t - (:inherit mh-speedbar-selected-folder :bold t))) - "Selected folder face when folder contains unread messages." - :group 'mh-faces - :group 'mh-speedbar) - -;;; XXX Temporary function for comparing old and new faces. Delete -;;; when everybody is happy. -(defvar bw-face-generation 'new) - -(defun bw-toggle-faces () - "Toggle between old and new faces." - (interactive) - (cond ((eq bw-face-generation 'new) - (message "Going from new to old...") - (bw-new-face-to-old) - (message "Going from new to old...done") - (setq bw-face-generation 'old)) - ((eq bw-face-generation 'old) - (message "Going from old to new...") - (bw-old-face-to-new) - (message "Going from old to new...done") - (setq bw-face-generation 'new)))) - -(defun bw-new-face-to-old () - "Set old faces." - (face-spec-set 'mh-folder-body - (mh-defface-compat - '((((class color) (min-colors 88) (background light)) - (:foreground "RosyBrown")) - (((class color) (min-colors 88) (background dark)) - (:foreground "LightSalmon")) - (((class color)) - (:foreground "green")) - (((class grayscale) (background light)) - (:foreground "DimGray" :italic t)) - (((class grayscale) (background dark)) - (:foreground "LightGray" :italic t)) - (t - (:italic t))))) - - (face-spec-set 'mh-folder-msg-number - '((((class color) (background light)) - (:foreground "snow4")) - (((class color) (background dark)) - (:foreground "snow3")) - (t - (:bold t)))) - - (face-spec-set 'mh-folder-cur-msg-number - (mh-defface-compat - '((((class color) (min-colors 88) (background light)) - (:foreground "Purple")) - (((class color) (min-colors 88) (background dark)) - (:foreground "Cyan")) - (((class color)) - (:foreground "cyan" :weight bold)) - (((class grayscale) (background light)) - (:foreground "LightGray" :bold t)) - (((class grayscale) (background dark)) - (:foreground "DimGray" :bold t)) - (t - (:bold t))))) - - (face-spec-set 'mh-folder-date - '((((class color) (background light)) - (:foreground "snow4")) - (((class color) (background dark)) - (:foreground "snow3")) - (t - (:bold t)))) - - (face-spec-set 'mh-folder-msg-number - '((((class color) (background light)) - (:foreground "snow4")) - (((class color) (background dark)) - (:foreground "snow3")) - (t - (:bold t))))) - -(defun bw-old-face-to-new () - "Set new faces." - (face-spec-set 'mh-folder-body - '((((class color)) - (:inherit mh-folder-msg-number)) - (t - (:inherit mh-folder-msg-number :italic t)))) - - (face-spec-set 'mh-folder-cur-msg-number - '((t - (:inherit mh-folder-msg-number :bold t)))) - - (face-spec-set 'mh-folder-date '((t (:inherit mh-folder-msg-number)))) - - (face-spec-set 'mh-folder-msg-number - '((((class color) (background light)) - (:foreground "snow4")) - (((class color) (background dark)) - (:foreground "snow3")) - (((class color)) - (:foreground "cyan"))))) - -;; Local Variables: -;; indent-tabs-mode: nil -;; sentence-end-double-space: nil -;; End: - -;; arch-tag: 778d2a20-82e2-4276-be9d-309386776a68 -;;; mh-customize.el ends here diff --git a/lisp/mh-e/mh-e.el b/lisp/mh-e/mh-e.el index f92d777309a..3953ddd6c67 100644 --- a/lisp/mh-e/mh-e.el +++ b/lisp/mh-e/mh-e.el @@ -28,16 +28,22 @@ ;;; Commentary: -;; How to Use: +;; How to use: ;; M-x mh-rmail to read mail. Type C-h m there for a list of commands. ;; C-u M-x mh-rmail to visit any folder. -;; M-x mh-smail to send mail. From within the mail reader, "m" works, too. +;; M-x mh-smail to send mail. From within the mail reader, "s" works, too. ;; Your .emacs might benefit from these bindings: ;; (global-set-key "\C-cr" 'mh-rmail) ;; (global-set-key "\C-xm" 'mh-smail) ;; (global-set-key "\C-x4m" 'mh-smail-other-window) +;; If Emacs can't find mh-rmail or mh-smail, add the following to ~/.emacs: +;; (require 'mh-autoloads) + +;; If you want to customize MH-E before explicitly loading it, add this: +;; (require 'mh-cus-load) + ;; MH (Message Handler) is a powerful mail reader. ;; The MH newsgroup is comp.mail.mh; the mailing list is mh-users@ics.uci.edu @@ -59,17 +65,18 @@ ;; mh-e-users@lists.sourceforge.net ;; mh-e-announce@lists.sourceforge.net ;; mh-e-devel@lists.sourceforge.net -;; + ;; Subscribe by sending a "subscribe" message to ;; <list>-request@lists.sourceforge.net, or by using the web interface at ;; https://sourceforge.net/mail/?group_id=13357 ;; Bug Reports: ;; https://sourceforge.net/tracker/?group_id=13357&atid=113357 -;; Include the output of M-x mh-version in any bug report. +;; Include the output of M-x mh-version in the bug report unless +;; you're 110% sure we won't ask for it. ;; Feature Requests: -;; https://sourceforge.net/tracker/?atid=363357&group_id=13357&func=browse +;; https://sourceforge.net/tracker/?group_id=13357&atid=363357 ;; Support: ;; https://sourceforge.net/tracker/?group_id=13357&atid=213357 @@ -85,1236 +92,283 @@ ;;; Code: -;;(message "> mh-e") -(provide 'mh-e) +;; Provide functions to the rest of MH-E. However, mh-e.el must not +;; use any definitions in files that require mh-e from mh-loaddefs, +;; for if it does it will introduce a require loop. +(require 'mh-loaddefs) -(eval-when-compile (require 'mh-acros)) (mh-require-cl) -(require 'easymenu) -(require 'gnus-util) +(eval-and-compile + (defvar mh-xemacs-flag (featurep 'xemacs) + "Non-nil means the current Emacs is XEmacs.")) +(mh-do-in-xemacs + (require 'mh-xemacs)) + (require 'mh-buffers) -(require 'mh-seq) -(require 'mh-utils) -;;(message "< mh-e") +(require 'mh-compat) -(defconst mh-version "7.85+cvs" "Version number of MH-E.") + -(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.") +;;; Global Variables - +;; Try to keep variables local to a single file. Provide accessors if +;; variables are shared. Use this section as a last resort. -;;; Scan Line Formats - -;; 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. - -;; The following scan formats are passed to the scan program if the setting of -;; `mh-scan-format-file' is t. They are identical except the later one makes -;; use of the nmh `decode' function to decode RFC 2047 encodings. If you just -;; want to change the column of the notations, use the `mh-set-cmd-note' -;; function. - -(defvar mh-scan-format-mh - (concat - "%4(msg)" - "%<(cur)+%| %>" - "%<{replied}-" - "%?(nonnull(comp{to}))%<(mymbox{to})t%>" - "%?(nonnull(comp{cc}))%<(mymbox{cc})c%>" - "%?(nonnull(comp{bcc}))%<(mymbox{bcc})b%>" - "%?(nonnull(comp{newsgroups}))n%>" - "%<(zero) %>" - "%02(mon{date})/%02(mday{date})%<{date} %|*%>" - "%<(mymbox{from})%<{to}To:%14(friendly{to})%>%>" - "%<(zero)%17(friendly{from})%> " - "%{subject}%<{body}<<%{body}%>") - "*Scan format string for MH. -This string is passed to the scan program via the -format -argument. This format is identical to the default except that -additional hints for fontification have been added to the fifth -column (remember that in Emacs, the first column is 0). - -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-format-nmh - (concat - "%4(msg)" - "%<(cur)+%| %>" - "%<{replied}-" - "%?(nonnull(comp{to}))%<(mymbox{to})t%>" - "%?(nonnull(comp{cc}))%<(mymbox{cc})c%>" - "%?(nonnull(comp{bcc}))%<(mymbox{bcc})b%>" - "%?(nonnull(comp{newsgroups}))n%>" - "%<(zero) %>" - "%02(mon{date})/%02(mday{date})%<{date} %|*%>" - "%<(mymbox{from})%<{to}To:%14(decode(friendly{to}))%>%>" - "%<(zero)%17(decode(friendly{from}))%> " - "%(decode{subject})%<{body}<<%{body}%>") - "*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 fifth -column (remember that in Emacs, the first column is 0). - -The values of the fifth column, in priority order, are: \"-\" if -the message has been replied to, t if an address on the To: field -matches one of the mailboxes of the current user, \"c\" if the Cc: -field matches, \"b\" if the Bcc: field matches, and \"n\" if a -non-empty Newsgroups: field is present.") - -(defvar mh-note-deleted ?D - "Messages that have been deleted are marked by this character. -See also `mh-scan-deleted-msg-regexp'.") - -(defvar mh-note-refiled ?^ - "Messages that have been refiled are marked by this character. -See also `mh-scan-refiled-msg-regexp'.") - -(defvar mh-note-cur ?+ - "The current message (in MH, not in MH-E) is marked by this character. -See also `mh-scan-cur-msg-number-regexp'.") - -(defvar mh-scan-good-msg-regexp "^\\( *[0-9]+\\)[^D^0-9]" - "This regular expression matches \"good\" messages. - -It must match from the beginning of the line. Note that the -default setting of `mh-folder-font-lock-keywords' expects this -expression to contain at least one parenthesized expression which -matches the message number as in the default of - - \"^\\\\( *[0-9]+\\\\)[^D^0-9]\". - -This expression includes the leading space within the parenthesis -since it looks better to highlight it as well. The highlighting -is done with the face `mh-folder-msg-number'. This regular -expression should be correct as it is needed by non-fontification -functions.") - -(defvar mh-scan-deleted-msg-regexp "^\\( *[0-9]+\\)D" - "This regular expression matches deleted messages. - -It must match from the beginning of the line. Note that the -default setting of `mh-folder-font-lock-keywords' expects this -expression to contain at least one parenthesized expression which -matches the message number as in the default of - - \"^\\\\( *[0-9]+\\\\)D\". - -This expression includes the leading space within the parenthesis -since it looks better to highlight it as well. The highlighting -is done with the face `mh-folder-deleted'. This regular -expression should be correct as it is needed by non-fontification -functions. See also `mh-note-deleted'.") - -(defvar mh-scan-refiled-msg-regexp "^\\( *[0-9]+\\)\\^" - "This regular expression matches refiled messages. - -It must match from the beginning of the line. Note that the -default setting of `mh-folder-font-lock-keywords' expects this -expression to contain at least one parenthesized expression which -matches the message number as in the default of - - \"^\\\\( *[0-9]+\\\\)\\\\^\". - -This expression includes the leading space within the parenthesis -since it looks better to highlight it as well. The highlighting -is done with the face `mh-folder-refiled'. This regular -expression should be correct as it is needed by non-fontification -functions. See also `mh-note-refiled'.") - -(defvar mh-scan-valid-regexp "^ *[0-9]" - "This regular expression describes a valid scan line. - -This is used to eliminate error messages that are occasionally -produced by \"inc\".") - -(defvar mh-scan-cur-msg-number-regexp "^\\( *[0-9]+\\+\\).*" - "This regular expression matches the current message. - -It must match from the beginning of the line. Note that the -default setting of `mh-folder-font-lock-keywords' expects this -expression to contain at least one parenthesized expression which -matches the message number as in the default of - - \"^\\\\( *[0-9]+\\\\+\\\\).*\". - -This expression includes the leading space and current message -marker \"+\" within the parenthesis since it looks better to -highlight these items as well. The highlighting is done with the -face `mh-folder-cur-msg-number'. This regular expression should -be correct as it is needed by non-fontification functions. See -also `mh-note-cur'.") - -(defvar mh-scan-date-regexp "\\([0-9][0-9]/[0-9][0-9]\\)" - "This regular expression matches a valid date. - -It must not be anchored to the beginning or the end of the line. -Note that the default setting of `mh-folder-font-lock-keywords' -expects this expression to contain only one parenthesized -expression which matches the date field as in the default of -\"\\\\([0-9][0-9]/[0-9][0-9]\\\\)\"}. If this regular expression -is not correct, the date will not be highlighted with the face -`mh-folder-date'.") - -(defvar mh-scan-rcpt-regexp "\\(To:\\)\\(..............\\)" - "This regular expression specifies the recipient in messages you sent. - -Note that the default setting of `mh-folder-font-lock-keywords' -expects this expression to contain two parenthesized expressions. -The first is expected to match the \"To:\" that the default scan -format file generates. The second is expected to match the -recipient's name as in the default of -\"\\\\(To:\\\\)\\\\(..............\\\\)\". If this regular -expression is not correct, the \"To:\" string will not be -highlighted with the face `mh-folder-to' and the recipient will -not be highlighted with the face `mh-folder-address'") - -(defvar mh-scan-body-regexp "\\(<<\\([^\n]+\\)?\\)" - "This regular expression matches the message body fragment. - -Note that the default setting of `mh-folder-font-lock-keywords' -expects this expression to contain at least one parenthesized -expression which matches the body text as in the default of -\"\\\\(<<\\\\([^\\n]+\\\\)?\\\\)\". If this regular expression is -not correct, the body fragment will not be highlighted with the -face `mh-folder-body'.") - -(defvar mh-scan-subject-regexp - "^ *[0-9]+........[ ]*...................\\([Rr][Ee]\\(\\[[0-9]+\\]\\)?:\\s-*\\)*\\([^<\n]*\\)" - "This regular expression matches the subject. - -It must match from the beginning of the line. Note that the -default setting of `mh-folder-font-lock-keywords' expects this -expression to contain at least three parenthesized expressions. -The first is expected to match the \"Re:\" string, if any, and is -highlighted with the face `mh-folder-followup'. The second -matches an optional bracketed number after \"Re:\", such as in -\"Re[2]:\" (and is thus a sub-expression of the first expression) -and the third is expected to match the subject line itself which -is highlighted with the face `mh-folder-subject'. For example, -the default (broken on multiple lines for readability) is - - ^ *[0-9]+........[ ]*................... - \\\\([Rr][Ee]\\\\(\\\\\\=[[0-9]+\\\\]\\\\)?:\\\\s-*\\\\)* - \\\\([^<\\n]*\\\\) - -This regular expression should be correct as it is needed by -non-fontification functions.") - -(defvar mh-scan-sent-to-me-sender-regexp - "^ *[0-9]+.\\([bct]\\).....[ ]*\\(..................\\)" - "This regular expression matches messages sent to us. - -Note that the default setting of `mh-folder-font-lock-keywords' -expects this expression to contain at least two parenthesized -expressions. The first should match the fontification hint (see -`mh-scan-format-nmh') and the second should match the user name -as in the default of - - ^ *[0-9]+.\\\\([bct]\\\\).....[ ]*\\\\(..................\\\\) - -If this regular expression is not correct, the notation hints -will not be highlighted with the face -`mh-mh-folder-sent-to-me-hint' and the sender will not be -highlighted with the face `mh-folder-sent-to-me-sender'.") +(defconst mh-version "7.85+sans-entropy" "Version number of MH-E.") - +;; Variants -(defvar mh-folder-font-lock-keywords - (list - ;; Folders when displaying index buffer - (list "^\\+.*" - '(0 'mh-search-folder)) - ;; Marked for deletion - (list (concat mh-scan-deleted-msg-regexp ".*") - '(0 'mh-folder-deleted)) - ;; Marked for refile - (list (concat mh-scan-refiled-msg-regexp ".*") - '(0 'mh-folder-refiled)) - ;; After subject - (list mh-scan-body-regexp - '(1 'mh-folder-body nil t)) - ;; Subject - '(mh-folder-font-lock-subject - (1 'mh-folder-followup append t) - (2 'mh-folder-subject append t)) - ;; Current message number - (list mh-scan-cur-msg-number-regexp - '(1 'mh-folder-cur-msg-number)) - ;; Message number - (list mh-scan-good-msg-regexp - '(1 'mh-folder-msg-number)) - ;; Date - (list mh-scan-date-regexp - '(1 'mh-folder-date)) - ;; Messages from me (To:) - (list mh-scan-rcpt-regexp - '(1 'mh-folder-to) - '(2 'mh-folder-address)) - ;; Messages to me - (list mh-scan-sent-to-me-sender-regexp - '(1 'mh-folder-sent-to-me-hint) - '(2 'mh-folder-sent-to-me-sender))) - "Keywords (regular expressions) 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. - - \" \" blank space is the default character. - \"%\" indicates that the message in in a named MH sequence. - \"-\" indicates that the message has been annotated with a replied field. - \"t\" indicates that the message contains mymbox in the To: field. - \"c\" indicates that the message contains mymbox in the Cc: field. - \"b\" indicates that the message contains mymbox in the Bcc: field. - \"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-destination-offset - (+ mh-scan-cmd-note-width) - "The offset from the `mh-cmd-note' for the destination column.") - -(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." - (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 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)) +(defvar mh-sys-path + '("/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/" + "/usr/local/bin/mu-mh/" ; GNU mailutils - default + "/usr/bin/mu-mh/") ; GNU mailutils - packaged + "List of directories to search for variants of the MH variant. +The list `exec-path' is searched in addition to this list. +There's no need for users to modify this list. Instead add extra +directories to the customizable variable `mh-path'.") - +(defvar mh-variants nil + "List describing known MH variants. +Do not access this variable directly as it may not have yet been initialized. +Use the function `mh-variants' instead.") -;; Fontifify unseen mesages in bold. - -(defmacro mh-generate-sequence-font-lock (seq prefix face) - "Generate the appropriate code to fontify messages in SEQ. -PREFIX is used to generate unique names for the variables and -functions defined by the macro. So a different prefix should be -provided for every invocation. -FACE is the font-lock face used to display the matching scan lines." - (let ((cache (intern (format "mh-folder-%s-seq-cache" prefix))) - (func (intern (format "mh-folder-font-lock-%s" prefix)))) - `(progn - (defvar ,cache nil - "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 ',cache) - - (defun ,func (limit) - "Return unseen message lines to font-lock between point and LIMIT." - (if (not ,cache) (setq ,cache (mh-seq-msgs (mh-find-seq ,seq)))) - (let ((cur-msg (mh-get-msg-num nil))) - (cond ((not ,cache) - nil) - ((>= (point) limit) ;Presumably at end of buffer - (setq ,cache nil) - nil) - ((member cur-msg ,cache) - (let ((bpoint (progn (beginning-of-line)(point))) - (epoint (progn (forward-line 1)(point)))) - (if (<= limit (point)) (setq ,cache nil)) - (set-match-data (list bpoint epoint bpoint epoint)) - t)) - (t - ;; move forward one line at a time, checking each message - (while (and (= 0 (forward-line 1)) - (> limit (point)) - (not (member (mh-get-msg-num nil) ,cache)))) - ;; Examine how we must have exited the loop... - (let ((cur-msg (mh-get-msg-num nil))) - (cond ((or (<= limit (point)) - (not (member cur-msg ,cache))) - (setq ,cache nil) - nil) - ((member cur-msg ,cache) - (let ((bpoint (progn (beginning-of-line) (point))) - (epoint (progn (forward-line 1) (point)))) - (if (<= limit (point)) (setq ,cache nil)) - (set-match-data - (list bpoint epoint bpoint epoint)) - t)))))))) - - (setq mh-folder-font-lock-keywords - (append mh-folder-font-lock-keywords - (list (list ',func (list 1 '',face 'prepend t)))))))) - -(mh-generate-sequence-font-lock mh-unseen-seq unseen bold) -(mh-generate-sequence-font-lock mh-tick-seq tick mh-folder-tick) +(defvar mh-variant-in-use nil + "The MH variant currently in use; a string with variant and version number. +This differs from `mh-variant' when the latter is set to +\"autodetect\".") - +(defvar mh-progs nil + "Directory containing MH commands, such as inc, repl, and rmm.") + +;;;###autoload +(put 'mh-progs 'risky-local-variable t) + +(defvar mh-lib nil + "Directory containing the MH library. +This directory contains, among other things, the components file.") + +;;;###autoload +(put 'mh-lib 'risky-local-variable t) + +(defvar mh-lib-progs nil + "Directory containing MH helper programs. +This directory contains, among other things, the mhl program.") + +;;;###autoload +(put 'mh-lib-progs 'risky-local-variable t) -;;; Internal variables: +;; Profile Components -(defvar mh-last-destination nil - "Destination of last refile or write command.") +(defvar mh-draft-folder nil + "Cached value of the \"Draft-Folder:\" MH profile component. +Name of folder containing draft messages. +Nil means do not use a draft folder.") -(defvar mh-last-destination-folder nil - "Destination of last refile command.") +(defvar mh-inbox nil + "Cached value of the \"Inbox:\" MH profile component. +Set to \"+inbox\" if no such component. +Name of the Inbox folder.") -(defvar mh-last-destination-write nil - "Destination of last write command.") +(defvar mh-user-path nil + "Cached value of the \"Path:\" MH profile component. +User's mail folder directory.") + +;; Maps declared here so that they can be used in docstrings. (defvar mh-folder-mode-map (make-keymap) - "Keymap for MH folders.") + "Keymap for MH-Folder mode.") + +(defvar mh-folder-seq-tool-bar-map nil + "Keymap for MH-Folder tool bar.") + +(defvar mh-folder-tool-bar-map nil + "Keymap for MH-Folder tool bar.") + +(defvar mh-inc-spool-map (make-sparse-keymap) + "Keymap for MH-E's mh-inc-spool commands.") + +(defvar mh-letter-mode-map (copy-keymap text-mode-map) + "Keymap for MH-Letter mode.") + +(defvar mh-letter-tool-bar-map nil + "Keymap for MH-Letter tool bar.") + +(defvar mh-search-mode-map (make-sparse-keymap) + "Keymap for MH-Search mode.") + +(defvar mh-show-mode-map (make-sparse-keymap) + "Keymap MH-Show mode.") + +(defvar mh-show-seq-tool-bar-map nil + "Keymap for MH-Show tool bar.") + +(defvar mh-show-tool-bar-map nil + "Keymap for MH-Show tool bar.") + +;; MH-Folder Locals (alphabetical) (defvar mh-arrow-marker nil "Marker for arrow display in fringe.") +(defvar mh-colors-available-flag nil + "Non-nil means colors are available.") + +(defvar mh-current-folder nil + "Name of current folder, a string.") + (defvar mh-delete-list nil "List of message numbers to delete. This variable can be used by `mh-before-commands-processed-hook'.") +(defvar mh-folder-view-stack nil + "Stack of previous folder views.") + +(defvar mh-index-data nil + "Info about index search results.") + +(defvar mh-index-previous-search nil) + +(defvar mh-index-msg-checksum-map nil) + +(defvar mh-index-checksum-origin-map nil) + +(defvar mh-index-sequence-search-flag nil) + +(defvar mh-mode-line-annotation nil + "Message range displayed in buffer.") + +(defvar mh-next-direction 'forward + "Direction to move to next message.") + +(defvar mh-previous-window-config nil + "Window configuration before MH-E command.") + (defvar mh-refile-list nil "List of folder names in `mh-seq-list'. This variable can be used by `mh-before-commands-processed-hook'.") -(defvar mh-folders-changed nil - "Lists which folders were affected by deletes and refiles. -This list will always include the current folder -`mh-current-folder'. This variable can be used by -`mh-after-commands-processed-hook'.") +(defvar mh-seen-list nil + "List of displayed messages to be removed from the \"Unseen\" sequence.") -(defvar mh-next-direction 'forward - "Direction to move to next message.") +(defvar mh-seq-list nil + "Alist of this folder's sequences. +Elements have the form (SEQUENCE . MESSAGES).") + +(defvar mh-sequence-notation-history nil + "Remember original notation that is overwritten by `mh-note-seq'.") + +(defvar mh-show-buffer nil + "Buffer that displays message for this folder.") -(defvar mh-view-ops () +(defvar mh-showing-mode nil + "If non-nil, show the message in a separate window.") + +(defvar mh-view-ops nil "Stack of operations that change the folder view. These operations include narrowing or threading.") -(defvar mh-folder-view-stack () - "Stack of previous folder views.") +;; MH-Show Locals (alphabetical) -(defvar mh-index-data nil - "Info about index search results.") +(defvar mh-globals-hash (make-hash-table) + "Keeps track of MIME data on a per buffer basis.") -(defvar mh-index-previous-search nil) -(defvar mh-index-msg-checksum-map nil) -(defvar mh-index-checksum-origin-map nil) -(defvar mh-index-sequence-search-flag nil) +(defvar mh-show-folder-buffer nil + "Keeps track of folder whose message is being displayed.") -(defvar mh-first-msg-num nil - "Number of first message in buffer.") +;; MH-Letter Locals -(defvar mh-last-msg-num nil - "Number of last msg in buffer.") +(defvar mh-folders-changed nil + "Lists which folders were affected by deletes and refiles. +This list will always include the current folder +`mh-current-folder'. This variable can be used by +`mh-after-commands-processed-hook'.") -(defvar mh-mode-line-annotation nil - "Message range displayed in buffer.") +(defvar mh-mail-header-separator "--------" + "*Line used by MH to separate headers from text in messages being composed. -(defvar mh-sequence-notation-history nil - "Remember original notation that is overwritten by `mh-note-seq'.") +This variable should not be used directly in programs. Programs +should use `mail-header-separator' instead. +`mail-header-separator' is initialized to +`mh-mail-header-separator' in `mh-letter-mode'; in other +contexts, you may have to perform this initialization yourself. -(defvar mh-colors-available-flag nil - "Non-nil means colors are available.") +Do not make this a regular expression as it may be the argument +to `insert' and it is passed through `regexp-quote' before being +used by functions like `re-search-forward'.") - +(defvar mh-sent-from-folder nil + "Folder of msg assoc with this letter.") -;;; Macros and generic functions: - -(defun mh-mapc (function list) - "Apply FUNCTION to each element of LIST for side effects only." - (while list - (funcall function (car list)) - (setq list (cdr list)))) - -(defun mh-scan-format () - "Return the output format argument for the scan program." - (if (equal mh-scan-format-file t) - (list "-format" (if (mh-variant-p 'nmh 'mu-mh) - (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)))) +(defvar mh-sent-from-msg nil + "Number of msg assoc with this letter.") - +;; Sequences -;;; Entry points: +(defvar mh-unseen-seq nil + "Cached value of the \"Unseen-Sequence:\" MH profile component. +Name of the Unseen sequence.") -;;;###autoload -(defun mh-rmail (&optional arg) - "Incorporate new mail with MH. -Scan an MH folder if ARG is non-nil. +(defvar mh-previous-seq nil + "Cached value of the \"Previous-Sequence:\" MH profile component. +Name of the Previous sequence.") -This function is an entry point to MH-E, the Emacs interface to -the MH mail system." - (interactive "P") - (mh-find-path) - (if arg - (call-interactively 'mh-visit-folder) - (unless (get-buffer mh-inbox) - (mh-visit-folder mh-inbox (symbol-name mh-unseen-seq))) - (mh-inc-folder))) +;; Etc. (alphabetical) -;;;###autoload -(defun mh-nmail (&optional arg) - "Check for new mail in inbox folder. -Scan an MH folder if ARG is non-nil. +(defvar mh-flists-present-flag nil + "Non-nil means that we have \"flists\".") -This function is an entry point to MH-E, the Emacs interface to -the MH mail system." - (interactive "P") - (mh-find-path) ; init mh-inbox - (if arg - (call-interactively 'mh-visit-folder) - (mh-visit-folder mh-inbox))) +(defvar mh-index-data-file ".mhe_index" + "MH-E specific file where index seach info is stored.") - +(defvar mh-letter-header-field-regexp "^\\([A-Za-z][A-Za-z0-9-]*\\):") -;;; User executable MH-E commands: - -(defun mh-delete-msg (range) - "Delete RANGE\\<mh-folder-mode-map>. - -To mark a message for deletion, use this command. A \"D\" is -placed by the message in the scan window, and the next undeleted -message is displayed. If the previous command had been -\\[mh-previous-undeleted-msg], then the next message displayed is -the first undeleted message previous to the message just deleted. -Use \\[mh-next-undeleted-msg] to force subsequent -\\[mh-delete-msg] commands to move forward to the next undeleted -message after deleting the message under the cursor. - -The hook `mh-delete-msg-hook' is called after you mark a message -for deletion. For example, a past maintainer of MH-E used this -once when he kept statistics on his mail usage. - -Check the documentation of `mh-interactive-range' to see how -RANGE is read in interactive use." - (interactive (list (mh-interactive-range "Delete"))) - (mh-delete-msg-no-motion range) - (if (looking-at mh-scan-deleted-msg-regexp) - (mh-next-msg))) - -(defun mh-delete-msg-no-motion (range) - "Delete RANGE, don't move to next message. - -This command marks the RANGE for deletion but leaves the cursor -at the current message in case you wish to perform other -operations on the message. - -Check the documentation of `mh-interactive-range' to see how -RANGE is read in interactive use." - (interactive (list (mh-interactive-range "Delete"))) - (mh-iterate-on-range () range - (mh-delete-a-msg nil))) - -(defun mh-execute-commands () - "Process outstanding delete and refile requests\\<mh-folder-mode-map>. - -If you've marked messages to be deleted or refiled and you want -to go ahead and delete or refile the messages, use this command. -Many MH-E commands that may affect the numbering of the -messages (such as \\[mh-rescan-folder] or \\[mh-pack-folder]) -will ask if you want to process refiles or deletes first and then -either run this command for you or undo the pending refiles and -deletes, which are lost. - -This function runs `mh-before-commands-processed-hook' before the -commands are processed and `mh-after-commands-processed-hook' -after the commands are processed." - (interactive) - (if mh-folder-view-stack (mh-widen t)) - (mh-process-commands mh-current-folder) - (mh-set-scan-mode) - (mh-goto-cur-msg) ; after mh-set-scan-mode for efficiency - (mh-make-folder-mode-line) - t) ; return t for write-file-functions - -(defun mh-first-msg () - "Display first message." - (interactive) - (goto-char (point-min)) - (while (and (not (eobp)) (not (looking-at mh-scan-valid-regexp))) - (forward-line 1))) +(defvar mh-page-to-next-msg-flag nil + "Non-nil means next SPC or whatever goes to next undeleted message.") -(defun mh-header-display () - "Display message with all header fields\\<mh-folder-mode-map>. +(defvar mh-pgp-support-flag (not (not (locate-library "mml2015"))) + "Non-nil means PGP support is available.") -Use the command \\[mh-show] to show the message normally again." - (interactive) - (and (not mh-showing-with-headers) - (or mh-mhl-format-file mh-clean-message-header-flag) - (mh-invalidate-show-buffer)) - (let ((mh-decode-mime-flag nil) - (mh-mhl-format-file 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 file folder) - "Incorporate new mail into a folder. - -You can incorporate mail from any file into the current folder by -specifying a prefix argument; you'll be prompted for the name of -the FILE to use as well as the destination FOLDER - -The hook `mh-inc-folder-hook' is run 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: " - mh-user-path))) - (if current-prefix-arg - (mh-prompt-for-folder "inc mail into" mh-inbox t)))) - (if (not folder) - (setq folder mh-inbox)) - (let ((threading-needed-flag nil)) - (let ((config (current-window-configuration))) - (when (and mh-show-buffer (get-buffer mh-show-buffer)) - (delete-windows-on mh-show-buffer)) - (cond ((not (get-buffer folder)) - (mh-make-folder folder) - (setq threading-needed-flag mh-show-threads-flag) - (setq mh-previous-window-config config)) - ((not (eq (current-buffer) (get-buffer folder))) - (switch-to-buffer folder) - (setq mh-previous-window-config config)))) - (mh-get-new-mail file) - (when (and threading-needed-flag - (save-excursion - (goto-char (point-min)) - (or (null mh-large-folder) - (not (equal (forward-line (1+ mh-large-folder)) 0)) - (and (message "Not threading since the number of messages exceeds `mh-large-folder'") - nil)))) - (mh-toggle-threads)) - (beginning-of-line) - (if (and mh-showing-mode (looking-at mh-scan-valid-regexp)) (mh-show)) - (run-hooks 'mh-inc-folder-hook))) - -(defun mh-last-msg () - "Display last message." - (interactive) - (goto-char (point-max)) - (while (and (not (bobp)) (not (looking-at mh-scan-valid-regexp))) - (forward-line -1)) - (mh-recenter nil)) - -(defun mh-next-undeleted-msg (&optional count wait-after-complaining-flag) - "Display next message. - -This command can be given a prefix argument COUNT to specify how -many unread messages to skip. - -In a program, pause for a second after printing message if we are -at the last undeleted message and optional argument -WAIT-AFTER-COMPLAINING-FLAG is non-nil." - (interactive "p") - (setq mh-next-direction 'forward) - (forward-line 1) - (cond ((re-search-forward mh-scan-good-msg-regexp nil t count) - (beginning-of-line) - (mh-maybe-show)) - (t (forward-line -1) - (message "No more undeleted messages") - (if wait-after-complaining-flag (sit-for 1))))) - -(defun mh-folder-from-address () - "Derive folder name from sender. - -The name of the folder is derived as follows: - - a) The folder name associated with the first address found in - the list `mh-default-folder-list' is used. Each element in - this list contains a \"Check Recipient\" item. If this item is - turned on, then the address is checked against the recipient - instead of the sender. This is useful for mailing lists. - - b) An alias prefixed by `mh-default-folder-prefix' - corresponding to the address is used. The prefix is used to - prevent clutter in your mail directory. - -Return nil if a folder name was not derived, or if the variable -`mh-default-folder-must-exist-flag' is t and the folder does not -exist." - ;; Loop for all entries in mh-default-folder-list - (save-restriction - (goto-char (point-min)) - (re-search-forward "\n\n" nil 'limit) - (narrow-to-region (point-min) (point)) - (let ((to/cc (concat (or (message-fetch-field "to") "") ", " - (or (message-fetch-field "cc") ""))) - (from (or (message-fetch-field "from") "")) - folder-name) - (setq folder-name - (loop for list in mh-default-folder-list - when (string-match (nth 0 list) (if (nth 2 list) to/cc from)) - return (nth 1 list) - finally return nil)) - - ;; Make sure a result from `mh-default-folder-list' begins with "+" - ;; since 'mh-expand-file-name below depends on it - (when (and folder-name (not (eq (aref folder-name 0) ?+))) - (setq folder-name (concat "+" folder-name))) - - ;; If not, is there an alias for the address? - (when (not folder-name) - (let* ((from-header (mh-extract-from-header-value)) - (address (and from-header - (nth 1 (mail-extract-address-components - from-header)))) - (alias (and address (mh-alias-address-to-alias address)))) - (when alias - (setq folder-name - (and alias (concat "+" mh-default-folder-prefix alias)))))) - - ;; If mh-default-folder-must-exist-flag set, check that folder exists. - (if (and folder-name - (or (not mh-default-folder-must-exist-flag) - (file-exists-p (mh-expand-file-name folder-name)))) - folder-name)))) - -(defun mh-prompt-for-refile-folder () - "Prompt the user for a folder in which the message should be filed. -The folder is returned as a string. - -The default folder name is generated by the option -`mh-default-folder-for-message-function' if it is non-nil or -`mh-folder-from-address'." - (mh-prompt-for-folder - "Destination" - (let ((refile-file (ignore-errors (mh-msg-filename (mh-get-msg-num t))))) - (if (null refile-file) "" - (save-excursion - (set-buffer (get-buffer-create mh-temp-buffer)) - (erase-buffer) - (insert-file-contents refile-file) - (or (and mh-default-folder-for-message-function - (let ((buffer-file-name refile-file)) - (funcall mh-default-folder-for-message-function))) - (mh-folder-from-address) - (and (eq 'refile (car mh-last-destination-folder)) - (symbol-name (cdr mh-last-destination-folder))) - "")))) - t)) - -(defun mh-refile-msg (range folder &optional dont-update-last-destination-flag) - "Refile (output) RANGE into FOLDER. - -You are prompted for the folder name. Note that this command can also -be used to create folders. If you specify a folder that does not -exist, you will be prompted to create it. - -The hook `mh-refile-msg-hook' is called after a message is marked to -be refiled. - -Check the documentation of `mh-interactive-range' to see how RANGE is -read in interactive use. - -In a program, the variables `mh-last-destination' and -`mh-last-destination-folder' are not updated if -DONT-UPDATE-LAST-DESTINATION-FLAG is non-nil." - (interactive (list (mh-interactive-range "Refile") - (intern (mh-prompt-for-refile-folder)))) - (unless dont-update-last-destination-flag - (setq mh-last-destination (cons 'refile folder) - mh-last-destination-folder mh-last-destination)) - (mh-iterate-on-range () range - (mh-refile-a-msg nil folder)) - (when (looking-at mh-scan-refiled-msg-regexp) (mh-next-msg))) - -(defun mh-refile-or-write-again (range &optional interactive-flag) - "Repeat last output command. - -If you are refiling several messages into the same folder, you -can use this command to repeat the last -refile (\\[mh-refile-msg]) or write (\\[mh-write-msg-to-file]). -You can use a range. - -Check the documentation of `mh-interactive-range' to see how RANGE is -read in interactive use. - -In a program, a non-nil INTERACTIVE-FLAG means that the function was -called interactively." - (interactive (list (mh-interactive-range "Redo") t)) - (if (null mh-last-destination) - (error "No previous refile or write")) - (cond ((eq (car mh-last-destination) 'refile) - (mh-refile-msg range (cdr mh-last-destination)) - (message "Destination folder: %s" (cdr mh-last-destination))) - (t - (mh-iterate-on-range msg range - (apply 'mh-write-msg-to-file msg (cdr mh-last-destination))) - (mh-next-msg interactive-flag)))) - -(defun mh-quit () - "Quit the current MH-E folder. - -When you want to quit using MH-E and go back to editing, you can use -this command. This buries the buffers of the current MH-E folder and -restores the buffers that were present when you first ran -\\[mh-rmail]. It also removes any MH-E working buffers whose name -begins with \" *mh-\" or \"*MH-E \". You can later restore your MH-E -session by selecting the \"+inbox\" buffer or by running \\[mh-rmail] -again. - -The two hooks `mh-before-quit-hook' and `mh-quit-hook' are called by -this function. The former one is called before the quit occurs, so you -might use it to perform any MH-E operations; you could perform some -query and abort the quit or call `mh-execute-commands', for example. -The latter is not run in an MH-E context, so you might use it to -modify the window setup." - (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-destroy-postponed-handles) - (bury-buffer (current-buffer)) - - ;; Delete all MH-E temporary and working buffers. - (dolist (buffer (buffer-list)) - (when (or (string-match "^ \\*mh-" (buffer-name buffer)) - (string-match "^\\*MH-E " (buffer-name buffer))) - (kill-buffer buffer))) - - (if mh-previous-window-config - (set-window-configuration mh-previous-window-config)) - (run-hooks 'mh-quit-hook)) - -(defun mh-page-msg (&optional lines) - "Display next page in message. - -You can give this command a prefix argument that specifies the -number of LINES to scroll. This command will also show the next -undeleted message if it is used at the bottom of a message." - (interactive "P") - (if mh-showing-mode - (if mh-page-to-next-msg-flag - (if (equal mh-next-direction 'backward) - (mh-previous-undeleted-msg) - (mh-next-undeleted-msg)) - (if (mh-in-show-buffer (mh-show-buffer) - (pos-visible-in-window-p (point-max))) - (progn - (message - "End of message (Type %s to read %s undeleted message)" - (single-key-description last-input-event) - (if (equal mh-next-direction 'backward) - "previous" - "next")) - (setq mh-page-to-next-msg-flag t)) - (scroll-other-window lines))) - (mh-show))) - -(defun mh-previous-page (&optional lines) - "Display next page in message. - -You can give this command a prefix argument that specifies the -number of LINES to scroll." - (interactive "P") - (mh-in-show-buffer (mh-show-buffer) - (scroll-down lines))) - -(defun mh-previous-undeleted-msg (&optional count wait-after-complaining-flag) - "Display previous message. - -This command can be given a prefix argument COUNT to specify how -many unread messages to skip. - -In a program, pause for a second after printing message if we are -at the last undeleted message and optional argument -WAIT-AFTER-COMPLAINING-FLAG is non-nil." - (interactive "p") - (setq mh-next-direction 'backward) - (beginning-of-line) - (cond ((re-search-backward mh-scan-good-msg-regexp nil t count) - (mh-maybe-show)) - (t (message "No previous undeleted message") - (if wait-after-complaining-flag (sit-for 1))))) - -(defun mh-previous-unread-msg (&optional count) - "Display previous unread message. - -This command can be given a prefix argument COUNT to specify how -many unread messages to skip." - (interactive "p") - (unless (> count 0) - (error "The function `mh-previous-unread-msg' expects positive argument")) - (setq count (1- count)) - (let ((unread-sequence (cdr (assoc mh-unseen-seq mh-seq-list))) - (cur-msg (mh-get-msg-num nil))) - (cond ((and (not cur-msg) (not (bobp)) - ;; If we are at the end of the buffer back up one line and go - ;; to unread message after that. - (progn - (forward-line -1) - (setq cur-msg (mh-get-msg-num nil))) - nil)) - ((or (null unread-sequence) (not cur-msg)) - ;; No unread message or there aren't any messages in buffer... - (message "No more unread messages")) - ((progn - ;; Skip count messages... - (while (and unread-sequence (>= (car unread-sequence) cur-msg)) - (setq unread-sequence (cdr unread-sequence))) - (while (> count 0) - (setq unread-sequence (cdr unread-sequence)) - (setq count (1- count))) - (not (car unread-sequence))) - (message "No more unread messages")) - (t (loop for msg in unread-sequence - when (mh-goto-msg msg t) return nil - finally (message "No more unread messages")))))) - -(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 button. - -If the end of the buffer is reached then the search wraps over to -the start of the buffer. - -If an optional prefix argument BACKWARD-FLAG is given, the cursor -will move to the previous 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 previous button. - -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-folder-toggle-mime-part (part-index) - "View attachment. - -This command displays (or hides) the attachment associated with -the button under the cursor. If the cursor is not located over a -button, then the cursor first moves to the next button, wrapping -to the beginning of the message if necessary. This command has -the advantage over related commands of working from the MH-Folder -buffer. - -You can also provide a numeric prefix argument PART-INDEX to view -the attachment labeled with that number. If Emacs does not know -how to display the attachment, then Emacs offers to save the -attachment in a file." - (interactive "P") - (when (consp part-index) (setq part-index (car part-index))) - (mh-folder-mime-action part-index #'mh-press-button t)) +(defvar mh-signature-separator "-- \n" + "Text of a signature separator. -(defun mh-folder-inline-mime-part (part-index) - "Show attachment verbatim. +A signature separator is used to separate the body of a message +from the signature. This can be used by user agents such as MH-E +to render the signature differently or to suppress the inclusion +of the signature in a reply. Use `mh-signature-separator-regexp' +when searching for a separator.") -You can view the raw contents of an attachment with this command. -This command displays (or hides) the contents of the attachment -associated with the button under the cursor verbatim. If the -cursor is not located over a button, then the cursor first moves -to the next button, wrapping to the beginning of the message if -necessary. +(defvar mh-signature-separator-regexp "^-- $" + "This regular expression matches the signature separator. +See `mh-signature-separator'.") -You can also provide a numeric prefix argument PART-INDEX to view -the attachment labeled with that number." - (interactive "P") - (when (consp part-index) (setq part-index (car part-index))) - (mh-folder-mime-action part-index #'mh-mime-inline-part nil)) +(defvar mh-thread-scan-line-map nil + "Map of message index to various parts of the scan line.") +(make-variable-buffer-local 'mh-thread-scan-line-map) -(defun mh-folder-save-mime-part (part-index) - "Save (output) attachment. +(defvar mh-thread-scan-line-map-stack 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.") +(make-variable-buffer-local 'mh-thread-scan-line-map-stack) -This command saves the attachment associated with the button under the -cursor. If the cursor is not located over a button, then the cursor -first moves to the next button, wrapping to the beginning of the -message if necessary. +(defvar mh-x-mailer-string nil + "*String containing the contents of the X-Mailer header field. +If nil, this variable is initialized to show the version of MH-E, +Emacs, and MH the first time a message is composed.") -You can also provide a numeric prefix argument PART-INDEX to save the -attachment labeled with that number. + -This command prompts you for a filename and suggests a specific name -if it is available." - (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-folder-view-stack ()) - (setq mh-thread-scan-line-map-stack ()) - (let ((buffer-read-only nil)) (erase-buffer))) - -(defun mh-rescan-folder (&optional range dont-exec-pending) - "Rescan folder\\<mh-folder-mode-map>. - -This command is useful to grab all messages in your \"+inbox\" after -processing your new mail for the first time. If you don't want to -rescan the entire folder, this command will accept a RANGE. Check the -documentation of `mh-interactive-range' to see how RANGE is read in -interactive use. - -This command will ask if you want to process refiles or deletes first -and then either run \\[mh-execute-commands] for you or undo the -pending refiles and deletes, which are lost. - -In a program, the processing of outstanding commands is not performed -if DONT-EXEC-PENDING is non-nil." - (interactive (list (if current-prefix-arg - (mh-read-range "Rescan" mh-current-folder t nil t - mh-interpret-number-as-range-flag) - nil))) - (setq mh-next-direction 'forward) - (let ((threaded-flag (memq 'unthread mh-view-ops)) - (msg-num (mh-get-msg-num nil))) - (mh-scan-folder mh-current-folder (or range "all") dont-exec-pending) - ;; If there isn't a cur sequence, mh-scan-folder goes to the first message. - ;; Try to stay where we were. - (if (null (car (mh-seq-to-msgs 'cur))) - (mh-goto-msg msg-num t t)) - (cond (threaded-flag (mh-toggle-threads)) - (mh-index-data (mh-index-insert-folder-headers))))) - -(defun mh-write-msg-to-file (message file no-header) - "Append MESSAGE to end of FILE\\<mh-folder-mode-map>. - -You are prompted for the filename. If the file already exists, -the message is appended to it. You can also write the message to -the file without the header by specifying a prefix argument -NO-HEADER. Subsequent writes to the same file can be made with -the command \\[mh-refile-or-write-again]." - (interactive - (list (mh-get-msg-num t) - (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-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 message)) - (output-file (mh-expand-file-name file))) - (setq mh-last-destination (list 'write file (if no-header 'no-header)) - mh-last-destination-write mh-last-destination) - (save-excursion - (set-buffer (get-buffer-create mh-temp-buffer)) - (erase-buffer) - (insert-file-contents msg-file-to-output) - (goto-char (point-min)) - (if no-header (search-forward "\n\n")) - (append-to-file (point) (point-max) output-file)))) - -(defun mh-toggle-showing () - "Toggle between MH-Folder and MH-Folder Show modes. - -This command switches between MH-Folder mode and MH-Folder Show -mode. MH-Folder mode turns off the associated show buffer so that -you can perform operations on the messages quickly without -reading them. This is an excellent way to prune out your junk -mail or to refile a group of messages to another folder for later -examination." - (interactive) - (if mh-showing-mode - (mh-set-scan-mode) - (mh-show))) - -(defun mh-undo (range) - "Undo pending deletes or refiles in RANGE. - -If you've deleted a message or refiled it, but changed your mind, -you can cancel the action before you've executed it. Use this -command to undo a refile on or deletion of a single message. You -can also undo refiles and deletes for messages that are found in -a given RANGE. - -Check the documentation of `mh-interactive-range' to see how -RANGE is read in interactive use." - (interactive (list (mh-interactive-range "Undo"))) - (cond ((numberp range) - (let ((original-position (point))) - (beginning-of-line) - (while (not (or (looking-at mh-scan-deleted-msg-regexp) - (looking-at mh-scan-refiled-msg-regexp) - (and (eq mh-next-direction 'forward) (bobp)) - (and (eq mh-next-direction 'backward) - (save-excursion (forward-line) (eobp))))) - (forward-line (if (eq mh-next-direction 'forward) -1 1))) - (if (or (looking-at mh-scan-deleted-msg-regexp) - (looking-at mh-scan-refiled-msg-regexp)) - (progn - (mh-undo-msg (mh-get-msg-num t)) - (mh-maybe-show)) - (goto-char original-position) - (error "Nothing to undo")))) - (t (mh-iterate-on-range () range - (mh-undo-msg nil)))) - (if (not (mh-outstanding-commands-p)) - (mh-set-folder-modified-p nil))) - -(defun mh-folder-line-matches-show-buffer-p () - "Return t if the message under point in folder-mode is in the show buffer. -Return nil in any other circumstance (no message under point, no -show buffer, the message in the show buffer doesn't match." - (and (eq major-mode 'mh-folder-mode) - (mh-get-msg-num nil) - mh-show-buffer - (get-buffer mh-show-buffer) - (buffer-file-name (get-buffer mh-show-buffer)) - (string-match ".*/\\([0-9]+\\)$" - (buffer-file-name (get-buffer mh-show-buffer))) - (string-equal - (match-string 1 (buffer-file-name (get-buffer mh-show-buffer))) - (int-to-string (mh-get-msg-num nil))))) +;;; MH-E Entry Points (eval-when-compile (require 'gnus)) @@ -1362,1489 +416,2870 @@ gnus-version) (goto-char (point-min)) (display-buffer mh-info-buffer)) -(defun mh-parse-flist-output-line (line &optional current-folder) - "Parse LINE to generate folder name, unseen messages and total messages. -If CURRENT-FOLDER is non-nil then it contains the current folder -name and it is used to avoid problems in corner cases involving -folders whose names end with a '+' character." - (with-temp-buffer - (insert line) - (goto-char (point-max)) - (let (folder unseen total p) - (when (search-backward " out of " (point-min) t) - (setq total (string-to-number - (buffer-substring-no-properties - (match-end 0) (line-end-position)))) - (when (search-backward " in sequence " (point-min) t) - (setq p (point)) - (when (search-backward " has " (point-min) t) - (setq unseen (string-to-number (buffer-substring-no-properties - (match-end 0) p))) - (while (eq (char-after) ? ) - (backward-char)) - (setq folder (buffer-substring-no-properties - (point-min) (1+ (point)))) - (when (and (equal (aref folder (1- (length folder))) ?+) - (equal current-folder folder)) - (setq folder (substring folder 0 (1- (length folder))))) - (values (format "+%s" folder) unseen total))))))) - -(defun mh-folder-size-folder (folder) - "Find size of FOLDER using \"folder\"." - (with-temp-buffer - (let ((u (length (cdr (assoc mh-unseen-seq - (mh-read-folder-sequences folder nil)))))) - (call-process (expand-file-name "folder" mh-progs) nil t nil - "-norecurse" folder) - (goto-char (point-min)) - (if (re-search-forward " has \\([0-9]+\\) " nil t) - (values (string-to-number (match-string 1)) u folder) - (values 0 u folder))))) - -(defun mh-folder-size-flist (folder) - "Find size of FOLDER using \"flist\"." - (with-temp-buffer - (call-process (expand-file-name "flist" mh-progs) nil t nil "-showzero" - "-norecurse" folder "-sequence" (symbol-name mh-unseen-seq)) - (goto-char (point-min)) - (multiple-value-bind (folder unseen total) - (mh-parse-flist-output-line - (buffer-substring (point) (line-end-position))) - (values total unseen folder)))) - -(defun mh-folder-size (folder) - "Find size of FOLDER." - (if mh-flists-present-flag - (mh-folder-size-flist folder) - (mh-folder-size-folder folder))) - -(defun mh-visit-folder (folder &optional range index-data) - "Visit FOLDER. - -When you want to read the messages that you have refiled into folders, -use this command to visit the folder. You are prompted for the folder -name. - -The folder buffer will show just unseen messages if there are any; -otherwise, it will show all the messages in the buffer as long there -are fewer than `mh-large-folder' messages. If there are more, then you -are prompted for a range of messages to scan. - -You can provide a prefix argument in order to specify a RANGE of -messages to show when you visit the folder. In this case, regions are -not used to specify the range and `mh-large-folder' is ignored. Check -the documentation of `mh-interactive-range' to see how RANGE is read -in interactive use. - -Note that this command can also be used to create folders. If you -specify a folder that does not exist, you will be prompted to create -it. - -Do not call this function from outside MH-E; use \\[mh-rmail] instead. - -If, in a program, RANGE is nil (the default), then all messages in -FOLDER are displayed. If an index buffer is being created then -INDEX-DATA is used to initialize the index buffer specific data -structures." - (interactive (let ((folder-name (mh-prompt-for-folder "Visit" mh-inbox t))) - (list folder-name - (mh-read-range "Scan" folder-name t nil - current-prefix-arg - mh-interpret-number-as-range-flag)))) - (let ((config (current-window-configuration)) - (current-buffer (current-buffer)) - (threaded-view-flag mh-show-threads-flag)) - (delete-other-windows) - (save-excursion - (when (get-buffer folder) - (set-buffer folder) - (setq threaded-view-flag (memq 'unthread mh-view-ops)))) - (when index-data - (mh-make-folder folder) - (setq mh-index-data (car index-data) - mh-index-msg-checksum-map (make-hash-table :test #'equal) - mh-index-checksum-origin-map (make-hash-table :test #'equal)) - (mh-index-update-maps folder (cadr index-data)) - (mh-index-create-sequences)) - (mh-scan-folder folder (or range "all")) - (cond ((and threaded-view-flag - (save-excursion - (goto-char (point-min)) - (or (null mh-large-folder) - (not (equal (forward-line (1+ mh-large-folder)) 0)) - (and (message "Not threading since the number of messages exceeds `mh-large-folder'") - nil)))) - (mh-toggle-threads)) - (mh-index-data - (mh-index-insert-folder-headers))) - (unless (eq current-buffer (current-buffer)) - (setq mh-previous-window-config config))) - nil) - -(defun mh-update-sequences () - "Flush MH-E's state out to MH. - -This function updates the sequence specified by your -\"Unseen-Sequence:\" profile component, \"cur\", and the sequence -listed by the `mh-tick-seq' option which is \"tick\" by default. -The message at the cursor is used for \"cur\"." - (interactive) - ;; mh-update-sequences is the opposite of mh-read-folder-sequences, - ;; which updates MH-E's state from MH. - (let ((folder-set (mh-update-unseen)) - (new-cur (mh-get-msg-num nil))) - (if new-cur - (let ((seq-entry (mh-find-seq 'cur))) - (mh-remove-cur-notation) - (setcdr seq-entry - (list new-cur)) ;delete-seq-locally, add-msgs-to-seq - (mh-define-sequence 'cur (list new-cur)) - (beginning-of-line) - (if (looking-at mh-scan-good-msg-regexp) - (mh-notate-cur))) - (or folder-set - (save-excursion - ;; psg - mh-current-folder is nil if mh-summary-height < 4 ! - ;; So I added this sanity check. - (if (stringp mh-current-folder) - (mh-exec-cmd-quiet t "folder" mh-current-folder "-fast") - (mh-exec-cmd-quiet t "folder" "-fast"))))))) + + +;;; Support Routines + +(defun mh-list-to-string (l) + "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))) + ((symbolp (car l)) + (setq new-list (cons (symbol-name (car l)) new-list))) + ((numberp (car l)) + (setq new-list (cons (int-to-string (car l)) new-list))) + ((equal (car l) "")) + ((stringp (car l)) (setq new-list (cons (car l) new-list))) + ((listp (car l)) + (setq new-list (nconc (mh-list-to-string-1 (car l)) + new-list))) + (t (error "Bad element in `mh-list-to-string': %s" (car l)))) + (setq l (cdr l))) + new-list)) -;;; Support routines. +;;; MH-E Process Support + +(defvar mh-index-max-cmdline-args 500 + "Maximum number of command line args.") -(defun mh-delete-a-msg (message) - "Delete MESSAGE. -If MESSAGE is nil then the message at point is deleted. -The hook `mh-delete-msg-hook' is called after you mark a message -for deletion. For example, a past maintainer of MH-E used this -once when he kept statistics on his mail usage." +(defun mh-xargs (cmd &rest args) + "Partial imitation of xargs. +The current buffer contains a list of strings, one on each line. +The function will execute CMD with ARGS and pass the first +`mh-index-max-cmdline-args' strings to it. This is repeated till +all the strings have been used." + (goto-char (point-min)) + (let ((current-buffer (current-buffer))) + (with-temp-buffer + (let ((out (current-buffer))) + (set-buffer current-buffer) + (while (not (eobp)) + (let ((arg-list (reverse args)) + (count 0)) + (while (and (not (eobp)) (< count mh-index-max-cmdline-args)) + (push (buffer-substring-no-properties (point) (line-end-position)) + arg-list) + (incf count) + (forward-line)) + (apply #'call-process cmd nil (list out nil) nil + (nreverse arg-list)))) + (erase-buffer) + (insert-buffer-substring out))))) + +;; XXX This should be applied anywhere MH-E calls out to /bin/sh. +(defun mh-quote-for-shell (string) + "Quote STRING for /bin/sh. +Adds double-quotes around entire string and quotes the characters +\\, `, and $ with a backslash." + (concat "\"" + (loop for x across string + concat (format (if (memq x '(?\\ ?` ?$)) "\\%c" "%c") x)) + "\"")) + +(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." (save-excursion - (if (numberp message) - (mh-goto-msg message nil t) - (beginning-of-line) - (setq message (mh-get-msg-num t))) - (if (looking-at mh-scan-refiled-msg-regexp) - (error "Message %d is refiled; undo refile before deleting" message)) - (if (looking-at mh-scan-deleted-msg-regexp) - nil - (mh-set-folder-modified-p t) - (setq mh-delete-list (cons message mh-delete-list)) - (mh-notate nil mh-note-deleted mh-cmd-note) - (run-hooks 'mh-delete-msg-hook)))) - -(defun mh-refile-a-msg (message folder) - "Refile MESSAGE in FOLDER. -If MESSAGE is nil then the message at point is refiled. -Folder is a symbol, not a string. -The hook `mh-refile-msg-hook' is called after a message is marked to -be refiled." + (set-buffer (get-buffer-create mh-log-buffer)) + (let* ((initial-size (mh-truncate-log-buffer)) + (start (point)) + (args (mh-list-to-string args))) + (apply 'call-process (expand-file-name command mh-progs) nil t nil args) + (when (> (buffer-size) initial-size) + (save-excursion + (goto-char start) + (insert "Errors when executing: " command) + (loop for arg in args do (insert " " arg)) + (insert "\n")) + (save-window-excursion + (switch-to-buffer-other-window mh-log-buffer) + (sit-for 5)))))) + +(defun mh-exec-cmd-error (env command &rest args) + "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 - (if (numberp message) - (mh-goto-msg message nil t) - (beginning-of-line) - (setq message (mh-get-msg-num t))) - (cond ((looking-at mh-scan-deleted-msg-regexp) - (error "Message %d is deleted; undo delete before moving" message)) - ((looking-at mh-scan-refiled-msg-regexp) - (if (y-or-n-p - (format "Message %d already refiled; copy to %s as well? " - message folder)) - (mh-exec-cmd "refile" (mh-get-msg-num t) "-link" - "-src" mh-current-folder - (symbol-name folder)) - (message "Message not copied"))) - (t - (mh-set-folder-modified-p t) - (cond ((null (assoc folder mh-refile-list)) - (push (list folder message) mh-refile-list)) - ((not (member message (cdr (assoc folder mh-refile-list)))) - (push message (cdr (assoc folder mh-refile-list))))) - (mh-notate nil mh-note-refiled mh-cmd-note) - (run-hooks 'mh-refile-msg-hook))))) - -(defun mh-next-msg (&optional wait-after-complaining-flag) - "Move backward or forward to the next undeleted message in the buffer. -If optional argument WAIT-AFTER-COMPLAINING-FLAG is non-nil and -we are at the last message, then wait for a second after telling -the user that there aren't any more unread messages." - (if (eq mh-next-direction 'forward) - (mh-next-undeleted-msg 1 wait-after-complaining-flag) - (mh-previous-undeleted-msg 1 wait-after-complaining-flag))) - -(defun mh-next-unread-msg (&optional count) - "Display next unread message. - -This command can be given a prefix argument COUNT to specify how -many unread messages to skip." - (interactive "p") - (unless (> count 0) - (error "The function `mh-next-unread-msg' expects positive argument")) - (setq count (1- count)) - (let ((unread-sequence (reverse (cdr (assoc mh-unseen-seq mh-seq-list)))) - (cur-msg (mh-get-msg-num nil))) - (cond ((and (not cur-msg) (not (bobp)) - ;; If we are at the end of the buffer back up one line and go - ;; to unread message after that. - (progn - (forward-line -1) - (setq cur-msg (mh-get-msg-num nil))) - nil)) - ((or (null unread-sequence) (not cur-msg)) - ;; No unread message or there aren't any messages in buffer... - (message "No more unread messages")) - ((progn - ;; Skip messages - (while (and unread-sequence (>= cur-msg (car unread-sequence))) - (setq unread-sequence (cdr unread-sequence))) - (while (> count 0) - (setq unread-sequence (cdr unread-sequence)) - (setq count (1- count))) - (not (car unread-sequence))) - (message "No more unread messages")) - (t (loop for msg in unread-sequence - when (mh-goto-msg msg t) return nil - finally (message "No more unread messages")))))) - -(defun mh-set-scan-mode () - "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-flag - (mh-recenter nil))) - -(defun mh-undo-msg (msg) - "Undo the deletion or refile of one MSG. -If MSG is nil then act on the message at point" + (set-buffer (get-buffer-create mh-temp-buffer)) + (erase-buffer) + (let ((process-environment process-environment)) + ;; XXX: We should purge the list that split-string returns of empty + ;; strings. This can happen in XEmacs if leading or trailing spaces + ;; are present. + (dolist (elem (if (stringp env) (split-string env " ") ())) + (push elem process-environment)) + (mh-handle-process-error + command (apply #'call-process (expand-file-name command mh-progs) + nil t nil (mh-list-to-string args)))))) + +(defun mh-exec-cmd-daemon (command filter &rest args) + "Execute MH command COMMAND in the background. + +If FILTER is non-nil then it is used to process the output +otherwise the default filter `mh-process-daemon' is used. See +`set-process-filter' for more details of FILTER. + +ARGS are passed to COMMAND as command line arguments." + (save-excursion + (set-buffer (get-buffer-create mh-log-buffer)) + (mh-truncate-log-buffer)) + (let* ((process-connection-type nil) + (process (apply 'start-process + command nil + (expand-file-name command mh-progs) + (mh-list-to-string args)))) + (set-process-filter process (or filter 'mh-process-daemon)) + process)) + +(defun mh-exec-cmd-env-daemon (env command filter &rest args) + "In ennvironment ENV, execute mh-command COMMAND in the background. + +ENV is nil or a string of space-separated \"var=value\" elements. +Signals an error if process does not complete successfully. + +If FILTER is non-nil then it is used to process the output +otherwise the default filter `mh-process-daemon' is used. See +`set-process-filter' for more details of FILTER. + +ARGS are passed to COMMAND as command line arguments." + (let ((process-environment process-environment)) + (dolist (elem (if (stringp env) (split-string env " ") ())) + (push elem process-environment)) + (apply #'mh-exec-cmd-daemon command filter args))) + +(defun mh-process-daemon (process output) + "PROCESS daemon that puts OUTPUT into a temporary buffer. +Any output from the process is displayed in an asynchronous +pop-up window." + (with-current-buffer (get-buffer-create mh-log-buffer) + (insert-before-markers output) + (display-buffer mh-log-buffer))) + +(defun mh-exec-cmd-quiet (raise-error command &rest args) + "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 + (apply 'call-process + (expand-file-name command mh-progs) nil t nil + args))) + (goto-char (point-min)) + (if raise-error + (mh-handle-process-error command value) + value))) + +(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." + (push-mark (point) t) + (apply 'call-process + (expand-file-name command mh-progs) nil t display + (mh-list-to-string args)) + + ;; 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)) + +;; Shush compiler. +(eval-when-compile (mh-do-in-xemacs (defvar mark-active))) + +(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-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." + (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-zero STATUS, otherwise return STATUS." + (if (equal status 0) + status + (goto-char (point-min)) + (insert (if (integerp status) + (format "%s: exit code %d\n" command status) + (format "%s: %s\n" command status))) + (save-excursion + (let ((error-message (buffer-substring (point-min) (point-max)))) + (set-buffer (get-buffer-create mh-log-buffer)) + (mh-truncate-log-buffer) + (insert error-message))) + (error "%s failed, check buffer %s for error message" + command mh-log-buffer))) + + + +;;; Variant Support + +(defcustom mh-path nil + "*Additional list of directories to search for MH. +See `mh-variant'." + :group 'mh-e + :type '(repeat (directory))) + +(defun mh-variants () + "Return a list of installed variants of MH on the system. +This function looks for MH in `mh-sys-path', `mh-path' and +`exec-path'. The format of the list of variants that is returned +is described by the variable `mh-variants'." + (if mh-variants + mh-variants + (let ((list-unique)) + ;; Make a unique list of directories, keeping the given order. + ;; We don't want the same MH variant to be listed multiple times. + (loop for dir in (append mh-path mh-sys-path exec-path) do + (setq dir (file-chase-links (directory-file-name dir))) + (add-to-list 'list-unique dir)) + (loop for dir in (nreverse list-unique) do + (when (and dir (file-directory-p dir) (file-readable-p dir)) + (let ((variant (mh-variant-info dir))) + (if variant + (add-to-list 'mh-variants variant))))) + mh-variants))) + +(defun mh-variant-info (dir) + "Return MH variant found in DIR, or nil if none present." (save-excursion - (if (numberp msg) - (mh-goto-msg msg t t) - (beginning-of-line) - (setq msg (mh-get-msg-num t))) - (cond ((memq msg mh-delete-list) - (setq mh-delete-list (delq msg mh-delete-list))) + (let ((tmp-buffer (get-buffer-create mh-temp-buffer))) + (set-buffer tmp-buffer) + (cond + ((mh-variant-mh-info dir)) + ((mh-variant-nmh-info dir)) + ((mh-variant-mu-mh-info dir)))))) + +(defun mh-variant-mh-info (dir) + "Return info for MH variant in DIR assuming a temporary buffer is setup." + ;; MH does not have the -version option. + ;; Its version number is included in the output of "-help" as: + ;; + ;; version: MH 6.8.4 #2[UCI] (burrito) of Fri Jan 15 20:01:39 EST 1999 + ;; options: [ATHENA] [BIND] [DUMB] [LIBLOCKFILE] [LOCALE] [MAILGROUP] [MHE] + ;; [MHRC] [MIME] [MORE='"/usr/bin/sensible-pager"'] [NLINK_HACK] + ;; [NORUSERPASS] [OVERHEAD] [POP] [POPSERVICE='"pop-3"'] [RENAME] + ;; [RFC1342] [RPATHS] [RPOP] [SENDMTS] [SMTP] [SOCKETS] + ;; [SPRINTFTYPE=int] [SVR4] [SYS5] [SYS5DIR] [TERMINFO] + ;; [TYPESIG=void] [UNISTD] [UTK] [VSPRINTF] + (let ((mhparam (expand-file-name "mhparam" dir))) + (when (mh-file-command-p mhparam) + (erase-buffer) + (call-process mhparam nil '(t nil) nil "-help") + (goto-char (point-min)) + (when (search-forward-regexp "version: MH \\(\\S +\\)" nil t) + (let ((version (format "MH %s" (match-string 1)))) + (erase-buffer) + (call-process mhparam nil '(t nil) nil "libdir") + (goto-char (point-min)) + (when (search-forward-regexp "^.*$" nil t) + (let ((libdir (match-string 0))) + `(,version + (variant mh) + (mh-lib-progs ,libdir) + (mh-lib ,libdir) + (mh-progs ,dir) + (flists nil))))))))) + +(defun mh-variant-mu-mh-info (dir) + "Return info for GNU mailutils variant in DIR. +This assumes that a temporary buffer is setup." + ;; 'mhparam -version' output: + ;; mhparam (GNU mailutils 0.3.2) + (let ((mhparam (expand-file-name "mhparam" dir))) + (when (mh-file-command-p mhparam) + (erase-buffer) + (call-process mhparam nil '(t nil) nil "-version") + (goto-char (point-min)) + (when (search-forward-regexp "mhparam (\\(GNU [Mm]ailutils \\S +\\))" + nil t) + (let ((version (match-string 1)) + (mh-progs dir)) + `(,version + (variant mu-mh) + (mh-lib-progs ,(mh-profile-component "libdir")) + (mh-lib ,(mh-profile-component "etcdir")) + (mh-progs ,dir) + (flists ,(file-exists-p + (expand-file-name "flists" dir))))))))) + +(defun mh-variant-nmh-info (dir) + "Return info for nmh variant in DIR assuming a temporary buffer is setup." + ;; `mhparam -version' outputs: + ;; mhparam -- nmh-1.1-RC1 [compiled on chaak at Fri Jun 20 11:03:28 PDT 2003] + (let ((mhparam (expand-file-name "mhparam" dir))) + (when (mh-file-command-p mhparam) + (erase-buffer) + (call-process mhparam nil '(t nil) nil "-version") + (goto-char (point-min)) + (when (search-forward-regexp "mhparam -- nmh-\\(\\S +\\)" nil t) + (let ((version (format "nmh %s" (match-string 1))) + (mh-progs dir)) + `(,version + (variant nmh) + (mh-lib-progs ,(mh-profile-component "libdir")) + (mh-lib ,(mh-profile-component "etcdir")) + (mh-progs ,dir) + (flists ,(file-exists-p + (expand-file-name "flists" dir))))))))) + +(defun mh-file-command-p (file) + "Return t if file FILE is the name of a executable regular file." + (and (file-regular-p file) (file-executable-p file))) + +(defun mh-variant-set-variant (variant) + "Setup the system variables for the MH variant named VARIANT. +If VARIANT is a string, use that key in the alist returned by the +function `mh-variants'. +If VARIANT is a symbol, select the first entry that matches that +variant." + (cond + ((stringp variant) ;e.g. "nmh 1.1-RC1" + (when (assoc variant (mh-variants)) + (let* ((alist (cdr (assoc variant (mh-variants)))) + (lib-progs (cadr (assoc 'mh-lib-progs alist))) + (lib (cadr (assoc 'mh-lib alist))) + (progs (cadr (assoc 'mh-progs alist))) + (flists (cadr (assoc 'flists alist)))) + ;;(set-default mh-variant variant) + (setq mh-x-mailer-string nil + mh-flists-present-flag flists + mh-lib-progs lib-progs + mh-lib lib + mh-progs progs + mh-variant-in-use variant)))) + ((symbolp variant) ;e.g. 'nmh (pick the first match) + (loop for variant-list in (mh-variants) + when (eq variant (cadr (assoc 'variant (cdr variant-list)))) + return (let* ((version (car variant-list)) + (alist (cdr variant-list)) + (lib-progs (cadr (assoc 'mh-lib-progs alist))) + (lib (cadr (assoc 'mh-lib alist))) + (progs (cadr (assoc 'mh-progs alist))) + (flists (cadr (assoc 'flists alist)))) + ;;(set-default mh-variant flavor) + (setq mh-x-mailer-string nil + mh-flists-present-flag flists + mh-lib-progs lib-progs + mh-lib lib + mh-progs progs + mh-variant-in-use version) + t))))) + +(defun mh-variant-p (&rest variants) + "Return t if variant is any of VARIANTS. +Currently known variants are 'MH, 'nmh, and 'mu-mh." + (let ((variant-in-use + (cadr (assoc 'variant (assoc mh-variant-in-use (mh-variants)))))) + (not (null (member variant-in-use variants))))) + +(defun mh-profile-component (component) + "Return COMPONENT value from mhparam, or nil if unset." + (save-excursion + (mh-exec-cmd-quiet nil "mhparam" "-components" component) + (mh-profile-component-value component))) + +(defun mh-profile-component-value (component) + "Find and return the value of COMPONENT in the current buffer. +Returns nil if the component is not in the buffer." + (let ((case-fold-search t)) + (goto-char (point-min)) + (cond ((not (re-search-forward (format "^%s:" component) nil t)) nil) + ((looking-at "[\t ]*$") nil) (t - (dolist (folder-msg-list mh-refile-list) - (setf (cdr folder-msg-list) (remove msg (cdr folder-msg-list)))) - (setq mh-refile-list (loop for x in mh-refile-list - unless (null (cdr x)) collect x)))) - (mh-notate nil ? mh-cmd-note))) + (re-search-forward "[\t ]*\\([^\t \n].*\\)$" nil t) + (let ((start (match-beginning 1))) + (end-of-line) + (buffer-substring start (point))))))) + +(defun mh-variant-set (variant) + "Set the MH variant to VARIANT. +Sets `mh-progs', `mh-lib', `mh-lib-progs' and +`mh-flists-present-flag'. +If the VARIANT is \"autodetect\", then first try nmh, then MH and +finally GNU mailutils." + (interactive + (list (completing-read + "MH variant: " + (mapcar (lambda (x) (list (car x))) (mh-variants)) + nil t))) + (let ((valid-list (mapcar (lambda (x) (car x)) (mh-variants)))) + (cond + ((eq variant 'none)) + ((eq variant 'autodetect) + (cond + ((mh-variant-set-variant 'nmh) + (message "%s installed as MH variant" mh-variant-in-use)) + ((mh-variant-set-variant 'mh) + (message "%s installed as MH variant" mh-variant-in-use)) + ((mh-variant-set-variant 'mu-mh) + (message "%s installed as MH variant" mh-variant-in-use)) + (t + (message "No MH variant found on the system")))) + ((member variant valid-list) + (when (not (mh-variant-set-variant variant)) + (message "Warning: %s variant not found. Autodetecting..." variant) + (mh-variant-set 'autodetect))) + (t + (message "Unknown variant; use %s" + (mapconcat '(lambda (x) (format "%s" (car x))) + (mh-variants) " or ")))))) + +(defcustom mh-variant 'autodetect + "*Specifies the variant used by MH-E. + +The default setting of this option is \"Auto-detect\" which means +that MH-E will automatically choose the first of nmh, MH, or GNU +mailutils that it finds in the directories listed in +`mh-path' (which you can customize), `mh-sys-path', and +`exec-path'. If, for example, you have both nmh and mailutils +installed and `mh-variant-in-use' was initialized to nmh but you +want to use mailutils, then you can set this option to +\"mailutils\". + +When this variable is changed, MH-E resets `mh-progs', `mh-lib', +`mh-lib-progs', `mh-flists-present-flag', and `mh-variant-in-use' +accordingly." + :type `(radio + (const :tag "Auto-detect" autodetect) + ,@(mapcar (lambda (x) `(const ,(car x))) (mh-variants))) + :set (lambda (symbol value) + (set-default symbol value) ;Done in mh-variant-set-variant! + (mh-variant-set value)) + :group 'mh-e) -;;; The folder data abstraction. +;;; MH-E Customization -(defvar mh-index-data-file ".mhe_index" - "MH-E specific file where index seach info is stored.") +;; All of the defgroups, defcustoms, and deffaces in MH-E are found +;; here. This makes it possible to customize modules that aren't +;; loaded yet. It also makes it easier to organize the customization +;; groups. -(defun mh-make-folder (name) - "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-msg-num-width-to-column (mh-msg-num-width name)))) - (setq buffer-read-only t) - (mh-folder-mode) - (mh-set-folder-modified-p nil) - (setq buffer-file-name mh-folder-filename) - (when (and (not mh-index-data) - (file-exists-p (concat buffer-file-name mh-index-data-file))) - (mh-index-read-data)) - (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) +;; This section contains the following sub-sections: + +;; 1. MH-E Customization Groups + +;; These are the customization group definitions. Every group has a +;; associated manual node. The ordering is alphabetical, except for +;; the groups mh-faces and mh-hooks which are last . + +;; 2. MH-E Customization + +;; These are the actual customization variables. There is a +;; sub-section for each group in the MH-E Customization Groups +;; section, in the same order, separated by page breaks. Within +;; each section, variables are sorted alphabetically. + +;; 3. Hooks + +;; All hooks must be placed in the mh-hook group; in addition, add +;; the group associated with the manual node in which the hook is +;; described. Since the mh-hook group appears near the end of this +;; section, the hooks will appear at the end of these other groups. + +;; 4. Faces + +;; All faces must be placed in the mh-faces group; in addition, add +;; the group associated with the manual node in which the face is +;; described. Since the mh-faces group appears near the end of this +;; section, the faces will appear at the end of these other groups. + +(defun mh-customize (&optional delete-other-windows-flag) + "Customize MH-E variables. +If optional argument DELETE-OTHER-WINDOWS-FLAG is non-nil, other +windows in the frame are removed." + (interactive "P") + (customize-group 'mh-e) + (when delete-other-windows-flag + (delete-other-windows))) -;;; Build mh-folder-mode menu - -;; 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-folder-view-stack] - "--" - ["Narrow to Subject Sequence" mh-narrow-to-subject t] - ["Narrow to Tick Sequence" mh-narrow-to-tick - (and mh-tick-seq (mh-seq-msgs (mh-find-seq mh-tick-seq)))] - ["Delete Rest of Same Subject" mh-delete-subject t] - ["Toggle Tick Mark" mh-toggle-tick 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 t] - ["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 (mh-outstanding-commands-p)] - ["Execute Delete/Refile" mh-execute-commands - (mh-outstanding-commands-p)] - "--" - ["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 - (mh-outstanding-commands-p)] - ["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] - ["View New Messages" mh-index-new-messages t] - ["Search..." mh-search t] - "--" - ["Quit MH-E" mh-quit t])) +;;; MH-E Customization Groups + +(defgroup mh-e nil + "Emacs interface to the MH mail system. +MH is the Rand Mail Handler. Other implementations include nmh +and GNU mailutils." + :link '(custom-manual "(mh-e)Top") + :group 'mail) + +(defgroup mh-alias nil + "Aliases." + :link '(custom-manual "(mh-e)Aliases") + :prefix "mh-alias-" + :group 'mh-e) + +(defgroup mh-folder nil + "Organizing your mail with folders." + :prefix "mh-" + :link '(custom-manual "(mh-e)Folders") + :group 'mh-e) + +(defgroup mh-folder-selection nil + "Folder selection." + :prefix "mh-" + :link '(custom-manual "(mh-e)Folder Selection") + :group 'mh-e) + +(defgroup mh-identity nil + "Identities." + :link '(custom-manual "(mh-e)Identities") + :prefix "mh-identity-" + :group 'mh-e) + +(defgroup mh-inc nil + "Incorporating your mail." + :prefix "mh-inc-" + :link '(custom-manual "(mh-e)Incorporating Mail") + :group 'mh-e) + +(defgroup mh-junk nil + "Dealing with junk mail." + :link '(custom-manual "(mh-e)Junk") + :prefix "mh-junk-" + :group 'mh-e) + +(defgroup mh-letter nil + "Editing a draft." + :prefix "mh-" + :link '(custom-manual "(mh-e)Editing Drafts") + :group 'mh-e) + +(defgroup mh-ranges nil + "Ranges." + :prefix "mh-" + :link '(custom-manual "(mh-e)Ranges") + :group 'mh-e) + +(defgroup mh-scan-line-formats nil + "Scan line formats." + :link '(custom-manual "(mh-e)Scan Line Formats") + :prefix "mh-" + :group 'mh-e) + +(defgroup mh-search nil + "Searching." + :link '(custom-manual "(mh-e)Searching") + :prefix "mh-search-" + :group 'mh-e) + +(defgroup mh-sending-mail nil + "Sending mail." + :prefix "mh-" + :link '(custom-manual "(mh-e)Sending Mail") + :group 'mh-e) + +(defgroup mh-sequences nil + "Sequences." + :prefix "mh-" + :link '(custom-manual "(mh-e)Sequences") + :group 'mh-e) + +(defgroup mh-show nil + "Reading your mail." + :prefix "mh-" + :link '(custom-manual "(mh-e)Reading Mail") + :group 'mh-e) + +(defgroup mh-speedbar nil + "The speedbar." + :prefix "mh-speed-" + :link '(custom-manual "(mh-e)Speedbar") + :group 'mh-e) + +(defgroup mh-thread nil + "Threading." + :prefix "mh-thread-" + :link '(custom-manual "(mh-e)Threading") + :group 'mh-e) + +(defgroup mh-tool-bar nil + "The tool bar" + :link '(custom-manual "(mh-e)Tool Bar") + :prefix "mh-" + :group 'mh-e) + +(defgroup mh-hooks nil + "MH-E hooks." + :link '(custom-manual "(mh-e)Top") + :prefix "mh-" + :group 'mh-e) + +(defgroup mh-faces nil + "Faces used in MH-E." + :link '(custom-manual "(mh-e)Top") + :prefix "mh-" + :group 'faces + :group 'mh-e) -(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)) ;XEmacs - -;; Register mh-folder-mode as supporting which-function-mode... -(load "which-func" t t) -(when (and (boundp 'which-func-modes) - (not (member 'mh-folder-mode which-func-modes))) - (push 'mh-folder-mode which-func-modes)) +;;; Emacs Interface to the MH Mail System (:group mh-e) + +;; See Variant Support, above. + +;;; Aliases (:group 'mh-alias) + +(defcustom mh-alias-completion-ignore-case-flag t + "*Non-nil means don't consider case significant in MH alias completion. + +As MH ignores case in the aliases, so too does MH-E. However, you +may turn off this option to make case significant which can be +used to segregate completion of your aliases. You might use +lowercase for mailing lists and uppercase for people." + :type 'boolean + :group 'mh-alias) + +(defcustom mh-alias-expand-aliases-flag nil + "*Non-nil means to expand aliases entered in the minibuffer. + +In other words, aliases entered in the minibuffer will be +expanded to the full address in the message draft. By default, +this expansion is not performed." + :type 'boolean + :group 'mh-alias) + +(defcustom mh-alias-flash-on-comma t + "*Specify whether to flash address or warn on translation. + +This option controls the behavior when a [comma] is pressed while +entering aliases or addresses. The default setting flashes the +address associated with an address in the minibuffer briefly, but +does not display a warning if the alias is not found." + :type '(choice (const :tag "Flash but Don't Warn If No Alias" t) + (const :tag "Flash and Warn If No Alias" 1) + (const :tag "Don't Flash Nor Warn If No Alias" nil)) + :group 'mh-alias) + +(defcustom mh-alias-insert-file nil + "*Filename used to store a new MH-E alias. + +The default setting of this option is \"Use Aliasfile Profile +Component\". This option can also hold the name of a file or a +list a file names. If this option is set to a list of file names, +or the \"Aliasfile:\" profile component contains more than one file +name, MH-E will prompt for one of them when MH-E adds an alias." + :type '(choice (const :tag "Use Aliasfile Profile Component" nil) + (file :tag "Alias File") + (repeat :tag "List of Alias Files" file)) + :group 'mh-alias) + +(defcustom mh-alias-insertion-location 'sorted + "Specifies where new aliases are entered in alias files. + +This option is set to \"Alphabetical\" by default. If you organize +your alias file in other ways, then adding aliases to the \"Top\" +or \"Bottom\" of your alias file might be more appropriate." + :type '(choice (const :tag "Alphabetical" sorted) + (const :tag "Top" top) + (const :tag "Bottom" bottom)) + :group 'mh-alias) + +(defcustom mh-alias-local-users t + "*If on, local users are added to alias completion. + +Aliases are created from \"/etc/passwd\" entries with a user ID +larger than a magical number, typically 200. This can be a handy +tool on a machine where you and co-workers exchange messages. +These aliases have the form \"local.first.last\" if a real name is +present in the password file. Otherwise, the alias will have the +form \"local.login\". + +If you're on a system with thousands of users you don't know, and +the loading of local aliases slows MH-E down noticeably, then +turn this option off. + +This option also takes a string which is executed to generate the +password file. For example, use \"ypcat passwd\" to obtain the +NIS password file." + :type '(choice (boolean) (string)) + :group 'mh-alias) + +(defcustom mh-alias-local-users-prefix "local." + "*String prefixed to the real names of users from the password file. +This option can also be set to \"Use Login\". + +For example, consider the following password file entry: + + psg:x:1000:1000:Peter S Galbraith,,,:/home/psg:/bin/tcsh + +The following settings of this option will produce the associated +aliases: + + \"local.\" local.peter.galbraith + \"\" peter.galbraith + Use Login psg + +This option has no effect if variable `mh-alias-local-users' is +turned off." + :type '(choice (const :tag "Use Login" nil) + (string)) + :group 'mh-alias) + +(defcustom mh-alias-passwd-gecos-comma-separator-flag t + "*Non-nil means the gecos field in the password file uses a comma separator. + +In the example in `mh-alias-local-users-prefix', commas are used +to separate different values within the so-called gecos field. +This is a fairly common usage. However, in the rare case that the +gecos field in your password file is not separated by commas and +whose contents may contain commas, you can turn this option off." + :type 'boolean + :group 'mh-alias) -;; Shush compiler. -(eval-when-compile - (defvar desktop-save-buffer) - (defvar font-lock-auto-fontify)) + -(defvar mh-folder-buttons-init-flag nil) +;;; Organizing Your Mail with Folders (:group 'mh-folder) + +(defcustom mh-new-messages-folders t + "Folders searched for the \"unseen\" sequence. + +Set this option to \"Inbox\" to search the \"+inbox\" folder or +\"All\" to search all of the top level folders. Otherwise, list +the folders that should be searched with the \"Choose Folders\" +menu item. + +See also `mh-recursive-folders-flag'." + :type '(choice (const :tag "Inbox" t) + (const :tag "All" nil) + (repeat :tag "Choose Folders" (string :tag "Folder"))) + :group 'mh-folder) + +(defcustom mh-ticked-messages-folders t + "Folders searched for `mh-tick-seq'. + +Set this option to \"Inbox\" to search the \"+inbox\" folder or +\"All\" to search all of the top level folders. Otherwise, list +the folders that should be searched with the \"Choose Folders\" +menu item. + +See also `mh-recursive-folders-flag'." + :type '(choice (const :tag "Inbox" t) + (const :tag "All" nil) + (repeat :tag "Choose Folders" (string :tag "Folder"))) + :group 'mh-folder) + +(defcustom mh-large-folder 200 + "The number of messages that indicates a large folder. + +If a folder is deemed to be large, that is the number of messages +in it exceed this value, then confirmation is needed when it is +visited. Even when `mh-show-threads-flag' is non-nil, the folder +is not automatically threaded, if it is large. If set to nil all +folders are treated as if they are small." + :type '(choice (const :tag "No Limit") integer) + :group 'mh-folder) + +(defcustom mh-recenter-summary-flag nil + "*Non-nil means to recenter the summary window. + +If this option is turned on, recenter the summary window when the +show window is toggled off." + :type 'boolean + :group 'mh-folder) + +(defcustom mh-recursive-folders-flag nil + "*Non-nil means that commands which operate on folders do so recursively." + :type 'boolean + :group 'mh-folder) + +(defcustom mh-sortm-args nil + "*Additional arguments for \"sortm\"\\<mh-folder-mode-map>. + +This option is consulted when a prefix argument is used with +\\[mh-sort-folder]. Normally default arguments to \"sortm\" are +specified in the MH profile. This option may be used to provide +an alternate view. For example, \"'(\"-nolimit\" \"-textfield\" +\"subject\")\" is a useful setting." + :type 'string + :group 'mh-folder) -;; Autoload cookie needed by desktop.el -;;;###autoload -(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> - -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 folder; these commands are executed all at once with a -separate command. - -Options that control this mode can be changed with -\\[customize-group]; specify the \"mh\" group. In particular, please -see the `mh-scan-format-file' option if you wish to modify scan's -format. - -When a folder is visited, the hook `mh-folder-mode-hook' is run. - -Ranges -====== -Many commands that operate on individual messages, such as -`mh-forward' or `mh-refile-msg' take a RANGE argument. This argument -can be used in several ways. - -If you provide the prefix argument (\\[universal-argument]) to -these commands, then you will be prompted for the message range. -This can be any valid MH range which can include messages, -sequences, and the abbreviations (described in the mh(1) man -page): - -<num1>-<num2> - Indicates all messages in the range <num1> to <num2>, inclusive. - The range must be nonempty. - -<num>:N -<num>:+N -<num>:-N - Up to N messages beginning with (or ending with) message num. Num - may be any of the predefined symbols: first, prev, cur, next or - last. - -first:N -prev:N -next:N -last:N - The first, previous, next or last messages, if they exist. - -all - All of the messages. - -For example, a range that shows all of these things is `1 2 3 -5-10 last:5 unseen'. - -If the option `transient-mark-mode' is set to t and you set a -region in the MH-Folder buffer, then the MH-E command will -perform the operation on all messages in that region. - -\\{mh-folder-mode-map}" - (mh-do-in-gnu-emacs - (unless mh-folder-buttons-init-flag - (mh-tool-bar-folder-buttons-init) - (setq mh-folder-buttons-init-flag t))) - (make-local-variable 'font-lock-defaults) - (setq font-lock-defaults '(mh-folder-font-lock-keywords t)) - (make-local-variable 'desktop-save-buffer) - (setq desktop-save-buffer t) - (mh-make-local-vars - 'mh-colors-available-flag (mh-colors-available-p) - ; Do we have colors available - 'mh-current-folder (buffer-name) ; Name of folder, a string - 'mh-show-buffer (format "show-%s" (buffer-name)) ; Buffer that displays msgs - 'mh-folder-filename ; e.g. "/usr/foobar/Mail/inbox/" - (file-name-as-directory (mh-expand-file-name (buffer-name))) - 'mh-display-buttons-for-inline-parts-flag - mh-display-buttons-for-inline-parts-flag ; Allow for display of buttons to - ; be toggled. - 'mh-arrow-marker (make-marker) ; Marker where arrow is displayed - 'overlay-arrow-position nil ; Allow for simultaneous display in - 'overlay-arrow-string ">" ; different MH-E buffers. - 'mh-showing-mode nil ; Show message also? - 'mh-delete-list nil ; List of msgs nums to delete - 'mh-refile-list nil ; List of folder names in mh-seq-list - 'mh-seq-list nil ; Alist of (seq . msgs) nums - 'mh-seen-list nil ; List of displayed messages - 'mh-next-direction 'forward ; Direction to move to next message - 'mh-view-ops () ; Stack that keeps track of the order - ; in which narrowing/threading has been - ; carried out. - 'mh-folder-view-stack () ; Stack of previous views of the - ; folder. - 'mh-index-data nil ; If the folder was created by a call - ; to mh-search, this contains info - ; about the search results. - 'mh-index-previous-search nil ; folder, indexer, search-regexp - 'mh-index-msg-checksum-map nil ; msg -> checksum map - 'mh-index-checksum-origin-map nil ; checksum -> ( orig-folder, orig-msg ) - 'mh-index-sequence-search-flag nil ; folder resulted from sequence search - '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 ; Indicates message range - 'mh-sequence-notation-history (make-hash-table) - ; Remember what is overwritten by - ; mh-note-seq. - 'imenu-create-index-function 'mh-index-create-imenu-index - ; Setup imenu support - '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) - (mh-make-local-hook (mh-write-file-functions-compat)) - (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 - (mh-funcall-if-exists hl-line-mode 1) - (setq revert-buffer-function 'mh-undo-folder) - (or (assq 'mh-showing-mode minor-mode-alist) - (setq minor-mode-alist - (cons '(mh-showing-mode " Show") minor-mode-alist))) - (easy-menu-add mh-folder-sequence-menu) - (easy-menu-add mh-folder-message-menu) - (easy-menu-add mh-folder-folder-menu) - (set (make-local-variable 'tool-bar-map) mh-folder-tool-bar-map) - (mh-funcall-if-exists mh-tool-bar-init :folder) - (if (and mh-xemacs-flag - font-lock-auto-fontify) - (turn-on-font-lock))) ; Force font-lock in XEmacs. - -(defun mh-toggle-mime-buttons () - "Toggle option `mh-display-buttons-for-inline-parts-flag'." - (interactive) - (setq mh-display-buttons-for-inline-parts-flag - (not mh-display-buttons-for-inline-parts-flag)) - (mh-show nil t)) - -(defun mh-colors-available-p () - "Check if colors are available in the Emacs being used." - (or mh-xemacs-flag - (let ((color-cells (display-color-cells))) - (and (numberp color-cells) (>= color-cells 8))))) - -(defun mh-colors-in-use-p () - "Check if colors are being used in the folder buffer." - (and mh-colors-available-flag font-lock-mode)) - -(defun mh-make-local-vars (&rest pairs) - "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-restore-desktop-buffer (desktop-buffer-file-name - desktop-buffer-name - desktop-buffer-misc) - "Restore an MH folder buffer specified in a desktop file. -When desktop creates a buffer, DESKTOP-BUFFER-FILE-NAME holds the -file name to visit, DESKTOP-BUFFER-NAME holds the desired buffer -name, and DESKTOP-BUFFER-MISC holds a list of miscellaneous info -used by the `desktop-buffer-handlers' functions." - (mh-find-path) - (mh-visit-folder desktop-buffer-name) - (current-buffer)) - -;; desktop-buffer-mode-handlers appeared in Emacs 22. -(if (fboundp 'desktop-buffer-mode-handlers) - (add-to-list 'desktop-buffer-mode-handlers - '(mh-folder-mode . mh-restore-desktop-buffer))) - -(defun mh-scan-folder (folder range &optional dont-exec-pending) - "Scan FOLDER over RANGE. - -After the scan is performed, switch to the buffer associated with -FOLDER. - -Check the documentation of `mh-interactive-range' to see how RANGE is -read in interactive use. - -The processing of outstanding commands is not performed if -DONT-EXEC-PENDING is non-nil." - (when (stringp range) - (setq range (delete "" (split-string range "[ \t\n]")))) - (cond ((null (get-buffer folder)) - (mh-make-folder folder)) - (t - (unless dont-exec-pending - (mh-process-or-undo-commands folder) - (mh-reset-threads-and-narrowing)) - (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)) - (when (mh-outstanding-commands-p) - (mh-notate-deleted-and-refiled))) - -(defun mh-msg-num-width-to-column (width) - "Return the column for notations given message number WIDTH. -Note that columns in Emacs start with 0. - -If `mh-scan-format-file' is set to \"Use MH-E scan Format\" this -means that either `mh-scan-format-mh' or `mh-scan-format-nmh' are -in use. This function therefore assumes that the first column is -empty (to provide room for the cursor), the following WIDTH -columns contain the message number, and the column for notations -comes after that." - (if (eq mh-scan-format-file t) - (max (1+ width) 2) - (error "%s %s" "Can't call `mh-msg-num-width-to-column' when" - "`mh-scan-format-file' is not set to \"Use MH-E scan Format\""))) - -(defun mh-set-cmd-note (column) - "Set `mh-cmd-note' to COLUMN. -Note that columns in Emacs start with 0." - (setq mh-cmd-note column)) - -(defun mh-regenerate-headers (range &optional update) - "Scan folder over 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) - (mh-remove-all-notation) - (with-mh-folder-updating (nil) - (if update - (goto-char (point-max)) - (delete-region (point-min) (point-max)) - (if mh-adaptive-cmd-note-flag - (mh-set-cmd-note (mh-msg-num-width-to-column (mh-msg-num-width - folder))))) - (setq scan-start (point)) - (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 - ((looking-at (if (mh-variant-p 'mu-mh) - "scan: message set .* does not exist" - "scan: bad message list ")) - (keep-lines mh-scan-valid-regexp)) - ((looking-at "scan: ")) ; Keep error messages - (t - (keep-lines mh-scan-valid-regexp))) ; Flush random scan lines - (setq mh-seq-list (mh-read-folder-sequences folder nil)) - (mh-notate-user-sequences) - (or update - (setq mh-mode-line-annotation - (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', adjusting the notation -column with the width of the largest 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-msg-num-width-to-column (mh-msg-num-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 MAILDROP-NAME into the current buffer. -Return in the current buffer." - (let ((point-before-inc (point)) - (folder mh-current-folder) - (new-mail-flag nil)) - (with-mh-folder-updating (t) - (if maildrop-name - (message "inc %s -file %s..." folder maildrop-name) - (message "inc %s..." folder)) - (setq mh-next-direction 'forward) - (goto-char (point-max)) - (mh-remove-cur-notation) - (let ((start-of-inc (point))) - (if maildrop-name - ;; I think MH 5 used "-ms-file" instead of "-file", - ;; which would make inc'ing from maildrops fail. - (mh-exec-cmd-output mh-inc-prog nil folder - (mh-scan-format) - "-file" (expand-file-name maildrop-name) - "-width" (window-width) - "-truncate") - (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)) - (goto-char start-of-inc) - (cond ((save-excursion - (re-search-forward "^inc: no mail" nil t)) - (message "No new mail%s%s" (if maildrop-name " in " "") - (if maildrop-name maildrop-name ""))) - ((and (when mh-folder-view-stack - (let ((saved-text (buffer-substring-no-properties - start-of-inc (point-max)))) - (delete-region start-of-inc (point-max)) - (unwind-protect (mh-widen t) - (mh-remove-cur-notation) - (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 - (setq new-mail-flag t))) - (keep-lines mh-scan-valid-regexp) ; Flush random scan lines - (let* ((sequences (mh-read-folder-sequences folder t)) - (new-cur (assoc 'cur sequences)) - (new-unseen (assoc mh-unseen-seq sequences))) - (unless (assoc 'cur mh-seq-list) - (push (list 'cur) mh-seq-list)) - (unless (assoc mh-unseen-seq mh-seq-list) - (push (list mh-unseen-seq) mh-seq-list)) - (setcdr (assoc 'cur mh-seq-list) (cdr new-cur)) - (setcdr (assoc mh-unseen-seq mh-seq-list) (cdr new-unseen))) - (when (equal (point-max) start-of-inc) - (mh-notate-cur)) - (if new-mail-flag - (progn - (mh-make-folder-mode-line) - (when (mh-speed-flists-active-p) - (mh-speed-flists t mh-current-folder)) - (when (memq 'unthread mh-view-ops) - (mh-thread-inc folder start-of-inc)) - (mh-goto-cur-msg)) - (goto-char point-before-inc)) - (mh-notate-user-sequences (cons start-of-inc (point-max))))))) - -(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 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 - (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)) - ("")))))) - (mh-logo-display)))) - -(defun mh-add-sequence-notation (msg internal-seq-flag) - "Add sequence notation to the MSG on the current line. -If INTERNAL-SEQ-FLAG is non-nil, then refontify the scan line if -font-lock is turned on." - (with-mh-folder-updating (t) - (save-excursion - (beginning-of-line) - (if internal-seq-flag - (progn - ;; Change the buffer so that if transient-mark-mode is active - ;; and there is an active region it will get deactivated as in - ;; the case of user sequences. - (mh-notate nil nil mh-cmd-note) - (when font-lock-mode - (font-lock-fontify-region (point) (line-end-position)))) - (forward-char (+ mh-cmd-note mh-scan-field-destination-offset)) - (let ((stack (gethash msg mh-sequence-notation-history))) - (setf (gethash msg mh-sequence-notation-history) - (cons (char-after) stack))) - (mh-notate nil mh-note-seq - (+ mh-cmd-note mh-scan-field-destination-offset)))))) - -(defun mh-remove-sequence-notation (msg internal-seq-flag &optional all) - "Remove sequence notation from the MSG on the current line. -If INTERNAL-SEQ-FLAG is non-nil, then `font-lock' was used to -highlight the sequence. In that case, no notation needs to be removed. -Otherwise the effect of inserting `mh-note-seq' needs to be reversed. -If ALL is non-nil, then all sequence marks on the scan line are -removed." - (with-mh-folder-updating (t) - ;; This takes care of internal sequences... - (mh-notate nil nil mh-cmd-note) - (unless internal-seq-flag - ;; ... and this takes care of user sequences. - (let ((stack (gethash msg mh-sequence-notation-history))) - (while (and all (cdr stack)) - (setq stack (cdr stack))) - (when stack - (save-excursion - (beginning-of-line) - (forward-char (+ mh-cmd-note mh-scan-field-destination-offset)) - (delete-char 1) - (insert (car stack)))) - (setf (gethash msg mh-sequence-notation-history) (cdr stack)))))) - -(defun mh-remove-cur-notation () - "Remove old cur notation." - (let ((cur-msg (car (mh-seq-to-msgs 'cur)))) - (save-excursion - (when (and cur-msg - (mh-goto-msg cur-msg t t) - (looking-at mh-scan-cur-msg-number-regexp)) - (mh-notate nil ? mh-cmd-note) - (setq overlay-arrow-position nil))))) - -(defun mh-remove-all-notation () - "Remove all notations on all scan lines that MH-E introduces." - (save-excursion - (setq overlay-arrow-position nil) - (goto-char (point-min)) - (mh-iterate-on-range msg (cons (point-min) (point-max)) - (mh-notate nil ? mh-cmd-note) - (mh-remove-sequence-notation msg nil t)) - (clrhash mh-sequence-notation-history))) - -(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)) - (unless minimal-changes-flag - (mh-notate-cur) - (mh-recenter 0) - (mh-maybe-show cur-msg))) - (t - (setq overlay-arrow-position nil) - (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." - (set-buffer folder) - (if (mh-outstanding-commands-p) - (if (or mh-do-not-confirm-flag - (y-or-n-p - "Process outstanding deletes and refiles? ")) - (mh-process-commands folder) - (set-buffer folder) - (mh-undo-folder))) - (mh-update-unseen) - (mh-invalidate-show-buffer)) - -(defun mh-process-commands (folder) - "Process outstanding commands for FOLDER. - -This function runs `mh-before-commands-processed-hook' before the -commands are processed and `mh-after-commands-processed-hook' -after the commands are processed." - (message "Processing deletes and refiles for %s..." folder) - (set-buffer folder) - (with-mh-folder-updating (nil) - ;; Run the before hook -- the refile and delete lists are still valid - (run-hooks 'mh-before-commands-processed-hook) - - ;; Update the unseen sequence if it exists - (mh-update-unseen) - - (let ((redraw-needed-flag mh-index-data) - (folders-changed (list mh-current-folder)) - (seq-map (and mh-refile-list mh-refile-preserves-sequences-flag - (mh-create-sequence-map mh-seq-list))) - (dest-map (and mh-refile-list mh-refile-preserves-sequences-flag - (make-hash-table)))) - ;; Remove invalid scan lines if we are in an index folder and then remove - ;; the real messages - (when mh-index-data - (mh-index-delete-folder-headers) - (setq folders-changed - (append folders-changed (mh-index-execute-commands)))) - - ;; Then refile messages - (mh-mapc #'(lambda (folder-msg-list) - (let* ((dest-folder (symbol-name (car folder-msg-list))) - (last (car (mh-translate-range dest-folder "last"))) - (msgs (cdr folder-msg-list))) - (push dest-folder folders-changed) - (setq redraw-needed-flag t) - (apply #'mh-exec-cmd - "refile" "-src" folder dest-folder - (mh-coalesce-msg-list msgs)) - (mh-delete-scan-msgs msgs) - ;; Preserve sequences in destination folder... - (when mh-refile-preserves-sequences-flag - (clrhash dest-map) - (loop for i from (1+ (or last 0)) - for msg in (sort (copy-sequence msgs) #'<) - do (loop for seq-name in (gethash msg seq-map) - do (push i (gethash seq-name dest-map)))) - (maphash - #'(lambda (seq msgs) - ;; Can't be run in the background, since the - ;; current folder is changed by mark this could - ;; lead to a race condition with the next refile. - (apply #'mh-exec-cmd "mark" - "-sequence" (symbol-name seq) dest-folder - "-add" (mapcar #'(lambda (x) (format "%s" x)) - (mh-coalesce-msg-list msgs)))) - dest-map)))) - mh-refile-list) - (setq mh-refile-list ()) - - ;; 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. - ;; Mark cur message - (if (> (buffer-size) 0) - (mh-define-sequence 'cur (list (or (mh-get-msg-num nil) "last")))) - - ;; Redraw folder buffer if needed - (when (and redraw-needed-flag) - (when (mh-speed-flists-active-p) - (apply #'mh-speed-flists t folders-changed)) - (cond ((memq 'unthread mh-view-ops) (mh-thread-inc folder (point-max))) - (mh-index-data (mh-index-insert-folder-headers)))) - - (and (buffer-file-name (get-buffer mh-show-buffer)) - (not (file-exists-p (buffer-file-name (get-buffer mh-show-buffer)))) - ;; If "inc" were to put a new msg in this file, - ;; we would not notice, so mark it invalid now. - (mh-invalidate-show-buffer)) - - (setq mh-seq-list (mh-read-folder-sequences mh-current-folder nil)) - (mh-remove-all-notation) - (mh-notate-user-sequences) - - ;; Run the after hook -- now folders-changed is valid, - ;; but not the lists of specific messages. - (let ((mh-folders-changed folders-changed)) - (run-hooks 'mh-after-commands-processed-hook))) - - (message "Processing deletes and refiles for %s...done" folder))) - -(defun mh-update-unseen () - "Synchronize the unseen sequence with MH. -Return non-nil iff the MH folder was set. -The hook `mh-unseen-updated-hook' is called 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))) - (if unseen-msgs - (progn - (mh-undefine-sequence mh-unseen-seq mh-seen-list) - (run-hooks 'mh-unseen-updated-hook) - (while mh-seen-list - (setq unseen-msgs (delq (car mh-seen-list) unseen-msgs)) - (setq mh-seen-list (cdr mh-seen-list))) - (setcdr unseen-seq unseen-msgs) - t) ;since we set the folder - (setq mh-seen-list nil))))) - -(defun mh-delete-scan-msgs (msgs) - "Delete the scan listing lines for MSGS." - (save-excursion - (while msgs - (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 () - "Return non-nil if there are outstanding deletes or refiles." - (save-excursion - (when (eq major-mode 'mh-show-mode) - (set-buffer mh-show-folder-buffer)) - (or mh-delete-list mh-refile-list))) - -(defun mh-coalesce-msg-list (messages) - "Given a list of MESSAGES, return a list of message number ranges. -This is the inverse of `mh-read-msg-list', which expands ranges. -Message lists passed to MH programs should be processed by this -function to avoid exceeding system command line argument limits." - (let ((msgs (sort (copy-sequence messages) 'mh-greaterp)) - (range-high nil) - (prev -1) - (ranges nil)) - (while prev - (if range-high - (if (or (not (numberp prev)) - (not (equal (car msgs) (1- prev)))) - (progn ;non-sequential, flush old range - (if (eq prev range-high) - (setq ranges (cons range-high ranges)) - (setq ranges (cons (format "%s-%s" prev range-high) ranges))) - (setq range-high nil)))) - (or range-high - (setq range-high (car msgs))) ;start new or first range - (setq prev (car msgs)) - (setq msgs (cdr msgs))) - ranges)) - -(defun mh-greaterp (msg1 msg2) - "Return the greater of two message indicators MSG1 and MSG2. -Strings are \"smaller\" than numbers. -Valid values are things like \"cur\", \"last\", 1, and 1820." - (if (numberp msg1) - (if (numberp msg2) - (> msg1 msg2) - t) - (if (numberp msg2) - nil - (string-lessp msg2 msg1)))) - -(defun mh-lessp (msg1 msg2) - "Return the lesser of two message indicators MSG1 and MSG2. -Strings are \"smaller\" than numbers. -Valid values are things like \"cur\", \"last\", 1, and 1820." - (not (mh-greaterp msg1 msg2))) + + +;;; Folder Selection (:group 'mh-folder-selection) + +(defcustom mh-default-folder-for-message-function nil + "Function to select a default folder for refiling or \"Fcc:\". + +The current buffer is set to the message being refiled with point +at the start of the message. This function should return the +default folder as a string with a leading \"+\" sign. It can also +return nil so that the last folder name is used as the default, +or an empty string to suppress the default entirely." + :type 'function + :group 'mh-folder-selection) + +(defcustom mh-default-folder-list nil + "*List of addresses and folders. + +The folder name associated with the first address found in this +list is used as the default for `mh-refile-msg' and similar +functions. Each element in this list contains a \"Check Recipient\" +item. If this item is turned on, then the address is checked +against the recipient instead of the sender. This is useful for +mailing lists. + +See `mh-prompt-for-refile-folder' and `mh-folder-from-address' +for more information." + :type '(repeat (list (regexp :tag "Address") + (string :tag "Folder") + (boolean :tag "Check Recipient"))) + :group 'mh-folder-selection) + +(defcustom mh-default-folder-must-exist-flag t + "*Non-nil means guessed folder name must exist to be used. + +If the derived folder does not exist, and this option is on, then +the last folder name used is suggested. This is useful if you get +mail from various people for whom you have an alias, but file +them all in the same project folder. + +See `mh-prompt-for-refile-folder' and `mh-folder-from-address' +for more information." + :type 'boolean + :group 'mh-folder-selection) + +(defcustom mh-default-folder-prefix "" + "*Prefix used for folder names generated from aliases. +The prefix is used to prevent clutter in your mail directory. + +See `mh-prompt-for-refile-folder' and `mh-folder-from-address' +for more information." + :type 'string + :group 'mh-folder-selection) -;;; Basic sequence handling - -(defun mh-delete-seq-locally (seq) - "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." - (let ((seqs ())) - (cond (save-refiles - (mh-mapc (function (lambda (seq) ; Save the refiling sequences - (if (mh-folder-name-p (mh-seq-name seq)) - (setq seqs (cons seq seqs))))) - mh-seq-list))) - (save-excursion - (if (eq 0 (mh-exec-cmd-quiet nil "mark" folder "-list")) - (progn - ;; look for name in line of form "cur: 4" or "myseq (private): 23" - (while (re-search-forward "^[^: ]+" nil t) - (setq seqs (cons (mh-make-seq (intern (buffer-substring - (match-beginning 0) - (match-end 0))) - (mh-read-msg-list)) - seqs))) - (delete-region (point-min) (point))))) ; avoid race with - ; mh-process-daemon - seqs)) - -(defun mh-read-msg-list () - "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) - (while (re-search-forward "[0-9]+" end-of-line t) - (setq num (string-to-number (buffer-substring (match-beginning 0) - (match-end 0)))) - (cond ((looking-at "-") ; Message range - (forward-char 1) - (re-search-forward "[0-9]+" end-of-line t) - (let ((num2 (string-to-number - (buffer-substring (match-beginning 0) - (match-end 0))))) - (if (< num2 num) - (error "Bad message range: %d-%d" num num2)) - (while (<= num num2) - (setq msgs (cons num msgs)) - (setq num (1+ num))))) - ((not (zerop num)) ;"pick" outputs "0" to mean no match - (setq msgs (cons num msgs))))) - msgs)) - -(defun mh-notate-user-sequences (&optional range) - "Mark user-defined sequences in RANGE. - -Check the documentation of `mh-interactive-range' to see how -RANGE is read in interactive use; if nil all messages are -notated." - (unless range - (setq range (cons (point-min) (point-max)))) - (let ((seqs mh-seq-list) - (msg-hash (make-hash-table))) - (dolist (seq seqs) - (dolist (msg (mh-seq-msgs seq)) - (push (car seq) (gethash msg msg-hash)))) - (mh-iterate-on-range msg range - (loop for seq in (gethash msg msg-hash) - do (mh-add-sequence-notation msg (mh-internal-seq seq)))))) - -(defvar mh-internal-seqs '(answered cur deleted forwarded printed)) - -(defun mh-internal-seq (name) - "Return non-nil if NAME is the name of an internal MH-E sequence." - (or (memq name mh-internal-seqs) - (eq name mh-unseen-seq) - (and (mh-colors-in-use-p) mh-tick-seq (eq name mh-tick-seq)) - (eq name mh-previous-seq) - (mh-folder-name-p name))) - -(defun mh-valid-seq-p (name) - "Return non-nil if NAME is a valid MH sequence name." - (and (symbolp name) - (string-match "^[a-zA-Z][a-zA-Z0-9]*$" (symbol-name name)))) - -(defun mh-delete-msg-from-seq (range sequence &optional internal-flag) - "Delete RANGE from SEQUENCE. - -Check the documentation of `mh-interactive-range' to see how -RANGE is read in interactive use. - -In a program, non-nil INTERNAL-FLAG means do not inform MH of the -change." - (interactive (list (mh-interactive-range "Delete") - (mh-read-seq-default "Delete from" t) - nil)) - (let ((entry (mh-find-seq sequence)) - (user-sequence-flag (not (mh-internal-seq sequence))) - (folders-changed (list mh-current-folder)) - (msg-list ())) - (when entry - (mh-iterate-on-range msg range - (push msg msg-list) - ;; Calling "mark" repeatedly takes too long. So we will pretend here - ;; that we are just modifying an internal sequence... - (when (memq msg (cdr entry)) - (mh-remove-sequence-notation msg (not user-sequence-flag))) - (mh-delete-a-msg-from-seq msg sequence t)) - ;; ... and here we will "mark" all the messages at one go. - (unless internal-flag (mh-undefine-sequence sequence msg-list)) - (when (and mh-index-data (not internal-flag)) - (setq folders-changed - (append folders-changed - (mh-index-delete-from-sequence sequence msg-list)))) - (when (and (eq sequence mh-unseen-seq) (mh-speed-flists-active-p)) - (apply #'mh-speed-flists t folders-changed))))) - -(defun mh-catchup (range) - "Delete RANGE from the \"unseen\" sequence. - -Check the documentation of `mh-interactive-range' to see how -RANGE is read in interactive use." - (interactive (list (mh-interactive-range "Catchup" - (cons (point-min) (point-max))))) - (mh-delete-msg-from-seq range mh-unseen-seq)) - -(defun mh-delete-a-msg-from-seq (msg sequence internal-flag) - "Delete MSG from SEQUENCE. -If INTERNAL-FLAG is non-nil, then do not inform MH of the -change." - (let ((entry (mh-find-seq sequence))) - (when (and entry (memq msg (mh-seq-msgs entry))) - (if (not internal-flag) - (mh-undefine-sequence sequence (list msg))) - (setcdr entry (delq msg (mh-seq-msgs entry)))))) - -(defun mh-undefine-sequence (seq msgs) - "Remove from the SEQ the list of MSGS." - (when (and (mh-valid-seq-p seq) msgs) - (apply #'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 SEQ to contain the list of MSGS. -Do not mark pseudo-sequences or empty sequences. -Signals an error if SEQ is an invalid name." - (if (and msgs - (mh-valid-seq-p seq) - (not (mh-folder-name-p seq))) - (save-excursion - (mh-exec-cmd-error nil "mark" mh-current-folder "-add" "-zero" - "-sequence" (symbol-name seq) - (mh-coalesce-msg-list msgs))))) - -(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-flag - (not (mh-internal-seq (mh-seq-name (car l))))) - (setq seqs (cons (mh-seq-name (car l)) seqs))) - (setq l (cdr l))) - seqs)) +;;; Identities (:group 'mh-identity) + +(eval-and-compile + (unless (fboundp 'mh-identity-make-menu-no-autoload) + (defun mh-identity-make-menu-no-autoload () + "Temporary definition. +Real definition will take effect when mh-identity is loaded." + nil))) + +(defcustom mh-identity-list nil + "*List of identities. + +To customize this option, click on the \"INS\" button and enter a label +such as \"Home\" or \"Work\". Then click on the \"INS\" button with the +label \"Add at least one item below\". Then choose one of the items in +the \"Value Menu\". + +You can specify an alternate \"From:\" header field using the \"From +Field\" menu item. You must include a valid email address. A standard +format is \"First Last <login@@host.domain>\". If you use an initial +with a period, then you must quote your name as in '\"First I. Last\" +<login@@host.domain>'. People usually list the name of the company +where they work using the \"Organization Field\" menu item. Set any +arbitrary header field and value in the \"Other Field\" menu item. +Unless the header field is a standard one, precede the name of your +field's label with \"X-\", as in \"X-Fruit-of-the-Day:\". The value of +\"Attribution Verb\" overrides the setting of +`mh-extract-from-attribution-verb'. Set your signature with the +\"Signature\" menu item. You can specify the contents of +`mh-signature-file-name', a file, or a function. Specify a different +key to sign or encrypt messages with the \"GPG Key ID\" menu item. + +You can select the identities you have added via the menu called +\"Identity\" in the MH-Letter buffer. You can also use +\\[mh-insert-identity]. To clear the fields and signature added by the +identity, select the \"None\" identity. + +The \"Identity\" menu contains two other items to save you from having +to set the identity on every message. The menu item \"Set Default for +Session\" can be used to set the default identity to the current +identity until you exit Emacs. The menu item \"Save as Default\" sets +the option `mh-identity-default' to the current identity setting. You +can also customize the `mh-identity-default' option in the usual +fashion." + :type '(repeat (list :tag "" + (string :tag "Label") + (repeat :tag "Add at least one item below" + (choice + (cons :tag "From Field" + (const "From") + (string :tag "Value")) + (cons :tag "Organization Field" + (const "Organization") + (string :tag "Value")) + (cons :tag "Other Field" + (string :tag "Field") + (string :tag "Value")) + (cons :tag "Attribution Verb" + (const ":attribution-verb") + (string :tag "Value")) + (cons :tag "Signature" + (const :tag "Signature" + ":signature") + (choice + (const :tag "mh-signature-file-name" + nil) + (file) + (function))) + (cons :tag "GPG Key ID" + (const :tag "GPG Key ID" + ":pgg-default-user-id") + (string :tag "Value")))))) + :set (lambda (symbol value) + (set-default symbol value) + (mh-identity-make-menu-no-autoload)) + :group 'mh-identity) + +(defcustom mh-auto-fields-list nil + "List of recipients for which header lines are automatically inserted. + +This option can be used to set the identity depending on the +recipient. To customize this option, click on the \"INS\" button and +enter a regular expression for the recipient's address. Click on the +\"INS\" button with the \"Add at least one item below\" label. Then choose +one of the items in the \"Value Menu\". + +The \"Identity\" menu item is used to select an identity from those +configured in `mh-identity-list'. All of the information for that +identity will be added if the recipient matches. The \"Fcc Field\" menu +item is used to select a folder that is used in the \"Fcc:\" header. +When you send the message, MH will put a copy of your message in this +folder. The \"Mail-Followup-To Field\" menu item is used to insert an +\"Mail-Followup-To:\" header field with the recipients you provide. If +the recipient's mail user agent supports this header field (as nmh +does), then their replies will go to the addresses listed. This is +useful if their replies go both to the list and to you and you don't +have a mechanism to suppress duplicates. If you reply to someone not +on the list, you must either remove the \"Mail-Followup-To:\" field, or +ensure the recipient is also listed there so that he receives replies +to your reply. Other header fields may be added using the \"Other +Field\" menu item. + +These fields can only be added after the recipient is known. Once the +header contains one or more recipients, run the +\\[mh-insert-auto-fields] command or choose the \"Identity -> Insert +Auto Fields\" menu item to insert these fields manually. However, you +can just send the message and the fields will be added automatically. +You are given a chance to see these fields and to confirm them before +the message is actually sent. You can do away with this confirmation +by turning off the option `mh-auto-fields-prompt-flag'. + +You should avoid using the same header field in `mh-auto-fields-list' +and `mh-identity-list' definitions that may apply to the same message +as the result is undefined." + :type `(repeat + (list :tag "" + (string :tag "Recipient") + (repeat :tag "Add at least one item below" + (choice + (cons :tag "Identity" + (const ":identity") + ,(append + '(radio) + (mapcar + (function (lambda (arg) `(const ,arg))) + (mapcar 'car mh-identity-list)))) + (cons :tag "Fcc Field" + (const "fcc") + (string :tag "Value")) + (cons :tag "Mail-Followup-To Field" + (const "Mail-Followup-To") + (string :tag "Value")) + (cons :tag "Other Field" + (string :tag "Field") + (string :tag "Value")))))) + :group 'mh-identity) + +(defcustom mh-auto-fields-prompt-flag t + "*Non-nil means to prompt before sending if fields inserted. +See `mh-auto-fields-list'." + :type 'boolean + :group 'mh-identity) + +(defcustom mh-identity-default nil + "Default identity to use when `mh-letter-mode' is called. +See `mh-identity-list'." + :type (append + '(radio) + (cons '(const :tag "None" nil) + (mapcar (function (lambda (arg) `(const ,arg))) + (mapcar 'car mh-identity-list)))) + :group 'mh-identity) + +(defcustom mh-identity-handlers + '(("From" . mh-identity-handler-top) + (":default" . mh-identity-handler-bottom) + (":attribution-verb" . mh-identity-handler-attribution-verb) + (":signature" . mh-identity-handler-signature) + (":pgg-default-user-id" . mh-identity-handler-gpg-identity)) + "Handler functions for fields in `mh-identity-list'. + +This option is used to change the way that fields, signatures, +and attributions in `mh-identity-list' are added. To customize +`mh-identity-handlers', replace the name of an existing handler +function associated with the field you want to change with the +name of a function you have written. You can also click on an +\"INS\" button and insert a field of your choice and the name of +the function you have written to handle it. + +The \"Field\" field can be any field that you've used in your +`mh-identity-list'. The special fields \":attribution-verb\", +\":signature\", or \":pgg-default-user-id\" are used for the +`mh-identity-list' choices \"Attribution Verb\", \"Signature\", and +\"GPG Key ID\" respectively. + +The handler associated with the \":default\" field is used when no +other field matches. + +The handler functions are passed two or three arguments: the +FIELD itself (for example, \"From\"), or one of the special +fields (for example, \":signature\"), and the ACTION 'remove or +'add. If the action is 'add, an additional argument +containing the VALUE for the field is given." + :type '(repeat (cons (string :tag "Field") function)) + :group 'mh-identity) + + + +;;; Incorporating Your Mail (:group 'mh-inc) + +(defcustom mh-inc-prog "inc" + "*Program to incorporate new mail into a folder. + +This program generates a one-line summary for each of the new +messages. Unless it is an absolute pathname, the file is assumed +to be in the `mh-progs' directory. You may also link a file to +\"inc\" that uses a different format. You'll then need to modify +several scan line format variables appropriately." + :type 'string + :group 'mh-inc) + +(eval-and-compile + (unless (fboundp 'mh-inc-spool-make-no-autoload) + (defun mh-inc-spool-make-no-autoload () + "Temporary definition. +Real definition will take effect when mh-inc is loaded." + nil))) + +(defcustom mh-inc-spool-list nil + "*Alternate spool files. + +You can use the `mh-inc-spool-list' variable to direct MH-E to +retrieve mail from arbitrary spool files other than your system +mailbox, file it in folders other than your \"+inbox\", and assign +key bindings to incorporate this mail. + +Suppose you are subscribed to the \"mh-e-devel\" mailing list and +you use \"procmail\" to filter this mail into \"~/mail/mh-e\" with +the following recipe in \".procmailrc\": + + MAILDIR=$HOME/mail + :0: + * ^From mh-e-devel-admin@stop.mail-abuse.org + mh-e + +In order to incorporate \"~/mail/mh-e\" into \"+mh-e\" with an +\"I m\" (mh-inc-spool-mh-e) command, customize this option, and click +on the \"INS\" button. Enter a \"Spool File\" of \"~/mail/mh-e\", a +\"Folder\" of \"mh-e\", and a \"Key Binding\" of \"m\". + +You can use \"xbuffy\" to automate the incorporation of this mail +using the \"gnudoit\" command in the \"gnuserv\" package as follows: + + box ~/mail/mh-e + title mh-e + origMode + polltime 10 + headertime 0 + command gnudoit -q '(mh-inc-spool-mh-e)'" + :type '(repeat (list (file :tag "Spool File") + (string :tag "Folder") + (character :tag "Key Binding"))) + :set (lambda (symbol value) + (set-default symbol value) + (mh-inc-spool-make-no-autoload)) + :group 'mh-inc) + + + +;;; Dealing with Junk Mail (:group 'mh-junk) + +(defvar mh-junk-choice nil + "Chosen spam fighting program.") + +;; Available spam filter interfaces +(defvar mh-junk-function-alist + '((spamassassin mh-spamassassin-blacklist mh-spamassassin-whitelist) + (bogofilter mh-bogofilter-blacklist mh-bogofilter-whitelist) + (spamprobe mh-spamprobe-blacklist mh-spamprobe-whitelist)) + "Available choices of spam programs to use. + +This is an alist. For each element there are functions that +blacklist a message as spam and whitelist a message incorrectly +classified as spam.") + +(defun mh-junk-choose (symbol value) + "Choose spam program to use. + +The function is always called with SYMBOL bound to +`mh-junk-program' and VALUE bound to the new value of +`mh-junk-program'. The function sets the variable +`mh-junk-choice' in addition to `mh-junk-program'." + (set symbol value) ;XXX shouldn't this be set-default? + (setq mh-junk-choice + (or value + (loop for element in mh-junk-function-alist + until (executable-find (symbol-name (car element))) + finally return (car element))))) + +(defcustom mh-junk-background nil + "If on, spam programs are run in background. + +By default, the programs are run in the foreground, but this can +be slow when junking large numbers of messages. If you have +enough memory or don't junk that many messages at the same time, +you might try turning on this option." + :type '(choice (const :tag "Off" nil) + (const :tag "On" 0)) + :group 'mh-junk) + +(defcustom mh-junk-disposition nil + "Disposition of junk mail." + :type '(choice (const :tag "Delete Spam" nil) + (string :tag "Spam Folder")) + :group 'mh-junk) + +(defcustom mh-junk-program nil + "Spam program that MH-E should use. + +The default setting of this option is \"Auto-detect\" which means +that MH-E will automatically choose one of SpamAssassin, +bogofilter, or SpamProbe in that order. If, for example, you have +both SpamAssassin and bogofilter installed and you want to use +bogofilter, then you can set this option to \"Bogofilter\"." + :type '(choice (const :tag "Auto-detect" nil) + (const :tag "SpamAssassin" spamassassin) + (const :tag "Bogofilter" bogofilter) + (const :tag "SpamProbe" spamprobe)) + :set 'mh-junk-choose + :group 'mh-junk) + + + +;;; Editing a Draft (:group 'mh-letter) + +(defcustom mh-compose-insertion (if (locate-library "mml") 'mml 'mh) + "Type of tags used when composing MIME messages. + +In addition to MH-style directives, MH-E also supports MML (MIME +Meta Language) tags. (see Info node `(emacs-mime)Composing'). +This option can be used to choose between them. By default, this +option is set to \"MML\" if it is supported since it provides a +lot more functionality. This option can also be set to \"MH\" if +MH-style directives are preferred." + :type '(choice (const :tag "MML" mml) + (const :tag "MH" mh)) + :group 'mh-letter) + +(defcustom mh-compose-skipped-header-fields + '("From" "Organization" "References" "In-Reply-To" + "X-Face" "Face" "X-Image-URL" "X-Mailer") + "List of header fields to skip over when navigating in draft." + :type '(repeat (string :tag "Field")) + :group 'mh-letter) + +(defcustom mh-compose-space-does-completion-flag nil + "*Non-nil means \\<mh-letter-mode-map>\\[mh-letter-complete-or-space] does completion in message header." + :type 'boolean + :group 'mh-letter) + +(defcustom mh-delete-yanked-msg-window-flag nil + "*Non-nil means delete any window displaying the message. + +This deletes the window containing the original message after +yanking it with \\<mh-letter-mode-map>\\[mh-yank-cur-msg] to make +more room on your screen for your reply." + :type 'boolean + :group 'mh-letter) + +(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]. + +The attribution consists of the sender's name and email address +followed by the content of this option. This option can be set to +\"wrote:\", \"a écrit:\", and \"schrieb:\". You can also use the +\"Custom String\" menu item to enter your own verb." + :type '(choice (const "wrote:") + (const "a écrit:") + (const "schrieb:") + (string :tag "Custom String")) + :group 'mh-letter) + +(defcustom mh-ins-buf-prefix "> " + "*String to put before each line of a yanked or inserted message. + +The prefix \"> \" is the default setting of this option. I +suggest that you not modify this option since it is used by many +mailers and news readers: messages are far easier to read if +several included messages have all been indented by the same +string. + +This prefix is not inserted if you use one of the supercite +flavors of `mh-yank-behavior' or you have added a +`mail-citation-hook'." + :type 'string + :group 'mh-letter) + +(defcustom mh-letter-complete-function 'ispell-complete-word + "*Function to call when completing outside of address or folder fields. + +In the body of the message, +\\<mh-letter-mode-map>\\[mh-letter-complete] runs this function, +which is set to \"ispell-complete-word\" by default." + :type '(choice function (const nil)) + :group 'mh-letter) + +(defcustom mh-letter-fill-column 72 + "*Fill column to use in MH Letter mode. + +By default, this option is 72 to allow others to quote your +message without line wrapping." + :type 'integer + :group 'mh-letter) + +(defcustom mh-mml-method-default (if mh-pgp-support-flag "pgpmime" "none") + "Default method to use in security tags. + +This option is used to select between a variety of mail security +mechanisms. The default is \"PGP (MIME)\" if it is supported\; +otherwise, the default is \"None\". Other mechanisms include +vanilla \"PGP\" and \"S/MIME\". + +The `pgg' customization group may have some settings which may +interest you (see Info node `(pgg)'). + +In particular, I turn on the option `pgg-encrypt-for-me' so that +all messages I encrypt are encrypted with my public key as well. +If you keep a copy of all of your outgoing mail with a \"Fcc:\" +header field, this setting is vital so that you can read the mail +you write!" + :type '(choice (const :tag "PGP (MIME)" "pgpmime") + (const :tag "PGP" "pgp") + (const :tag "S/MIME" "smime") + (const :tag "None" "none")) + :group 'mh-letter) + +(defcustom mh-signature-file-name "~/.signature" + "*Source of user's signature. + +By default, the text of your signature is taken from the file +\"~/.signature\". You can read from other sources by changing this +option. This file may contain a vCard in which case an attachment is +added with the vCard. + +This option may also be a symbol, in which case that function is +called. You may not want a signature separator to be added for you; +instead you may want to insert one yourself. Options that you may find +useful to do this include `mh-signature-separator' (when inserting a +signature separator) and `mh-signature-separator-regexp' (for finding +said separator). The function `mh-signature-separator-p', which +reports t if the buffer contains a separator, may be useful as well. + +The signature is inserted into your message with the command +\\<mh-letter-mode-map>\\[mh-insert-signature] or with the option +`mh-identity-list'." + :type 'file + :group 'mh-letter) + +(defcustom mh-signature-separator-flag t + "*Non-nil means a signature separator should be inserted. + +It is not recommended that you change this option since various +mail user agents, including MH-E, use the separator to present +the signature differently, and to suppress the signature when +replying or yanking a letter into a draft." + :type 'boolean + :group 'mh-letter) + +(defcustom mh-x-face-file "~/.face" + "*File containing face header field to insert in outgoing mail. + +If the file starts with either of the strings \"X-Face:\", \"Face:\" +or \"X-Image-URL:\" then the contents are added to the message header +verbatim. Otherwise it is assumed that the file contains the value of +the \"X-Face:\" header field. + +The \"X-Face:\" header field, which is a low-resolution, black and +white image, can be generated using the \"compface\" command (see URL +`ftp://ftp.cs.indiana.edu/pub/faces/compface/compface.tar.Z'). The +\"Online X-Face Converter\" is a useful resource for quick conversion +of images into \"X-Face:\" header fields (see URL +`http://www.dairiki.org/xface/'). + +Use the \"make-face\" script to convert a JPEG image to the higher +resolution, color, \"Face:\" header field (see URL +`http://quimby.gnus.org/circus/face/make-face'). + +The URL of any image can be used for the \"X-Image-URL:\" field and no +processing of the image is required. + +To prevent the setting of any of these header fields, either set +`mh-x-face-file' to nil, or simply ensure that the file defined by +this option doesn't exist." + :type 'file + :group 'mh-letter) + +(defcustom mh-yank-behavior 'attribution + "*Controls which part of a message is yanked by \\<mh-letter-mode-map>\\[mh-yank-cur-msg]. + +To include the entire message, including the entire header, use +\"Body and Header\". Use \"Body\" to yank just the body without +the header. To yank only the portion of the message following the +point, set this option to \"Below Point\". + +Choose \"Invoke supercite\" to pass the entire message and header +through supercite. + +If the \"Body With Attribution\" setting is used, then the +message minus the header is yanked and a simple attribution line +is added at the top using the value of the option +`mh-extract-from-attribution-verb'. This is the default. + +If the \"Invoke supercite\" or \"Body With Attribution\" settings +are used, the \"-noformat\" argument is passed to the \"repl\" +program to override a \"-filter\" or \"-format\" argument. These +settings also have \"Automatically\" variants that perform the +action automatically when you reply so that you don't need to use +\\[mh-yank-cur-msg] at all. Note that this automatic action is +only performed if the show buffer matches the message being +replied to. People who use the automatic variants tend to turn on +the option `mh-delete-yanked-msg-window-flag' as well so that the +show window is never displayed. + +If the show buffer has a region, the option `mh-yank-behavior' is +ignored unless its value is one of Attribution variants in which +case the attribution is added to the yanked region. + +If this option is set to one of the supercite flavors, the hook +`mail-citation-hook' is ignored and `mh-ins-buf-prefix' is not +inserted." + :type '(choice (const :tag "Body and Header" t) + (const :tag "Body" body) + (const :tag "Below Point" nil) + (const :tag "Invoke supercite" supercite) + (const :tag "Invoke supercite, Automatically" autosupercite) + (const :tag "Body With Attribution" attribution) + (const :tag "Body With Attribution, Automatically" + autoattrib)) + :group 'mh-letter) + + + +;;; Ranges (:group 'mh-ranges) + +(defcustom mh-interpret-number-as-range-flag t + "*Non-nil means interpret a number as a range. + +Since one of the most frequent ranges used is \"last:N\", MH-E +will interpret input such as \"200\" as \"last:200\" if this +option is on (which is the default). If you need to scan just the +message 200, then use the range \"200:200\"." + :type 'boolean + :group 'mh-ranges) + + + +;;; Scan Line Formats (:group 'mh-scan-line-formats) + +(eval-and-compile + (unless (fboundp 'mh-adaptive-cmd-note-flag-check) + (defun mh-adaptive-cmd-note-flag-check (symbol value) + "Temporary definition. +Real definition, below, uses variables that aren't defined yet." + (set-default symbol value)))) + +(defcustom mh-adaptive-cmd-note-flag t + "*Non-nil means that the message number width is determined dynamically. + +If you've created your own format to handle long message numbers, +you'll be pleased to know you no longer need it since MH-E adapts its +internal format based upon the largest message number if this option +is on (the default). This option may only be turned on when +`mh-scan-format-file' is set to \"Use MH-E scan Format\". + +If you prefer fixed-width message numbers, turn off this option and +call `mh-set-cmd-note' with the width specified by your format file +\(see `mh-scan-format-file'). For example, the default width is 4, so +you would use \"(mh-set-cmd-note 4)\"." + :type 'boolean + :group 'mh-scan-line-formats + :set 'mh-adaptive-cmd-note-flag-check) + +(defun mh-scan-format-file-check (symbol value) + "Check if desired setting is legal. +Throw an error if user tries to set `mh-scan-format-file' to +anything but t when `mh-adaptive-cmd-note-flag' is on. Otherwise, +set SYMBOL to VALUE." + (if (and (not (eq value t)) + (eq mh-adaptive-cmd-note-flag t)) + (error "%s %s" "You must turn off `mh-adaptive-cmd-note-flag'" + "unless you use \"Use MH-E scan Format\"") + (set-default symbol value))) + +(defcustom mh-scan-format-file t + "Specifies the format file to pass to the scan program. + +The default setting for this option is \"Use MH-E scan Format\". This +means that the format string will be taken from the either +`mh-scan-format-mh' or `mh-scan-format-nmh' depending on whether MH or +nmh (or GNU mailutils) is in use. This setting also enables you to +turn on the `mh-adaptive-cmd-note-flag' option. + +You can also set this option to \"Use Default scan Format\" to get the +same output as you would get if you ran \"scan\" from the shell. If +you have a format file that you want MH-E to use but not MH, you can +set this option to \"Specify a scan Format File\" and enter the name +of your format file. + +If you change the format of the scan lines you'll need to tell MH-E +how to parse the new format. As you will see, quite a lot of variables +are involved to do that. Use \"\\[apropos] RET mh-scan.*regexp\" to +obtain a list of these variables. You will also have to call +`mh-set-cmd-note' if your notations are not in column 4 (columns in +Emacs start with 0)." + :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-scan-line-formats + :set 'mh-scan-format-file-check) + +(defun mh-adaptive-cmd-note-flag-check (symbol value) + "Check if desired setting is legal. +Throw an error if user tries to turn on +`mh-adaptive-cmd-note-flag' when `mh-scan-format-file' isn't t. +Otherwise, set SYMBOL to VALUE." + (if (and value + (not (eq mh-scan-format-file t))) + (error "%s %s" "Can't turn on unless `mh-scan-format-file'" + "is set to \"Use MH-E scan Format\"") + (set-default symbol value))) + +(defcustom mh-scan-prog "scan" + "*Program used to scan messages. + +The name of the program that generates a listing of one line per +message is held in this option. Unless this variable contains an +absolute pathname, it is assumed to be in the `mh-progs' +directory. You may link another program to `scan' (see +\"mh-profile(5)\") to produce a different type of listing." + :type 'string + :group 'mh-scan-line-formats) +(make-variable-buffer-local 'mh-scan-prog) + + + +;;; Searching (:group 'mh-search) + +(defcustom mh-search-program nil + "Search program that MH-E shall use. + +The default setting of this option is \"Auto-detect\" which means +that MH-E will automatically choose one of swish++, swish-e, +mairix, namazu, pick and grep in that order. If, for example, you +have both swish++ and mairix installed and you want to use +mairix, then you can set this option to \"mairix\". + +More information about setting up an indexing program to use with +MH-E can be found in the documentation of `mh-search'." + :type '(choice (const :tag "Auto-detect" nil) + (const :tag "swish++" swish++) + (const :tag "swish-e" swish) + (const :tag "mairix" mairix) + (const :tag "namazu" namazu) + (const :tag "pick" pick) + (const :tag "grep" grep)) + :group 'mh-search) + + + +;;; Sending Mail (:group 'mh-sending-mail) + +(defcustom mh-compose-forward-as-mime-flag t + "*Non-nil means that messages are forwarded as attachments. + +By default, this option is on which means that the forwarded +messages are included as attachments. If you would prefer to +forward your messages verbatim (as text, inline), then turn off +this option. Forwarding messages verbatim works well for short, +textual messages, but your recipient won't be able to view any +non-textual attachments that were in the forwarded message. Be +aware that if you have \"forw: -mime\" in your MH profile, then +forwarded messages will always be included as attachments +regardless of the settings of this option." + :type 'boolean + :group 'mh-sending-mail) + +(defcustom mh-compose-letter-function nil + "Invoked when starting a new draft. + +However, it is the last function called before you edit your +message. The consequence of this is that you can write a function +to write and send the message for you. This function is passed +three arguments: the contents of the TO, SUBJECT, and CC header +fields." + :type '(choice (const nil) function) + :group 'mh-sending-mail) + +(defcustom mh-compose-prompt-flag nil + "*Non-nil means prompt for header fields when composing a new draft." + :type 'boolean + :group 'mh-sending-mail) + +(defcustom mh-forward-subject-format "%s: %s" + "*Format string for forwarded message subject. + +This option is a string which includes two escapes (\"%s\"). The +first \"%s\" is replaced with the sender of the original message, +and the second one is replaced with the original \"Subject:\"." + :type 'string + :group 'mh-sending-mail) + +(defcustom mh-insert-x-mailer-flag t + "*Non-nil means append an \"X-Mailer:\" header field to the header. + +This header field includes the version of MH-E and Emacs that you +are using. If you don't want to participate in our marketing, you +can turn this option off." + :type 'boolean + :group 'mh-sending-mail) + +(defcustom mh-redist-full-contents-flag nil + "*Non-nil means the \"dist\" command needs entire letter for redistribution. + +This option must be turned on if \"dist\" requires the whole +letter for redistribution, which is the case if \"send\" is +compiled with the BERK option (which many people abhor). If you +find that MH will not allow you to redistribute a message that +has been redistributed before, turn off this option." + :type 'boolean + :group 'mh-sending-mail) + +(defcustom mh-reply-default-reply-to nil + "*Sets the person or persons to whom a reply will be sent. + +This option is set to \"Prompt\" by default so that you are +prompted for the recipient of a reply. If you find that most of +the time that you specify \"cc\" when you reply to a message, set +this option to \"cc\". Other choices include \"from\", \"to\", or +\"all\". You can always edit the recipients in the draft." + :type '(choice (const :tag "Prompt" nil) + (const "from") + (const "to") + (const "cc") + (const "all")) + :group 'mh-sending-mail) + +(defcustom mh-reply-show-message-flag t + "*Non-nil means the MH-Show buffer is displayed when replying. + +If you include the message automatically, you can hide the +MH-Show buffer by turning off this option. + +See also `mh-reply'." + :type 'boolean + :group 'mh-sending-mail) + + + +;;; Sequences (:group 'mh-sequences) + +;; If `mh-unpropagated-sequences' becomes a defcustom, add the following to +;; the docstring: "Additional sequences that should not to be preserved can be +;; specified by setting `mh-unpropagated-sequences' appropriately." XXX + +(defcustom mh-refile-preserves-sequences-flag t + "*Non-nil means that sequences are preserved when messages are refiled. + +If a message is in any sequence (except \"Previous-Sequence:\" +and \"cur\") when it is refiled, then it will still be in those +sequences in the destination folder. If this behavior is not +desired, then turn off this option." + :type 'boolean + :group 'mh-sequences) + +(defcustom mh-tick-seq 'tick + "The name of the MH sequence for ticked messages. + +You can customize this option if you already use the \"tick\" +sequence for your own use. You can also disable all of the +ticking functions by choosing the \"Disable Ticking\" item but +there isn't much advantage to that." + :type '(choice (const :tag "Disable Ticking" nil) + symbol) + :group 'mh-sequences) + +(defcustom mh-update-sequences-after-mh-show-flag t + "*Non-nil means flush MH sequences to disk after message is shown\\<mh-folder-mode-map>. + +Three sequences are maintained internally by MH-E and pushed out +to MH when a message is shown. They include the sequence +specified by your \"Unseen-Sequence:\" profile entry, \"cur\", +and the sequence listed by the option `mh-tick-seq' which is +\"tick\" by default. If you do not like this behavior, turn off +this option. You can then update the state manually with the +\\[mh-execute-commands], \\[mh-quit], or \\[mh-update-sequences] +commands." + :type 'boolean + :group 'mh-sequences) + + + +;;; Reading Your Mail (:group 'mh-show) + +(defcustom mh-bury-show-buffer-flag t + "*Non-nil means show buffer is buried. + +One advantage of not burying the show buffer is that one can +delete the show buffer more easily in an electric buffer list +because of its proximity to its associated MH-Folder buffer. Try +running \\[electric-buffer-list] to see what I mean." + :type 'boolean + :group 'mh-show) + +(defcustom mh-clean-message-header-flag t + "*Non-nil means remove extraneous header fields. + +See also `mh-invisible-header-fields-default' and +`mh-invisible-header-fields'." + :type 'boolean + :group 'mh-show) + +(defcustom mh-decode-mime-flag (not (not (locate-library "mm-decode"))) + "*Non-nil means attachments are handled\\<mh-folder-mode-map>. + +MH-E can handle attachments as well if the Gnus `mm-decode' +library is present. If so, this option will be on. Otherwise, +you'll see the MIME body parts rather than text or attachments. +There isn't much point in turning off this option; however, you +can inspect it if it appears that the body parts are not being +interpreted correctly or toggle it with the command +\\[mh-toggle-mh-decode-mime-flag] to view the raw message. + +This option also controls the display of quoted-printable +messages and other graphical widgets. See the options +`mh-graphical-smileys-flag' and `mh-graphical-emphasis-flag'." + :type 'boolean + :group 'mh-show) + +(defcustom mh-display-buttons-for-alternatives-flag nil + "*Non-nil means display buttons for all alternative attachments. + +Sometimes, a mail program will produce multiple alternatives of +the attachment in increasing degree of faithfulness to the +original content. By default, only the preferred alternative is +displayed. If this option is on, then the preferred part is shown +inline and buttons are shown for each of the other alternatives." + :type 'boolean + :group 'mh-show) + +(defcustom mh-display-buttons-for-inline-parts-flag nil + "*Non-nil means display buttons for all inline attachments\\<mh-folder-mode-map>. + +The sender can request that attachments should be viewed inline so +that they do not really appear like an attachment at all to the +reader. Most of the time, this is desirable, so by default MH-E +suppresses the buttons for inline attachments. On the other hand, you +may receive code or HTML which the sender has added to his message as +inline attachments so that you can read them in MH-E. In this case, it +is useful to see the buttons so that you know you don't have to cut +and paste the code into a file; you can simply save the attachment. + +If you want to make the buttons visible for inline attachments, you +can use the command \\[mh-toggle-mime-buttons] to toggle the +visibility of these buttons. You can turn on these buttons permanently +by turning on this option. + +MH-E cannot display all attachments inline however. It can display +text (including HTML) and images." + :type 'boolean + :group 'mh-show) + +(defcustom mh-do-not-confirm-flag nil + "*Non-nil means non-reversible commands 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. +Turning on this option means that these actions will be +performed--which is usually desired but cannot be +retracted--without question." + :type 'boolean + :group 'mh-show) + +(defcustom mh-fetch-x-image-url nil + "*Control fetching of \"X-Image-URL:\" header field image. + +Ths option controls the fetching of the \"X-Image-URL:\" header +field image with the following values: + +Ask Before Fetching + You are prompted before the image is fetched. MH-E will + remember your reply and will either use the already fetched + image the next time the same URL is encountered or silently + skip it if you didn't fetch it the first time. This is a + good setting. + +Never Fetch + Images are never fetched and only displayed if they are + already present in the cache. This is the default. + +There isn't a value of \"Always Fetch\" for privacy and DOS (denial of +service) reasons. For example, fetching a URL can tip off a spammer +that you've read his email (which is why you shouldn't blindly answer +yes if you've set this option to \"Ask Before Fetching\"). Someone may +also flood your network and fill your disk drive by sending a torrent +of messages, each specifying a unique URL to a very large file. + +The cache of images is found in the directory \".mhe-x-image-cache\" +within your MH directory. You can add your own face to the \"From:\" +field too. See Info node `(mh-e)Picture'. + +This setting only has effect if the option `mh-show-use-xface-flag' is +turned on." + + :type '(choice (const :tag "Ask Before Fetching" ask) + (const :tag "Never Fetch" nil)) + :group 'mh-show) + +(defcustom mh-graphical-smileys-flag t + "*Non-nil means graphical smileys are displayed. + +It is a long standing custom to inject body language using a +cornucopia of punctuation, also known as the \"smileys\". MH-E +can render these as graphical widgets if this option is turned +on, which it is by default. Smileys include patterns such as :-) +and ;-). + +This option is disabled if the option `mh-decode-mime-flag' is +turned off." + :type 'boolean + :group 'mh-show) + +(defcustom mh-graphical-emphasis-flag t + "*Non-nil means graphical emphasis is displayed. + +A few typesetting features are indicated in ASCII text with +certain characters. If your terminal supports it, MH-E can render +these typesetting directives naturally if this option is turned +on, which it is by default. For example, _underline_ will be +underlined, *bold* will appear in bold, /italics/ will appear in +italics, and so on. See the option `gnus-emphasis-alist' for the +whole list. + +This option is disabled if the option `mh-decode-mime-flag' is +turned off." + :type 'boolean + :group 'mh-show) + +(defcustom mh-highlight-citation-style 'gnus + "Style for highlighting citations. + +If the sender of the message has cited other messages in his +message, then MH-E will highlight these citations to emphasize +the sender's actual response. This option can be customized to +change the highlighting style. The \"Multicolor\" method uses a +different color for each indentation while the \"Monochrome\" +method highlights all citations in red. To disable highlighting +of citations entirely, choose \"None\"." + :type '(choice (const :tag "Multicolor" gnus) + (const :tag "Monochrome" font-lock) + (const :tag "None" nil)) + :group 'mh-show) + +;; Keep fields alphabetized. Mention source, if known. +(defvar mh-invisible-header-fields-internal + '("Approved:" + "Autoforwarded:" + "Bestservhost:" + "Cancel-Lock:" ; NNTP posts + "Content-" ; RFC 2045 + "Delivered-To:" ; Egroups/yahoogroups mailing list manager + "Delivery-Date:" ; MH + "Delivery:" + "DomainKey-Signature:" ;http://antispam.yahoo.com/domainkeys + "Encoding:" + "Envelope-to:" + "Errors-To:" + "Face:" ; Gnus Face header + "Forwarded:" ; MH + "From " ; sendmail + "Importance:" ; MS Outlook + "In-Reply-To:" ; MH + "Lines:" + "List-" ; Mailman mailing list manager + "List-" ; Unknown mailing list managers + "List-Subscribe:" ; Unknown mailing list managers + "List-Unsubscribe:" ; Unknown mailing list managers + "Mail-from:" ; MH + "Mailing-List:" ; Egroups/yahoogroups mailing list manager + "Message-Id:" ; RFC 822 + "Mime-Version" ; RFC 2045 + "NNTP-" ; News + "Old-Return-Path:" + "Original-Encoded-Information-Types:" ; X400 + "Original-Lines:" ; mail to news + "Original-NNTP-" ; mail to news + "Original-Newsgroups:" ; mail to news + "Original-Path:" ; mail to news + "Original-Received:" ; mail to news + "Original-To:" ; mail to news + "Original-X-" ; mail to news + "Originator:" + "P1-Content-Type:" ; X400 + "P1-Message-Id:" ; X400 + "P1-Recipient:" ; X400 + "Path:" + "Precedence:" + "Prev-Resent" ; MH + "Priority:" + "Received:" ; RFC 822 + "Received-SPF:" ; Gmail + "References:" + "Remailed-" ; MH + "Replied:" ; MH + "Resent" ; MH + "Return-Path:" ; RFC 822 + "Sensitivity:" ; MS Outlook + "Status:" ; sendmail + "Thread-" + "Ua-Content-Id:" ; X400 +;; "User-Agent:" ; Similar to X-Mailer, so display it. + "Via:" ; MH + "X-Abuse-Info:" + "X-Abuse-and-DMCA-" + "X-Accept-Language:" + "X-Accept-Language:" ; Netscape/Mozilla + "X-Ack:" + "X-Administrivia-To:" + "X-AntiAbuse:" ; cPanel + "X-Apparently-From:" ; MS Outlook + "X-Apparently-To:" ; Egroups/yahoogroups mailing list manager + "X-Authentication-Warning:" ; sendmail + "X-Beenthere:" ; Mailman mailing list manager + "X-Bogosity:" ; bogofilter + "X-Bugzilla-*" ; Bugzilla + "X-Complaints-To:" + "X-ContentStamp:" ; NetZero + "X-Cron-Env:" + "X-DMCA" + "X-Delivered" + "X-ELNK-Trace:" ; Earthlink mailer + "X-Envelope-Date:" ; GNU mailutils + "X-Envelope-From:" + "X-Envelope-Sender:" + "X-Envelope-To:" + "X-Evolution:" ; Evolution mail client + "X-Face:" + "X-Folder:" ; Spam + "X-From-Line" + "X-Gmail-" ; Gmail + "X-Gnus-Mail-Source:" ; gnus + "X-Greylist:" ; milter-greylist-1.2.1 + "X-Habeas-SWE-1:" ; Spam + "X-Habeas-SWE-2:" ; Spam + "X-Habeas-SWE-3:" ; Spam + "X-Habeas-SWE-4:" ; Spam + "X-Habeas-SWE-5:" ; Spam + "X-Habeas-SWE-6:" ; Spam + "X-Habeas-SWE-7:" ; Spam + "X-Habeas-SWE-8:" ; Spam + "X-Habeas-SWE-9:" ; Spam + "X-Info:" ; NTMail + "X-Juno-" ; Juno + "X-List-Host:" ; Unknown mailing list managers + "X-List-Subscribe:" ; Unknown mailing list managers + "X-List-Unsubscribe:" ; Unknown mailing list managers + "X-Listprocessor-" ; ListProc(tm) by CREN + "X-Listserver:" ; Unknown mailing list managers + "X-Loop:" ; Unknown mailing list managers + "X-Lumos-SenderID:" ; Roving ConstantContact + "X-MAIL-INFO:" ; NetZero + "X-MHE-Checksum" ; Checksum added during index search + "X-MIME-Autoconverted:" ; sendmail + "X-MIMETrack:" + "X-MS-" ; MS Outlook + "X-MailScanner" ; ListProc(tm) by CREN + "X-Mailing-List:" ; Unknown mailing list managers + "X-Mailman-Version:" ; Mailman mailing list manager + "X-Majordomo:" ; Majordomo mailing list manager + "X-Message-Id" + "X-MessageWall-Score:" ; Unknown mailing list manager, AUC TeX + "X-MimeOLE:" ; MS Outlook + "X-Mms-" ; T-Mobile pictures + "X-Mozilla-Status:" ; Netscape/Mozilla + "X-Msmail-" ; MS Outlook + "X-NAI-Spam-" ; Network Associates Inc. SpamKiller + "X-News:" ; News + "X-No-Archive:" + "X-Notes-Item:" ; Lotus Notes Domino structured header + "X-OperatingSystem:" + ;;"X-Operator:" ; Similar to X-Mailer, so display it + "X-Orcl-Content-Type:" + "X-Original-Complaints-To:" + "X-Original-Date:" ; SourceForge mailing list manager + "X-Original-To:" + "X-Original-Trace:" + "X-OriginalArrivalTime:" ; Hotmail + "X-Originating-IP:" ; Hotmail + "X-Postfilter:" + "X-Priority:" ; MS Outlook + "X-Qotd-" ; User added + "X-RM" + "X-Received-Date:" + "X-Received:" + "X-Request-" + "X-Return-Path-Hint:" ; Roving ConstantContact + "X-Roving-*" ; Roving ConstantContact + "X-SBClass:" ; Spam + "X-SBNote:" ; Spam + "X-SBPass:" ; Spam + "X-SBRule:" ; Spam + "X-SMTP-" + "X-Scanned-By" + "X-Sender:" + "X-Server-Date:" + "X-Server-Uuid:" + "X-Sieve:" ; Sieve filtering + "X-Source" + "X-Spam-" ; Spamassassin + "X-SpamBouncer:" ; Spam + "X-Status" + "X-Submissions-To:" + "X-Telecom-Digest" + "X-Trace:" + "X-UID" + "X-UIDL:" + "X-UNTD-" ; NetZero + "X-USANET-" ; usa.net + "X-UserInfo1:" + "X-VSMLoop:" ; NTMail + "X-Virus-Scanned" ; amavisd-new + "X-Vms-To:" + "X-WebTV-Signature:" + "X-Wss-Id:" ; Worldtalk gateways + "X-Yahoo" + "X-eGroups-" ; Egroups/yahoogroups mailing list manager + "X-pgp:" + "X-submission-address:" + "X400-" ; X400 + "Xref:") + "List of default header fields that are not to be shown. + +Do not alter this variable directly. Instead, add entries from +here that you would like to be displayed in +`mh-invisible-header-fields-default' and add entries to hide in +`mh-invisible-header-fields'.") + +(eval-and-compile + (unless (fboundp 'mh-invisible-headers) + (defun mh-invisible-headers () + "Temporary definition. +Real definition, below, uses variables that aren't defined yet." + nil))) + +(defvar mh-delay-invisible-header-generation-flag t + "Non-nil means to delay the generation of invisible header fields. +Because the function `mh-invisible-headers' uses both +`mh-invisible-header-fields' and `mh-invisible-header-fields', it +cannot be run until both variables have been initialized.") + +(defcustom mh-invisible-header-fields nil + "*Additional header fields to hide. + +Header fields that you would like to hide that aren't listed in +`mh-invisible-header-fields-default' can be added to this option +with a couple of caveats. Regular expressions are not allowed. +Unique fields should have a \":\" suffix; otherwise, the element +can be used to render invisible an entire class of fields that +start with the same prefix. If you think a header field should be +generally ignored, report a bug (see URL +`https://sourceforge.net/tracker/?group_id=13357&atid=113357'). + +See also `mh-clean-message-header-flag'." + + :type '(repeat (string :tag "Header field")) + :set (lambda (symbol value) + (set-default symbol value) + (mh-invisible-headers)) + :group 'mh-show) + +(defcustom mh-invisible-header-fields-default nil + "*List of hidden header fields. + +The header fields listed in this option are hidden, although you +can check off any field that you would like to see. + +Header fields that you would like to hide that aren't listed can +be added to the option `mh-invisible-header-fields'. + +See also `mh-clean-message-header-flag'." + :type `(set ,@(mapcar (lambda (x) `(const ,x)) + mh-invisible-header-fields-internal)) + :set (lambda (symbol value) + (set-default symbol value) + (mh-invisible-headers)) + :group 'mh-show) + +(defvar mh-invisible-header-fields-compiled nil + "*Regexp matching lines in a message header that are not to be shown. +Do not alter this variable directly. Instead, customize +`mh-invisible-header-fields-default' checking for fields normally +hidden that you wish to display, and add extra entries to hide in +`mh-invisible-header-fields'.") + +(defun mh-invisible-headers () + "Make or remake the variable `mh-invisible-header-fields-compiled'. +Done using `mh-invisible-header-fields-internal' as input, from +which entries from `mh-invisible-header-fields-default' are +removed and entries from `mh-invisible-header-fields' are added." + (let ((fields mh-invisible-header-fields-internal)) + (when mh-invisible-header-fields-default + ;; Remove entries from `mh-invisible-header-fields-default' + (setq fields + (loop for x in fields + unless (member x mh-invisible-header-fields-default) + collect x))) + (when (and (boundp 'mh-invisible-header-fields) + mh-invisible-header-fields) + (dolist (x mh-invisible-header-fields) + (unless (member x fields) (setq fields (cons x fields))))) + (if fields + (setq mh-invisible-header-fields-compiled + (concat + "^" + ;; workaround for insufficient default + (let ((max-specpdl-size 1000)) + (regexp-opt fields t)))) + (setq mh-invisible-header-fields-compiled nil)))) + +;; Compile invisible header fields. +(mh-invisible-headers) + +(defcustom mh-lpr-command-format "lpr -J '%s'" + "*Command used to print\\<mh-folder-mode-map>. + +This option contains the Unix command line which performs the +actual printing for the \\[mh-print-msg] command. The string can +contain one escape, \"%s\", which is replaced by the name of the +folder and the message number and is useful for print job names. +I use \"mpage -h'%s' -b Letter -H1of -mlrtb -P\" which produces a +nice header and adds a bit of margin so the text fits within my +printer's margins. + +This options is not used by the commands \\[mh-ps-print-msg] or +\\[mh-ps-print-msg-file]." + :type 'string + :group 'mh-show) + +(defcustom mh-max-inline-image-height nil + "*Maximum inline image height if \"Content-Disposition:\" is not present. + +Some older mail programs do not insert this needed plumbing to +tell MH-E whether to display the attachments inline or not. If +this is the case, MH-E will display these images inline if they +are smaller than the window. However, you might want to allow +larger images to be displayed inline. To do this, you can change +the options `mh-max-inline-image-width' and +`mh-max-inline-image-height' from their default value of zero to +a large number. The size of your screen is a good choice for +these numbers." + :type '(choice (const nil) integer) + :group 'mh-show) + +(defcustom mh-max-inline-image-width nil + "*Maximum inline image width if \"Content-Disposition:\" is not present. + +Some older mail programs do not insert this needed plumbing to +tell MH-E whether to display the attachments inline or not. If +this is the case, MH-E will display these images inline if they +are smaller than the window. However, you might want to allow +larger images to be displayed inline. To do this, you can change +the options `mh-max-inline-image-width' and +`mh-max-inline-image-height' from their default value of zero to +a large number. The size of your screen is a good choice for +these numbers." + :type '(choice (const nil) integer) + :group 'mh-show) + +(defcustom mh-mhl-format-file nil + "*Specifies the format file to pass to the \"mhl\" program. + +Normally MH-E takes care of displaying messages itself (rather than +calling an MH program to do the work). If you'd rather have \"mhl\" +display the message (within MH-E), change this option from its default +value of \"Use Default mhl Format (Printing Only)\". + +You can set this option to \"Use Default mhl Format\" to get the same +output as you would get if you ran \"mhl\" from the shell. + +If you have a format file that you want MH-E to use, you can set this +option to \"Specify an mhl Format File\" and enter the name of your +format file. Your format file should specify a non-zero value for +\"overflowoffset\" to allow MH-E to parse the header. Note that +\"mhl\" is always used for printing and forwarding; in this case, the +value of this option is consulted if you have specified a format +file." + :type '(choice (const :tag "Use Default mhl Format (Printing Only)" nil) + (const :tag "Use Default mhl Format" t) + (file :tag "Specify an mhl Format File")) + :group 'mh-show) + +(defcustom mh-mime-save-parts-default-directory t + "Default directory to use for \\<mh-folder-mode-map>\\[mh-mime-save-parts]. + +The default value for this option is \"Prompt Always\" so that +you are always prompted for the directory in which to save the +attachments. However, if you usually use the same directory +within a session, then you can set this option to \"Prompt the +First Time\" to avoid the prompt each time. you can make this +directory permanent by choosing \"Directory\" and entering the +directory's name." + :type '(choice (const :tag "Prompt the First Time" nil) + (const :tag "Prompt Always" t) + directory) + :group 'mh-show) + +(defcustom mh-print-background-flag nil + "*Non-nil means messages should be printed in the background\\<mh-folder-mode-map>. + +Normally messages are printed in the foreground. If this is slow on +your system, you may elect to turn off this option to print in the +background. + +WARNING: If you do this, do not delete the message until it is printed +or else the output may be truncated. + +This option is not used by the commands \\[mh-ps-print-msg] or +\\[mh-ps-print-msg-file]." + :type 'boolean + :group 'mh-show) + +(defcustom mh-show-maximum-size 0 + "*Maximum size of message (in bytes) to display automatically. + +This option provides an opportunity to skip over large messages +which may be slow to load. The default value of 0 means that all +message are shown regardless of size." + :type 'integer + :group 'mh-show) + +(defcustom mh-show-use-goto-addr-flag (and (boundp 'goto-address-highlight-p) + goto-address-highlight-p) + "*Non-nil means highlight URLs and email addresses\\<goto-address-highlight-keymap>. + +To send a message using the highlighted email address or to view +the web page for the highlighted URL, use the middle mouse button +or \\[goto-address-at-point]. + +See Info node `(mh-e)Sending Mail' to see how to configure Emacs +to send the message using MH-E. + +The default value of this option comes from the value of +`goto-address-highlight-p'." + :type 'boolean + :group 'mh-show) + +(defcustom mh-show-use-xface-flag (>= emacs-major-version 21) + "*Non-nil means display face images in MH-show buffers. + +MH-E can display the content of \"Face:\", \"X-Face:\", and +\"X-Image-URL:\" header fields. If any of these fields occur in the +header of your message, the sender's face will appear in the \"From:\" +header field. If more than one of these fields appear, then the first +field found in the order \"Face:\", \"X-Face:\", and \"X-Image-URL:\" +will be used. + +The option `mh-show-use-xface-flag' is used to turn this feature on +and off. This feature will be turned on by default if your system +supports it. + +The first header field used, if present, is the Gnus-specific +\"Face:\" field. The \"Face:\" field appeared in GNU Emacs 21 and +XEmacs. For more information, see URL +`http://quimby.gnus.org/circus/face/'. Next is the traditional +\"X-Face:\" header field. The display of this field requires the +\"uncompface\" program (see URL +`ftp://ftp.cs.indiana.edu/pub/faces/compface/compface.tar.z'). Recent +versions of XEmacs have internal support for \"X-Face:\" images. If +your version of XEmacs does not, then you'll need both \"uncompface\" +and the x-face package (see URL `ftp://ftp.jpl.org/pub/elisp/'). + +Finally, MH-E will display images referenced by the \"X-Image-URL:\" +header field if neither the \"Face:\" nor the \"X-Face:\" fields are +present. The display of the images requires \"wget\" (see URL +`http://www.gnu.org/software/wget/wget.html'), \"fetch\", or \"curl\" +to fetch the image and the \"convert\" program from the ImageMagick +suite (see URL `http://www.imagemagick.org/'). Of the three header +fields this is the most efficient in terms of network usage since the +image doesn't need to be transmitted with every single mail. + +The option `mh-fetch-x-image-url' controls the fetching of the +\"X-Image-URL:\" header field image." + :type 'boolean + :group 'mh-show) + +(defcustom mh-store-default-directory nil + "*Default directory for \\<mh-folder-mode-map>\\[mh-store-msg]. + +If you would like to change the initial default directory, +customize this option, change the value from \"Current\" to +\"Directory\", and then enter the name of the directory for storing +the content of these messages." + :type '(choice (const :tag "Current" nil) + directory) + :group 'mh-show) + +(defcustom mh-summary-height nil + "*Number of lines in MH-Folder buffer (including the mode line). + +The default value of this option is \"Automatic\" which means +that the MH-Folder buffer will maintain the same proportional +size if the frame is resized. If you'd prefer a fixed height, +then choose the \"Fixed Size\" option and enter the number of +lines you'd like to see." + :type '(choice (const :tag "Automatic" nil) + (integer :tag "Fixed Size")) + :group 'mh-show) + + + +;;; The Speedbar (:group 'mh-speedbar) + +(defcustom mh-speed-update-interval 60 + "Time between speedbar updates in seconds. +Set to 0 to disable automatic update." + :type 'integer + :group 'mh-speedbar) + + + +;;; Threading (:group 'mh-thread) + +(defcustom mh-show-threads-flag nil + "*Non-nil means new folders start in threaded mode. + +Threading large number of messages can be time consuming so this +option is turned off by default. If you turn this option on, then +threading will be done only if the number of messages being +threaded is less than `mh-large-folder'." + :type 'boolean + :group 'mh-thread) -;;; Build mh-folder-mode keymap: - -(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-toggle-tick - "," mh-header-display - "." mh-alt-show - ";" mh-toggle-mh-decode-mime-flag - ">" 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-index-next-folder - [backtab] mh-index-previous-folder - "\M-\t" mh-index-previous-folder - "\e<" mh-first-msg - "\e>" mh-last-msg - "\ed" mh-redistribute - "\r" mh-show - "^" 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-or-thread - "m" mh-alt-send - "n" mh-next-undeleted-msg - "\M-n" mh-next-unread-msg - "o" mh-refile-msg - "p" mh-previous-undeleted-msg - "\M-p" mh-previous-unread-msg - "q" mh-quit - "r" mh-reply - "s" mh-send - "t" mh-toggle-showing - "u" mh-undo - "v" mh-index-visit-folder - "x" mh-execute-commands - "|" mh-pipe-msg) - -(gnus-define-keys (mh-folder-map "F" mh-folder-mode-map) - "?" mh-prefix-help - "'" mh-index-ticked-messages - "S" mh-sort-folder - "c" mh-catchup - "f" mh-alt-visit-folder - "k" mh-kill-folder - "l" mh-list-folders - "n" mh-index-new-messages - "o" mh-alt-visit-folder - "p" mh-pack-folder - "q" mh-index-sequenced-messages - "r" mh-rescan-folder - "s" mh-search - "u" mh-undo-folder - "v" mh-visit-folder) - -(define-key mh-folder-mode-map "I" mh-inc-spool-map) - -(gnus-define-keys (mh-junk-map "J" mh-folder-mode-map) - "?" mh-prefix-help - "b" mh-junk-blacklist - "w" mh-junk-whitelist) - -(gnus-define-keys (mh-ps-print-map "P" mh-folder-mode-map) - "?" mh-prefix-help - "C" mh-ps-print-toggle-color - "F" mh-ps-print-toggle-faces - "f" mh-ps-print-msg-file - "l" mh-print-msg - "p" mh-ps-print-msg) - -(gnus-define-keys (mh-sequence-map "S" mh-folder-mode-map) - "'" mh-narrow-to-tick - "?" mh-prefix-help - "d" mh-delete-msg-from-seq - "k" mh-delete-seq - "l" mh-list-sequences - "n" mh-narrow-to-seq - "p" mh-put-msg-in-seq - "s" mh-msg-is-in-seq - "w" mh-widen) - -(gnus-define-keys (mh-thread-map "T" mh-folder-mode-map) - "?" mh-prefix-help - "u" mh-thread-ancestor - "p" mh-thread-previous-sibling - "n" mh-thread-next-sibling - "t" mh-toggle-threads - "d" mh-thread-delete - "o" mh-thread-refile) - -(gnus-define-keys (mh-limit-map "/" mh-folder-mode-map) - "'" mh-narrow-to-tick - "?" mh-prefix-help - "c" mh-narrow-to-cc - "g" mh-narrow-to-range - "m" mh-narrow-to-from - "s" mh-narrow-to-subject - "t" mh-narrow-to-to - "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 - "e" mh-display-with-external-viewer - "i" mh-folder-inline-mime-part - "o" mh-folder-save-mime-part - "t" mh-toggle-mime-buttons - "v" mh-folder-toggle-mime-part - "\t" mh-next-button - [backtab] mh-prev-button - "\M-\t" mh-prev-button) - -(cond - (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 +;;; The Tool Bar (:group 'mh-tool-bar) + +;; mh-tool-bar-folder-buttons and mh-tool-bar-letter-buttons defined +;; dynamically in mh-tool-bar.el. + +(defcustom mh-tool-bar-search-function 'mh-search + "*Function called by the tool bar search button. + +By default, this is set to `mh-search'. You can also choose +\"Other Function\" from the \"Value Menu\" and enter a function +of your own choosing." + :type '(choice (const mh-search) + (function :tag "Other Function")) + :group 'mh-tool-bar) + +;; XEmacs has a couple of extra customizations... +(mh-do-in-xemacs + (defcustom mh-xemacs-use-tool-bar-flag mh-xemacs-has-tool-bar-flag + "*If non-nil, use tool bar. + +This option controls whether to show the MH-E icons at all. By +default, this option is turned on if the window system supports +tool bars. If your system doesn't support tool bars, then you +won't be able to turn on this option." + :type 'boolean + :group 'mh-tool-bar + :set (lambda (symbol value) + (if (and (eq value t) + (not mh-xemacs-has-tool-bar-flag)) + (error "Tool bar not supported")) + (set-default symbol value))) + + (defcustom mh-xemacs-tool-bar-position nil + "*Tool bar location. + +This option controls the placement of the tool bar along the four +edges of the frame. You can choose from one of \"Same As Default +Tool Bar\", \"Top\", \"Bottom\", \"Left\", or \"Right\". If this +variable is set to anything other than \"Same As Default Tool +Bar\" and the default tool bar is in a different location, then +two tool bars will be displayed: the MH-E tool bar and the +default tool bar." + :type '(radio (const :tag "Same As Default Tool Bar" :value nil) + (const :tag "Top" :value top) + (const :tag "Bottom" :value bottom) + (const :tag "Left" :value left) + (const :tag "Right" :value right)) + :group 'mh-tool-bar)) -;;; 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-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" - "[;]toggle MIME decoding.\n" - "Prefix characters:\n [F]older, [S]equence, [J]unk, MIME [K]eys," - "\n [T]hread, [/]limit, e[X]tract, [D]igest, [I]nc spools.") - - (?F "[l]ist; [v]isit folder;\n" - "[n]ew messages; [']ticked messages; [s]earch;\n" - "[p]ack; [S]ort; [r]escan; [k]ill") - (?P "[p]rint message to [f]ile; old-style [l]pr printing;\n" - "Toggle printing of [C]olors, [F]aces") - (?S "[p]ut message in sequence, [n]arrow, [']narrow to ticked, [w]iden,\n" - "[s]equences, [l]ist,\n" - "[d]elete message from sequence, [k]ill sequence") - (?T "[t]oggle, [d]elete, [o]refile thread") - (?/ "Limit to [c]c, ran[g]e, fro[m], [s]ubject, [t]o; [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") - (?J "[b]lacklist, [w]hitelist message")) - "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.") +;;; Hooks (:group 'mh-hooks + group where hook described) + +(defcustom mh-after-commands-processed-hook nil + "Hook run by \\<mh-folder-mode-map>\\[mh-execute-commands] after performing outstanding requests. + +Variables that are useful in this hook include +`mh-folders-changed', which lists which folders were affected by +deletes and refiles. This list will always include the current +folder, which is also available in `mh-current-folder'." + :type 'hook + :group 'mh-hooks + :group 'mh-folder) + +(defcustom mh-alias-reloaded-hook nil + "Hook run by `mh-alias-reload' after loading aliases." + :type 'hook + :group 'mh-hooks + :group 'mh-alias) + +(defcustom mh-before-commands-processed-hook nil + "Hook run by \\<mh-folder-mode-map>\\[mh-execute-commands] before performing outstanding requests. + +Variables that are useful in this hook include `mh-delete-list' +and `mh-refile-list' which can be used to see which changes will +be made to the current folder, `mh-current-folder'." + :type 'hook + :group 'mh-hooks + :group 'mh-folder) + +(defcustom mh-before-quit-hook nil + "Hook run by \\<mh-folder-mode-map>\\[mh-quit] before quitting MH-E. + +This hook is called before the quit occurs, so you might use it +to perform any MH-E operations; you could perform some query and +abort the quit or call `mh-execute-commands', for example. + +See also `mh-quit-hook'." + :type 'hook + :group 'mh-hooks + :group 'mh-folder) + +(defcustom mh-before-send-letter-hook nil + "Hook run at the beginning of the \\<mh-letter-mode-map>\\[mh-send-letter] command. + +For example, if you want to check your spelling in your message +before sending, add the `ispell-message' function." + :type 'hook + :options '(ispell-message) + :group 'mh-hooks + :group 'mh-letter) + +(defcustom mh-delete-msg-hook nil + "Hook run by \\<mh-letter-mode-map>\\[mh-delete-msg] after marking each message for deletion. + +For example, a past maintainer of MH-E used this once when he +kept statistics on his mail usage." + :type 'hook + :group 'mh-hooks + :group 'mh-show) + +(defcustom mh-find-path-hook nil + "Hook run by `mh-find-path' after reading the user's MH profile. + +This hook can be used the change the value of the variables that +`mh-find-path' sets if you need to run with different values +between MH and MH-E." + :type 'hook + :group 'mh-hooks + :group 'mh-e) + +(defcustom mh-folder-mode-hook nil + "Hook run by `mh-folder-mode' when visiting a new folder." + :type 'hook + :group 'mh-hooks + :group 'mh-folder) + +(defcustom mh-forward-hook nil + "Hook run by `mh-forward' on a forwarded letter." + :type 'hook + :group 'mh-hooks + :group 'mh-sending-mail) + +(defcustom mh-inc-folder-hook nil + "Hook run by \\<mh-folder-mode-map>\\[mh-inc-folder] after incorporating mail into a folder." + :type 'hook + :group 'mh-hooks + :group 'mh-inc) + +(defcustom mh-insert-signature-hook nil + "Hook run by \\<mh-letter-mode-map>\\[mh-insert-signature] after signature has been inserted. + +Hook functions may access the actual name of the file or the +function used to insert the signature with +`mh-signature-file-name'." + :type 'hook + :group 'mh-hooks + :group 'mh-letter) + +(defcustom mh-kill-folder-suppress-prompt-hooks '(mh-search-p) + "Abnormal hook run at the beginning of \\<mh-folder-mode-map>\\[mh-kill-folder]. + +The hook functions are called with no arguments and should return +a non-nil value to suppress the normal prompt when you remove a +folder. This is useful for folders that are easily regenerated. + +The default value of `mh-search-p' suppresses the prompt on +folders generated by searching. + +WARNING: Use this hook with care. If there is a bug in your hook +which returns t on \"+inbox\" and you hit \\[mh-kill-folder] by +accident in the \"+inbox\" folder, you will not be happy." + :type 'hook + :group 'mh-hooks + :group 'mh-folder) + +(defcustom mh-letter-mode-hook nil + "Hook run by `mh-letter-mode' on a new letter. + +This hook allows you to do some processing before editing a +letter. For example, you may wish to modify the header after +\"repl\" has done its work, or you may have a complicated +\"components\" file and need to tell MH-E where the cursor should +go." + :type 'hook + :group 'mh-hooks + :group 'mh-sending-mail) + +(defcustom mh-mh-to-mime-hook nil + "Hook run on the formatted letter by \\<mh-letter-mode-map>\\[mh-mh-to-mime]." + :type 'hook + :group 'mh-hooks + :group 'mh-letter) + +(defcustom mh-search-mode-hook nil + "Hook run upon entry to `mh-search-mode'\\<mh-folder-mode-map>. + +If you find that you do the same thing over and over when editing +the search template, you may wish to bind some shortcuts to keys. +This can be done with this hook which is called when +\\[mh-search] is run on a new pattern." + :type 'hook + :group 'mh-hooks + :group 'mh-search) + +(defcustom mh-quit-hook nil + "Hook run by \\<mh-folder-mode-map>\\[mh-quit] after quitting MH-E. + +This hook is not run in an MH-E context, so you might use it to +modify the window setup. + +See also `mh-before-quit-hook'." + :type 'hook + :group 'mh-hooks + :group 'mh-folder) + +(defcustom mh-refile-msg-hook nil + "Hook run by \\<mh-folder-mode-map>\\[mh-refile-msg] after marking each message for refiling." + :type 'hook + :group 'mh-hooks + :group 'mh-folder) + +(defcustom mh-show-hook nil + "Hook run after \\<mh-folder-mode-map>\\[mh-show] shows a message. + +It is the last thing called after messages are displayed. It's +used to affect the behavior of MH-E in general or when +`mh-show-mode-hook' is too early. See `mh-show-mode-hook'." + :type 'hook + :group 'mh-hooks + :group 'mh-show) + +(defcustom mh-show-mode-hook nil + "Hook run upon entry to `mh-show-mode'. + +This hook is called early on in the process of the message +display. It is usually used to perform some action on the +message's content. See `mh-show-hook'." + :type 'hook + :group 'mh-hooks + :group 'mh-show) + +(defcustom mh-unseen-updated-hook nil + "Hook run after the unseen sequence has been updated. + +The variable `mh-seen-list' can be used by this hook to obtain +the list of messages which were removed from the unseen +sequence." + :type 'hook + :group 'mh-hooks + :group 'mh-sequences) -(dolist (mess '("^Cursor not pointing to message$" - "^There is no other window$")) - (add-to-list 'debug-ignored-errors mess)) +;;; Faces (:group 'mh-faces + group where faces described) + +(if (boundp 'facemenu-unlisted-faces) + (add-to-list 'facemenu-unlisted-faces "^mh-")) + +(defvar mh-min-colors-defined-flag (and (not mh-xemacs-flag) + (>= emacs-major-version 22)) + "Non-nil means defface supports min-colors display requirement.") + +(defun mh-defface-compat (spec) + "Convert SPEC for defface if necessary to run on older platforms. +Modifies SPEC in place and returns it. See `defface' for the spec definition. + +When `mh-min-colors-defined-flag' is nil, this function finds +display entries with \"min-colors\" requirements and either +removes the \"min-colors\" requirement or strips the display +entirely if the display does not support the number of specified +colors." + (if mh-min-colors-defined-flag + spec + (let ((cells (display-color-cells)) + new-spec) + ;; Remove entries with min-colors, or delete them if we have fewer colors + ;; than they specify. + (loop for entry in (reverse spec) do + (let ((requirement (if (eq (car entry) t) + nil + (assoc 'min-colors (car entry))))) + (if requirement + (when (>= cells (nth 1 requirement)) + (setq new-spec (cons (cons (delq requirement (car entry)) + (cdr entry)) + new-spec))) + (setq new-spec (cons entry new-spec))))) + new-spec))) + +(defface mh-folder-address '((t (:inherit mh-folder-subject))) + "Recipient face." + :group 'mh-faces + :group 'mh-folder) + +(defface mh-folder-body + '((((class color)) + (:inherit mh-folder-msg-number)) + (t + (:inherit mh-folder-msg-number :italic t))) + "Body text face." + :group 'mh-faces + :group 'mh-folder) + +(defface mh-folder-cur-msg-number + '((t + (:inherit mh-folder-msg-number :bold t))) + "Current message number face." + :group 'mh-faces + :group 'mh-folder) + +(defface mh-folder-date '((t (:inherit mh-folder-msg-number))) + "Date face." + :group 'mh-faces + :group 'mh-folder) + +(defface mh-folder-deleted '((t (:inherit mh-folder-msg-number))) + "Deleted message face." + :group 'mh-faces + :group 'mh-folder) + +(defface mh-folder-followup + '((((class color) (background light)) + (:foreground "blue3")) + (((class color) (background dark)) + (:foreground "LightGoldenRod")) + (t + (:bold t))) + "\"Re:\" face." + :group 'mh-faces + :group 'mh-folder) + +(defface mh-folder-msg-number + (mh-defface-compat + '((((class color) (min-colors 88) (background light)) + (:foreground "snow4")) + (((class color) (min-colors 88) (background dark)) + (:foreground "snow3")) + (((class color)) + (:foreground "cyan")))) + + "Message number face." + :group 'mh-faces + :group 'mh-folder) + +(defface mh-folder-refiled + (mh-defface-compat + '((((class color) (min-colors 88) (background light)) + (:foreground "DarkGoldenrod")) + (((class color) (min-colors 88) (background dark)) + (:foreground "LightGoldenrod")) + (((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)) + (t + (:bold t :italic t)))) + "Refiled message face." + :group 'mh-faces + :group 'mh-folder) + +(defface mh-folder-sent-to-me-hint '((t (:inherit mh-folder-date))) + "Fontification hint face in messages sent directly to us. +The detection of messages sent to us is governed by the scan +format `mh-scan-format-nmh' and the regular expression +`mh-scan-sent-to-me-sender-regexp'." + :group 'mh-faces + :group 'mh-folder) + +(defface mh-folder-sent-to-me-sender '((t (:inherit mh-folder-followup))) + "Sender face in messages sent directly to us. +The detection of messages sent to us is governed by the scan +format `mh-scan-format-nmh' and the regular expression +`mh-scan-sent-to-me-sender-regexp'." + :group 'mh-faces + :group 'mh-folder) + +(defface mh-folder-subject + '((((class color) (background light)) + (:foreground "blue4")) + (((class color) (background dark)) + (:foreground "yellow")) + (t + (:bold t))) + "Subject face." + :group 'mh-faces + :group 'mh-folder) + +(defface mh-folder-tick + '((((class color) (background dark)) + (:background "#dddf7e")) + (((class color) (background light)) + (:background "#dddf7e")) + (t + (:underline t))) + "Ticked message face." + :group 'mh-faces + :group 'mh-folder) + +(defface mh-folder-to + (mh-defface-compat + '((((class color) (min-colors 88) (background light)) + (:foreground "RosyBrown")) + (((class color) (min-colors 88) (background dark)) + (:foreground "LightSalmon")) + (((class color)) + (:foreground "green")) + (((class grayscale) (background light)) + (:foreground "DimGray" :italic t)) + (((class grayscale) (background dark)) + (:foreground "LightGray" :italic t)) + (t + (:italic t)))) + "\"To:\" face." + :group 'mh-faces + :group 'mh-folder) + +(defface mh-search-folder + '((((class color) (background light)) + (:foreground "dark green" :bold t)) + (((class color) (background dark)) + (:foreground "indian red" :bold t)) + (t + (:bold t))) + "Folder heading face in MH-Folder buffers created by searches." + :group 'mh-faces + :group 'mh-search) + +(defface mh-letter-header-field + '((((class color) (background light)) + (:background "gray90")) + (((class color) (background dark)) + (:background "gray10")) + (t + (:bold t))) + "Editable header field value face in draft buffers." + :group 'mh-faces + :group 'mh-letter) + +(defface mh-show-cc + (mh-defface-compat + '((((class color) (min-colors 88) (background light)) + (:foreground "DarkGoldenrod")) + (((class color) (min-colors 88) (background dark)) + (:foreground "LightGoldenrod")) + (((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)) + (t + (:bold t :italic t)))) + "Face used to highlight \"cc:\" header fields." + :group 'mh-faces + :group 'mh-show) + +(defface mh-show-date + (mh-defface-compat + '((((class color) (min-colors 88) (background light)) + (:foreground "ForestGreen")) + (((class color) (min-colors 88) (background dark)) + (:foreground "PaleGreen")) + (((class color)) + (:foreground "green")) + (((class grayscale) (background light)) + (:foreground "Gray90" :bold t)) + (((class grayscale) (background dark)) + (:foreground "DimGray" :bold t)) + (t + (:bold t :underline t)))) + "Face used to highlight \"Date:\" header fields." + :group 'mh-faces + :group 'mh-show) + +(defface mh-show-from + '((((class color) (background light)) + (:foreground "red3")) + (((class color) (background dark)) + (:foreground "cyan")) + (t + (:bold t))) + "Face used to highlight \"From:\" header fields." + :group 'mh-faces + :group 'mh-show) + +(defface mh-show-header + (mh-defface-compat + '((((class color) (min-colors 88) (background light)) + (:foreground "RosyBrown")) + (((class color) (min-colors 88) (background dark)) + (:foreground "LightSalmon")) + (((class color)) + (:foreground "green")) + (((class grayscale) (background light)) + (:foreground "DimGray" :italic t)) + (((class grayscale) (background dark)) + (:foreground "LightGray" :italic t)) + (t + (:italic t)))) + "Face used to deemphasize less interesting header fields." + :group 'mh-faces + :group 'mh-show) + +(defface mh-show-pgg-bad '((t (:bold t :foreground "DeepPink1"))) + "Bad PGG signature face." + :group 'mh-faces + :group 'mh-show) + +(defface mh-show-pgg-good '((t (:bold t :foreground "LimeGreen"))) + "Good PGG signature face." + :group 'mh-faces + :group 'mh-show) + +(defface mh-show-pgg-unknown '((t (:bold t :foreground "DarkGoldenrod2"))) + "Unknown or untrusted PGG signature face." + :group 'mh-faces + :group 'mh-show) + +(defface mh-show-signature '((t (:italic t))) + "Signature face." + :group 'mh-faces + :group 'mh-show) + +(defface mh-show-subject '((t (:inherit mh-folder-subject))) + "Face used to highlight \"Subject:\" header fields." + :group 'mh-faces + :group 'mh-show) + +(defface mh-show-to + '((((class color) (background light)) + (:foreground "SaddleBrown")) + (((class color) (background dark)) + (:foreground "burlywood")) + (((class grayscale) (background light)) + (:foreground "DimGray" :underline t)) + (((class grayscale) (background dark)) + (:foreground "LightGray" :underline t)) + (t (:underline t))) + "Face used to highlight \"To:\" header fields." + :group 'mh-faces + :group 'mh-show) + +(defface mh-show-xface '((t (:inherit (mh-show-from highlight)))) + "X-Face image face. +The background and foreground are used in the image." + :group 'mh-faces + :group 'mh-show) + +(defface mh-speedbar-folder + '((((class color) (background light)) + (:foreground "blue4")) + (((class color) (background dark)) + (:foreground "light blue"))) + "Basic folder face." + :group 'mh-faces + :group 'mh-speedbar) + +(defface mh-speedbar-folder-with-unseen-messages + '((t + (:inherit mh-speedbar-folder :bold t))) + "Folder face when folder contains unread messages." + :group 'mh-faces + :group 'mh-speedbar) + +(defface mh-speedbar-selected-folder + '((((class color) (background light)) + (:foreground "red1" :underline t)) + (((class color) (background dark)) + (:foreground "red1" :underline t)) + (t + (:underline t))) + "Selected folder face." + :group 'mh-faces + :group 'mh-speedbar) + +(defface mh-speedbar-selected-folder-with-unseen-messages + '((t + (:inherit mh-speedbar-selected-folder :bold t))) + "Selected folder face when folder contains unread messages." + :group 'mh-faces + :group 'mh-speedbar) (provide 'mh-e) diff --git a/lisp/mh-e/mh-exec.el b/lisp/mh-e/mh-exec.el deleted file mode 100644 index cfb99e18ee3..00000000000 --- a/lisp/mh-e/mh-exec.el +++ /dev/null @@ -1,264 +0,0 @@ -;;; mh-exec.el --- MH-E process support - -;; Copyright (C) 1993, 1995, 1997, -;; 2000, 2001, 2002, 2003, 2004, 2005, 2006 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., 51 Franklin Street, Fifth Floor, -;; Boston, MA 02110-1301, USA. - -;;; Commentary: - -;; Issue shell and MH commands - -;;; Change Log: - -;;; Code: - -(eval-when-compile (require 'mh-acros)) -(mh-require-cl) - -(require 'mh-buffers) -(require 'mh-utils) - -(defvar mh-progs nil - "Directory containing MH commands, such as inc, repl, and rmm.") - -;;;###autoload -(put 'mh-progs 'risky-local-variable t) - -(defvar mh-lib nil - "Directory containing the MH library. -This directory contains, among other things, the components file.") - -;;;###autoload -(put 'mh-lib 'risky-local-variable t) - -(defvar mh-lib-progs nil - "Directory containing MH helper programs. -This directory contains, among other things, the mhl program.") - -;;;###autoload -(put 'mh-lib-progs 'risky-local-variable t) - -(defvar mh-index-max-cmdline-args 500 - "Maximum number of command line args.") - -(defun mh-xargs (cmd &rest args) - "Partial imitation of xargs. -The current buffer contains a list of strings, one on each line. -The function will execute CMD with ARGS and pass the first -`mh-index-max-cmdline-args' strings to it. This is repeated till -all the strings have been used." - (goto-char (point-min)) - (let ((current-buffer (current-buffer))) - (with-temp-buffer - (let ((out (current-buffer))) - (set-buffer current-buffer) - (while (not (eobp)) - (let ((arg-list (reverse args)) - (count 0)) - (while (and (not (eobp)) (< count mh-index-max-cmdline-args)) - (push (buffer-substring-no-properties (point) (line-end-position)) - arg-list) - (incf count) - (forward-line)) - (apply #'call-process cmd nil (list out nil) nil - (nreverse arg-list)))) - (erase-buffer) - (insert-buffer-substring out))))) - -;; XXX This should be applied anywhere MH-E calls out to /bin/sh. -(defun mh-quote-for-shell (string) - "Quote STRING for /bin/sh. -Adds double-quotes around entire string and quotes the characters -\\, `, and $ with a backslash." - (concat "\"" - (loop for x across string - concat (format (if (memq x '(?\\ ?` ?$)) "\\%c" "%c") x)) - "\"")) - -(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." - (save-excursion - (set-buffer (get-buffer-create mh-log-buffer)) - (let* ((initial-size (mh-truncate-log-buffer)) - (start (point)) - (args (mh-list-to-string args))) - (apply 'call-process (expand-file-name command mh-progs) nil t nil args) - (when (> (buffer-size) initial-size) - (save-excursion - (goto-char start) - (insert "Errors when executing: " command) - (loop for arg in args do (insert " " arg)) - (insert "\n")) - (save-window-excursion - (switch-to-buffer-other-window mh-log-buffer) - (sit-for 5)))))) - -(defun mh-exec-cmd-error (env command &rest args) - "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) - (let ((process-environment process-environment)) - ;; XXX: We should purge the list that split-string returns of empty - ;; strings. This can happen in XEmacs if leading or trailing spaces - ;; are present. - (dolist (elem (if (stringp env) (split-string env " ") ())) - (push elem process-environment)) - (mh-handle-process-error - command (apply #'call-process (expand-file-name command mh-progs) - nil t nil (mh-list-to-string args)))))) - -(defun mh-exec-cmd-daemon (command filter &rest args) - "Execute MH command COMMAND in the background. - -If FILTER is non-nil then it is used to process the output -otherwise the default filter `mh-process-daemon' is used. See -`set-process-filter' for more details of FILTER. - -ARGS are passed to COMMAND as command line arguments." - (save-excursion - (set-buffer (get-buffer-create mh-log-buffer)) - (mh-truncate-log-buffer)) - (let* ((process-connection-type nil) - (process (apply 'start-process - command nil - (expand-file-name command mh-progs) - (mh-list-to-string args)))) - (set-process-filter process (or filter 'mh-process-daemon)) - process)) - -(defun mh-exec-cmd-env-daemon (env command filter &rest args) - "In ennvironment ENV, execute mh-command COMMAND in the background. - -ENV is nil or a string of space-separated \"var=value\" elements. -Signals an error if process does not complete successfully. - -If FILTER is non-nil then it is used to process the output -otherwise the default filter `mh-process-daemon' is used. See -`set-process-filter' for more details of FILTER. - -ARGS are passed to COMMAND as command line arguments." - (let ((process-environment process-environment)) - (dolist (elem (if (stringp env) (split-string env " ") ())) - (push elem process-environment)) - (apply #'mh-exec-cmd-daemon command filter args))) - -(defun mh-process-daemon (process output) - "PROCESS daemon that puts OUTPUT into a temporary buffer. -Any output from the process is displayed in an asynchronous -pop-up window." - (with-current-buffer (get-buffer-create mh-log-buffer) - (insert-before-markers output) - (display-buffer mh-log-buffer))) - -(defun mh-exec-cmd-quiet (raise-error command &rest args) - "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 - (apply 'call-process - (expand-file-name command mh-progs) nil t nil - args))) - (goto-char (point-min)) - (if raise-error - (mh-handle-process-error command value) - value))) - -;; Shush compiler. -(eval-when-compile (defvar mark-active)) - -(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." - (push-mark (point) t) - (apply 'call-process - (expand-file-name command mh-progs) nil t display - (mh-list-to-string args)) - - ;; 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-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-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." - (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-zero STATUS, otherwise return STATUS." - (if (equal status 0) - status - (goto-char (point-min)) - (insert (if (integerp status) - (format "%s: exit code %d\n" command status) - (format "%s: %s\n" command status))) - (save-excursion - (let ((error-message (buffer-substring (point-min) (point-max)))) - (set-buffer (get-buffer-create mh-log-buffer)) - (mh-truncate-log-buffer) - (insert error-message))) - (error "%s failed, check buffer %s for error message" - command mh-log-buffer))) - -(provide 'mh-exec) - -;; Local Variables: -;; indent-tabs-mode: nil -;; sentence-end-double-space: nil -;; End: - -;; arch-tag: 2857996c-e624-46b2-a58d-979cd279d288 -;;; mh-utils.el ends here diff --git a/lisp/mh-e/mh-folder.el b/lisp/mh-e/mh-folder.el new file mode 100644 index 00000000000..c2bb229bde1 --- /dev/null +++ b/lisp/mh-e/mh-folder.el @@ -0,0 +1,1989 @@ +;;; mh-folder.el --- MH-Folder mode + +;; Copyright (C) 2002, 2003, 2005, 2006 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., 51 Franklin Street, Fifth Floor, +;; Boston, MA 02110-1301, USA. + +;;; Commentary: + +;; Mode for browsing folders + +;;; Change Log: + +;;; Code: + +(require 'mh-e) +(require 'mh-scan) +(mh-require-cl) + +;; Dynamically-created function not found in mh-loaddefs.el. +(autoload 'mh-tool-bar-folder-buttons-init "mh-tool-bar") + +(require 'gnus-util) +(autoload 'message-fetch-field "message") + + + +;;; MH-E Entry Points + +;;;###autoload +(defun mh-rmail (&optional arg) + "Incorporate new mail with MH. +Scan an MH folder if ARG is non-nil. + +This function is an entry point to MH-E, the Emacs interface to +the MH mail system." + (interactive "P") + (mh-find-path) + (if arg + (call-interactively 'mh-visit-folder) + (unless (get-buffer mh-inbox) + (mh-visit-folder mh-inbox (symbol-name mh-unseen-seq))) + (mh-inc-folder))) + +;;;###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, the Emacs interface to +the MH mail system." + (interactive "P") + (mh-find-path) ; init mh-inbox + (if arg + (call-interactively 'mh-visit-folder) + (mh-visit-folder mh-inbox))) + + +;;; Desktop Integration + +;; desktop-buffer-mode-handlers appeared in Emacs 22. +(if (fboundp 'desktop-buffer-mode-handlers) + (add-to-list 'desktop-buffer-mode-handlers + '(mh-folder-mode . mh-restore-desktop-buffer))) + +(defun mh-restore-desktop-buffer (desktop-buffer-file-name + desktop-buffer-name + desktop-buffer-misc) + "Restore an MH folder buffer specified in a desktop file. +When desktop creates a buffer, DESKTOP-BUFFER-FILE-NAME holds the +file name to visit, DESKTOP-BUFFER-NAME holds the desired buffer +name, and DESKTOP-BUFFER-MISC holds a list of miscellaneous info +used by the `desktop-buffer-handlers' functions." + (mh-find-path) + (mh-visit-folder desktop-buffer-name) + (current-buffer)) + + + +;;; Variables + +(defvar mh-folder-filename nil + "Full path of directory for this folder.") + +(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.") + +(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-first-msg-num nil + "Number of first message in buffer.") + +(defvar mh-last-msg-num nil + "Number of last msg in buffer.") + +(defvar mh-msg-count nil + "Number of msgs in buffer.") + + + +;;; 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-folder-view-stack] + "--" + ["Narrow to Subject Sequence" mh-narrow-to-subject t] + ["Narrow to Tick Sequence" mh-narrow-to-tick + (and mh-tick-seq (mh-seq-msgs (mh-find-seq mh-tick-seq)))] + ["Delete Rest of Same Subject" mh-delete-subject t] + ["Toggle Tick Mark" mh-toggle-tick t] + "--" + ["Push State Out to MH" mh-update-sequences t])) + +;;; 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 t] + ["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 (mh-outstanding-commands-p)] + ["Execute Delete/Refile" mh-execute-commands + (mh-outstanding-commands-p)] + "--" + ["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 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 + (mh-outstanding-commands-p)] + ["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] + ["View New Messages" mh-index-new-messages t] + ["Search..." mh-search t] + "--" + ["Quit MH-E" mh-quit t])) + + + +;;; MH-Folder Keys + +(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-toggle-tick + "," mh-header-display + "." mh-alt-show + ";" mh-toggle-mh-decode-mime-flag + ">" 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-index-next-folder + [backtab] mh-index-previous-folder + "\M-\t" mh-index-previous-folder + "\e<" mh-first-msg + "\e>" mh-last-msg + "\ed" mh-redistribute + "\r" mh-show + "^" 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-or-thread + "m" mh-alt-send + "n" mh-next-undeleted-msg + "\M-n" mh-next-unread-msg + "o" mh-refile-msg + "p" mh-previous-undeleted-msg + "\M-p" mh-previous-unread-msg + "q" mh-quit + "r" mh-reply + "s" mh-send + "t" mh-toggle-showing + "u" mh-undo + "v" mh-index-visit-folder + "x" mh-execute-commands + "|" mh-pipe-msg) + +(gnus-define-keys (mh-folder-map "F" mh-folder-mode-map) + "?" mh-prefix-help + "'" mh-index-ticked-messages + "S" mh-sort-folder + "c" mh-catchup + "f" mh-alt-visit-folder + "k" mh-kill-folder + "l" mh-list-folders + "n" mh-index-new-messages + "o" mh-alt-visit-folder + "p" mh-pack-folder + "q" mh-index-sequenced-messages + "r" mh-rescan-folder + "s" mh-search + "u" mh-undo-folder + "v" mh-visit-folder) + +(define-key mh-folder-mode-map "I" mh-inc-spool-map) + +(gnus-define-keys (mh-junk-map "J" mh-folder-mode-map) + "?" mh-prefix-help + "b" mh-junk-blacklist + "w" mh-junk-whitelist) + +(gnus-define-keys (mh-ps-print-map "P" mh-folder-mode-map) + "?" mh-prefix-help + "C" mh-ps-print-toggle-color + "F" mh-ps-print-toggle-faces + "f" mh-ps-print-msg-file + "l" mh-print-msg + "p" mh-ps-print-msg) + +(gnus-define-keys (mh-sequence-map "S" mh-folder-mode-map) + "'" mh-narrow-to-tick + "?" mh-prefix-help + "d" mh-delete-msg-from-seq + "k" mh-delete-seq + "l" mh-list-sequences + "n" mh-narrow-to-seq + "p" mh-put-msg-in-seq + "s" mh-msg-is-in-seq + "w" mh-widen) + +(gnus-define-keys (mh-thread-map "T" mh-folder-mode-map) + "?" mh-prefix-help + "u" mh-thread-ancestor + "p" mh-thread-previous-sibling + "n" mh-thread-next-sibling + "t" mh-toggle-threads + "d" mh-thread-delete + "o" mh-thread-refile) + +(gnus-define-keys (mh-limit-map "/" mh-folder-mode-map) + "'" mh-narrow-to-tick + "?" mh-prefix-help + "c" mh-narrow-to-cc + "g" mh-narrow-to-range + "m" mh-narrow-to-from + "s" mh-narrow-to-subject + "t" mh-narrow-to-to + "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 + "e" mh-display-with-external-viewer + "i" mh-folder-inline-mime-part + "o" mh-folder-save-mime-part + "t" mh-toggle-mime-buttons + "v" mh-folder-toggle-mime-part + "\t" mh-next-button + [backtab] mh-prev-button + "\M-\t" mh-prev-button) + +(cond + (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 + + + +;;; MH-Folder 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-folder-mode-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" + "[;]toggle MIME decoding.\n" + "Prefix characters:\n [F]older, [S]equence, [J]unk, MIME [K]eys," + "\n [T]hread, [/]limit, e[X]tract, [D]igest, [I]nc spools.") + + (?F "[l]ist; [v]isit folder;\n" + "[n]ew messages; [']ticked messages; [s]earch;\n" + "[p]ack; [S]ort; [r]escan; [k]ill") + (?P "[p]rint message to [f]ile; old-style [l]pr printing;\n" + "Toggle printing of [C]olors, [F]aces") + (?S "[p]ut message in sequence, [n]arrow, [']narrow to ticked, [w]iden,\n" + "[s]equences, [l]ist,\n" + "[d]elete message from sequence, [k]ill sequence") + (?T "[t]oggle, [d]elete, [o]refile thread") + (?/ "Limit to [c]c, ran[g]e, fro[m], [s]ubject, [t]o; [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") + (?J "[b]lacklist, [w]hitelist message")) + "Key binding cheat sheet. +See `mh-set-help'.") + + + +;;; MH-Folder Font Lock + +(defvar mh-folder-font-lock-keywords + (list + ;; Folders when displaying index buffer + (list "^\\+.*" + '(0 'mh-search-folder)) + ;; Marked for deletion + (list (concat mh-scan-deleted-msg-regexp ".*") + '(0 'mh-folder-deleted)) + ;; Marked for refile + (list (concat mh-scan-refiled-msg-regexp ".*") + '(0 'mh-folder-refiled)) + ;; After subject + (list mh-scan-body-regexp + '(1 'mh-folder-body nil t)) + ;; Subject + '(mh-folder-font-lock-subject + (1 'mh-folder-followup append t) + (2 'mh-folder-subject append t)) + ;; Current message number + (list mh-scan-cur-msg-number-regexp + '(1 'mh-folder-cur-msg-number)) + ;; Message number + (list mh-scan-good-msg-regexp + '(1 'mh-folder-msg-number)) + ;; Date + (list mh-scan-date-regexp + '(1 'mh-folder-date)) + ;; Messages from me (To:) + (list mh-scan-rcpt-regexp + '(1 'mh-folder-to) + '(2 'mh-folder-address)) + ;; Messages to me + (list mh-scan-sent-to-me-sender-regexp + '(1 'mh-folder-sent-to-me-hint) + '(2 'mh-folder-sent-to-me-sender))) + "Keywords (regular expressions) used to fontify the MH-Folder buffer.") + +(defun mh-folder-font-lock-subject (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 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)) + +;; Fontify unseen messages in bold. + +(defmacro mh-generate-sequence-font-lock (seq prefix face) + "Generate the appropriate code to fontify messages in SEQ. +PREFIX is used to generate unique names for the variables and +functions defined by the macro. So a different prefix should be +provided for every invocation. +FACE is the font-lock face used to display the matching scan lines." + (let ((cache (intern (format "mh-folder-%s-seq-cache" prefix))) + (func (intern (format "mh-folder-font-lock-%s" prefix)))) + `(progn + (defvar ,cache nil + "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 ',cache) + + (defun ,func (limit) + "Return unseen message lines to font-lock between point and LIMIT." + (if (not ,cache) (setq ,cache (mh-seq-msgs (mh-find-seq ,seq)))) + (let ((cur-msg (mh-get-msg-num nil))) + (cond ((not ,cache) + nil) + ((>= (point) limit) ;Presumably at end of buffer + (setq ,cache nil) + nil) + ((member cur-msg ,cache) + (let ((bpoint (progn (beginning-of-line)(point))) + (epoint (progn (forward-line 1)(point)))) + (if (<= limit (point)) (setq ,cache nil)) + (set-match-data (list bpoint epoint bpoint epoint)) + t)) + (t + ;; move forward one line at a time, checking each message + (while (and (= 0 (forward-line 1)) + (> limit (point)) + (not (member (mh-get-msg-num nil) ,cache)))) + ;; Examine how we must have exited the loop... + (let ((cur-msg (mh-get-msg-num nil))) + (cond ((or (<= limit (point)) + (not (member cur-msg ,cache))) + (setq ,cache nil) + nil) + ((member cur-msg ,cache) + (let ((bpoint (progn (beginning-of-line) (point))) + (epoint (progn (forward-line 1) (point)))) + (if (<= limit (point)) (setq ,cache nil)) + (set-match-data + (list bpoint epoint bpoint epoint)) + t)))))))) + + (setq mh-folder-font-lock-keywords + (append mh-folder-font-lock-keywords + (list (list ',func (list 1 '',face 'prepend t)))))))) + +(mh-generate-sequence-font-lock mh-unseen-seq unseen bold) +(mh-generate-sequence-font-lock mh-tick-seq tick mh-folder-tick) + + + +;;; MH-Folder Mode + +(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)) ;XEmacs + +;; Register mh-folder-mode as supporting which-function-mode... +(require 'which-func nil t) +(when (boundp 'which-func-modes) + (add-to-list 'which-func-modes 'mh-folder-mode)) + +;; Shush compiler. +(eval-when-compile + (defvar desktop-save-buffer) + (defvar font-lock-auto-fontify) + (mh-do-in-xemacs (defvar font-lock-defaults))) + +(defvar mh-folder-buttons-init-flag nil) + +;; Ensure new buffers won't get this mode if default-major-mode is nil. +(put 'mh-folder-mode 'mode-class 'special) + +;; Autoload cookie needed by desktop.el +;;;###autoload +(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> + +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 folder; these commands are executed all at once with a +separate command. + +Options that control this mode can be changed with +\\[customize-group]; specify the \"mh\" group. In particular, please +see the `mh-scan-format-file' option if you wish to modify scan's +format. + +When a folder is visited, the hook `mh-folder-mode-hook' is run. + +Ranges +====== +Many commands that operate on individual messages, such as +`mh-forward' or `mh-refile-msg' take a RANGE argument. This argument +can be used in several ways. + +If you provide the prefix argument (\\[universal-argument]) to +these commands, then you will be prompted for the message range. +This can be any valid MH range which can include messages, +sequences, and the abbreviations (described in the mh(1) man +page): + +<num1>-<num2> + Indicates all messages in the range <num1> to <num2>, inclusive. + The range must be nonempty. + +<num>:N +<num>:+N +<num>:-N + Up to N messages beginning with (or ending with) message num. Num + may be any of the predefined symbols: first, prev, cur, next or + last. + +first:N +prev:N +next:N +last:N + The first, previous, next or last messages, if they exist. + +all + All of the messages. + +For example, a range that shows all of these things is `1 2 3 +5-10 last:5 unseen'. + +If the option `transient-mark-mode' is set to t and you set a +region in the MH-Folder buffer, then the MH-E command will +perform the operation on all messages in that region. + +\\{mh-folder-mode-map}" + (mh-do-in-gnu-emacs + (unless mh-folder-buttons-init-flag + (mh-tool-bar-folder-buttons-init) + (setq mh-folder-buttons-init-flag t))) + (make-local-variable 'font-lock-defaults) + (setq font-lock-defaults '(mh-folder-font-lock-keywords t)) + (make-local-variable 'desktop-save-buffer) + (setq desktop-save-buffer t) + (mh-make-local-vars + 'mh-colors-available-flag (mh-colors-available-p) + ; Do we have colors available + 'mh-current-folder (buffer-name) ; Name of folder, a string + 'mh-show-buffer (format "show-%s" (buffer-name)) ; Buffer that displays msgs + 'mh-folder-filename ; e.g. "/usr/foobar/Mail/inbox/" + (file-name-as-directory (mh-expand-file-name (buffer-name))) + 'mh-display-buttons-for-inline-parts-flag + mh-display-buttons-for-inline-parts-flag ; Allow for display of buttons to + ; be toggled. + 'mh-arrow-marker (make-marker) ; Marker where arrow is displayed + 'overlay-arrow-position nil ; Allow for simultaneous display in + 'overlay-arrow-string ">" ; different MH-E buffers. + 'mh-showing-mode nil ; Show message also? + 'mh-delete-list nil ; List of msgs nums to delete + 'mh-refile-list nil ; List of folder names in mh-seq-list + 'mh-seq-list nil ; Alist of (seq . msgs) nums + 'mh-seen-list nil ; List of displayed messages + 'mh-next-direction 'forward ; Direction to move to next message + 'mh-view-ops () ; Stack that keeps track of the order + ; in which narrowing/threading has been + ; carried out. + 'mh-folder-view-stack () ; Stack of previous views of the + ; folder. + 'mh-index-data nil ; If the folder was created by a call + ; to mh-search, this contains info + ; about the search results. + 'mh-index-previous-search nil ; folder, indexer, search-regexp + 'mh-index-msg-checksum-map nil ; msg -> checksum map + 'mh-index-checksum-origin-map nil ; checksum -> ( orig-folder, orig-msg ) + 'mh-index-sequence-search-flag nil ; folder resulted from sequence search + '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 ; Indicates message range + 'mh-sequence-notation-history (make-hash-table) + ; Remember what is overwritten by + ; mh-note-seq. + 'imenu-create-index-function 'mh-index-create-imenu-index + ; Setup imenu support + '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) + (mh-make-local-hook (mh-write-file-functions-compat)) + (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 + (mh-funcall-if-exists hl-line-mode 1) + (setq revert-buffer-function 'mh-undo-folder) + (or (assq 'mh-showing-mode minor-mode-alist) + (setq minor-mode-alist + (cons '(mh-showing-mode " Show") minor-mode-alist))) + (easy-menu-add mh-folder-sequence-menu) + (easy-menu-add mh-folder-message-menu) + (easy-menu-add mh-folder-folder-menu) + (mh-inc-spool-make) + (set (make-local-variable 'tool-bar-map) mh-folder-tool-bar-map) + (mh-funcall-if-exists mh-tool-bar-init :folder) + (mh-set-help mh-folder-mode-help-messages) + (if (and mh-xemacs-flag + font-lock-auto-fontify) + (turn-on-font-lock))) ; Force font-lock in XEmacs. + + + +;;; MH-Folder Commands + +;; Alphabetical. +;; See also mh-comp.el, mh-junk.el, mh-mime.el, mh-print.el, +;; mh-search.el, and mh-seq.el. + +;;;###mh-autoload +(defun mh-delete-msg (range) + "Delete RANGE\\<mh-folder-mode-map>. + +To mark a message for deletion, use this command. A \"D\" is +placed by the message in the scan window, and the next undeleted +message is displayed. If the previous command had been +\\[mh-previous-undeleted-msg], then the next message displayed is +the first undeleted message previous to the message just deleted. +Use \\[mh-next-undeleted-msg] to force subsequent +\\[mh-delete-msg] commands to move forward to the next undeleted +message after deleting the message under the cursor. + +The hook `mh-delete-msg-hook' is called after you mark a message +for deletion. For example, a past maintainer of MH-E used this +once when he kept statistics on his mail usage. + +Check the documentation of `mh-interactive-range' to see how +RANGE is read in interactive use." + (interactive (list (mh-interactive-range "Delete"))) + (mh-delete-msg-no-motion range) + (if (looking-at mh-scan-deleted-msg-regexp) + (mh-next-msg))) + +;;;###mh-autoload +(defun mh-delete-msg-no-motion (range) + "Delete RANGE, don't move to next message. + +This command marks the RANGE for deletion but leaves the cursor +at the current message in case you wish to perform other +operations on the message. + +Check the documentation of `mh-interactive-range' to see how +RANGE is read in interactive use." + (interactive (list (mh-interactive-range "Delete"))) + (mh-iterate-on-range () range + (mh-delete-a-msg nil))) + +;;;###mh-autoload +(defun mh-execute-commands () + "Process outstanding delete and refile requests\\<mh-folder-mode-map>. + +If you've marked messages to be deleted or refiled and you want +to go ahead and delete or refile the messages, use this command. +Many MH-E commands that may affect the numbering of the +messages (such as \\[mh-rescan-folder] or \\[mh-pack-folder]) +will ask if you want to process refiles or deletes first and then +either run this command for you or undo the pending refiles and +deletes, which are lost. + +This function runs `mh-before-commands-processed-hook' before the +commands are processed and `mh-after-commands-processed-hook' +after the commands are processed." + (interactive) + (if mh-folder-view-stack (mh-widen t)) + (mh-process-commands mh-current-folder) + (mh-set-scan-mode) + (mh-goto-cur-msg) ; after mh-set-scan-mode for efficiency + (mh-make-folder-mode-line) + t) ; return t for write-file-functions + +;;;###mh-autoload +(defun mh-first-msg () + "Display first message." + (interactive) + (goto-char (point-min)) + (while (and (not (eobp)) (not (looking-at mh-scan-valid-regexp))) + (forward-line 1))) + +;;;###mh-autoload +(defun mh-goto-msg (number &optional no-error-if-no-message dont-show) + "Go to a message\\<mh-folder-mode-map>. + +You can enter the message NUMBER either before or after typing +\\[mh-goto-msg]. In the latter case, Emacs prompts you. + +In a program, optional non-nil second argument NO-ERROR-IF-NO-MESSAGE +means return nil instead of signaling an error if message does not +exist\; in this case, the 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)) + (let ((point (point)) + (return-value t)) + (goto-char (point-min)) + (unless (re-search-forward (format (mh-scan-msg-search-regexp) 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)) + +;;;###mh-autoload +(defun mh-inc-folder (&optional file folder) + "Incorporate new mail into a folder. + +You can incorporate mail from any file into the current folder by +specifying a prefix argument; you'll be prompted for the name of +the FILE to use as well as the destination FOLDER + +The hook `mh-inc-folder-hook' is run 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: " + mh-user-path))) + (if current-prefix-arg + (mh-prompt-for-folder "inc mail into" mh-inbox t)))) + (if (not folder) + (setq folder mh-inbox)) + (let ((threading-needed-flag nil)) + (let ((config (current-window-configuration))) + (when (and mh-show-buffer (get-buffer mh-show-buffer)) + (delete-windows-on mh-show-buffer)) + (cond ((not (get-buffer folder)) + (mh-make-folder folder) + (setq threading-needed-flag mh-show-threads-flag) + (setq mh-previous-window-config config)) + ((not (eq (current-buffer) (get-buffer folder))) + (switch-to-buffer folder) + (setq mh-previous-window-config config)))) + (mh-get-new-mail file) + (when (and threading-needed-flag + (save-excursion + (goto-char (point-min)) + (or (null mh-large-folder) + (not (equal (forward-line (1+ mh-large-folder)) 0)) + (and (message "Not threading since the number of messages exceeds `mh-large-folder'") + nil)))) + (mh-toggle-threads)) + (beginning-of-line) + (if (and mh-showing-mode (looking-at mh-scan-valid-regexp)) (mh-show)) + (run-hooks 'mh-inc-folder-hook))) + +;;;###mh-autoload +(defun mh-last-msg () + "Display last message." + (interactive) + (goto-char (point-max)) + (while (and (not (bobp)) (not (looking-at mh-scan-valid-regexp))) + (forward-line -1)) + (mh-recenter nil)) + +;;;###mh-autoload +(defun mh-modify (&optional message) + "Edit message. + +There are times when you need to edit a message. For example, you +may need to fix a broken Content-Type header field. You can do +this with this command. It displays the raw message in an +editable buffer. When you are done editing, save and kill the +buffer as you would any other. + +From a program, edit MESSAGE; nil means edit current message." + (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))) + +;;;###mh-autoload +(defun mh-next-button (&optional backward-flag) + "Go to the next button. + +If the end of the buffer is reached then the search wraps over to +the start of the buffer. + +If an optional prefix argument BACKWARD-FLAG is given, the cursor +will move to the previous 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))) + +;;;###mh-autoload +(defun mh-next-undeleted-msg (&optional count wait-after-complaining-flag) + "Display next message. + +This command can be given a prefix argument COUNT to specify how +many unread messages to skip. + +In a program, pause for a second after printing message if we are +at the last undeleted message and optional argument +WAIT-AFTER-COMPLAINING-FLAG is non-nil." + (interactive "p") + (setq mh-next-direction 'forward) + (forward-line 1) + (cond ((re-search-forward mh-scan-good-msg-regexp nil t count) + (beginning-of-line) + (mh-maybe-show)) + (t (forward-line -1) + (message "No more undeleted messages") + (if wait-after-complaining-flag (sit-for 1))))) + +;;;###mh-autoload +(defun mh-next-unread-msg (&optional count) + "Display next unread message. + +This command can be given a prefix argument COUNT to specify how +many unread messages to skip." + (interactive "p") + (unless (> count 0) + (error "The function `mh-next-unread-msg' expects positive argument")) + (setq count (1- count)) + (let ((unread-sequence (reverse (cdr (assoc mh-unseen-seq mh-seq-list)))) + (cur-msg (mh-get-msg-num nil))) + (cond ((and (not cur-msg) (not (bobp)) + ;; If we are at the end of the buffer back up one line and go + ;; to unread message after that. + (progn + (forward-line -1) + (setq cur-msg (mh-get-msg-num nil))) + nil)) + ((or (null unread-sequence) (not cur-msg)) + ;; No unread message or there aren't any messages in buffer... + (message "No more unread messages")) + ((progn + ;; Skip messages + (while (and unread-sequence (>= cur-msg (car unread-sequence))) + (setq unread-sequence (cdr unread-sequence))) + (while (> count 0) + (setq unread-sequence (cdr unread-sequence)) + (setq count (1- count))) + (not (car unread-sequence))) + (message "No more unread messages")) + (t (loop for msg in unread-sequence + when (mh-goto-msg msg t) return nil + finally (message "No more unread messages")))))) + +;;;###mh-autoload +(defun mh-page-msg (&optional lines) + "Display next page in message. + +You can give this command a prefix argument that specifies the +number of LINES to scroll. This command will also show the next +undeleted message if it is used at the bottom of a message." + (interactive "P") + (if mh-showing-mode + (if mh-page-to-next-msg-flag + (if (equal mh-next-direction 'backward) + (mh-previous-undeleted-msg) + (mh-next-undeleted-msg)) + (if (mh-in-show-buffer (mh-show-buffer) + (pos-visible-in-window-p (point-max))) + (progn + (message + "End of message (Type %s to read %s undeleted message)" + (single-key-description last-input-event) + (if (equal mh-next-direction 'backward) + "previous" + "next")) + (setq mh-page-to-next-msg-flag t)) + (scroll-other-window lines))) + (mh-show))) + +;;;###mh-autoload +(defun mh-prev-button () + "Go to the previous button. + +If the beginning of the buffer is reached then the search wraps +over to the end of the buffer." + (interactive) + (mh-next-button t)) + +;;;###mh-autoload +(defun mh-previous-page (&optional lines) + "Display next page in message. + +You can give this command a prefix argument that specifies the +number of LINES to scroll." + (interactive "P") + (mh-in-show-buffer (mh-show-buffer) + (scroll-down lines))) + +;;;###mh-autoload +(defun mh-previous-undeleted-msg (&optional count wait-after-complaining-flag) + "Display previous message. + +This command can be given a prefix argument COUNT to specify how +many unread messages to skip. + +In a program, pause for a second after printing message if we are +at the last undeleted message and optional argument +WAIT-AFTER-COMPLAINING-FLAG is non-nil." + (interactive "p") + (setq mh-next-direction 'backward) + (beginning-of-line) + (cond ((re-search-backward mh-scan-good-msg-regexp nil t count) + (mh-maybe-show)) + (t (message "No previous undeleted message") + (if wait-after-complaining-flag (sit-for 1))))) + +;;;###mh-autoload +(defun mh-previous-unread-msg (&optional count) + "Display previous unread message. + +This command can be given a prefix argument COUNT to specify how +many unread messages to skip." + (interactive "p") + (unless (> count 0) + (error "The function `mh-previous-unread-msg' expects positive argument")) + (setq count (1- count)) + (let ((unread-sequence (cdr (assoc mh-unseen-seq mh-seq-list))) + (cur-msg (mh-get-msg-num nil))) + (cond ((and (not cur-msg) (not (bobp)) + ;; If we are at the end of the buffer back up one line and go + ;; to unread message after that. + (progn + (forward-line -1) + (setq cur-msg (mh-get-msg-num nil))) + nil)) + ((or (null unread-sequence) (not cur-msg)) + ;; No unread message or there aren't any messages in buffer... + (message "No more unread messages")) + ((progn + ;; Skip count messages... + (while (and unread-sequence (>= (car unread-sequence) cur-msg)) + (setq unread-sequence (cdr unread-sequence))) + (while (> count 0) + (setq unread-sequence (cdr unread-sequence)) + (setq count (1- count))) + (not (car unread-sequence))) + (message "No more unread messages")) + (t (loop for msg in unread-sequence + when (mh-goto-msg msg t) return nil + finally (message "No more unread messages")))))) + +;;;###mh-autoload +(defun mh-quit () + "Quit the current MH-E folder. + +When you want to quit using MH-E and go back to editing, you can use +this command. This buries the buffers of the current MH-E folder and +restores the buffers that were present when you first ran +\\[mh-rmail]. It also removes any MH-E working buffers whose name +begins with \" *mh-\" or \"*MH-E \". You can later restore your MH-E +session by selecting the \"+inbox\" buffer or by running \\[mh-rmail] +again. + +The two hooks `mh-before-quit-hook' and `mh-quit-hook' are called by +this function. The former one is called before the quit occurs, so you +might use it to perform any MH-E operations; you could perform some +query and abort the quit or call `mh-execute-commands', for example. +The latter is not run in an MH-E context, so you might use it to +modify the window setup." + (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-destroy-postponed-handles) + (bury-buffer (current-buffer)) + + ;; Delete all MH-E temporary and working buffers. + (dolist (buffer (buffer-list)) + (when (or (string-match "^ \\*mh-" (buffer-name buffer)) + (string-match "^\\*MH-E " (buffer-name buffer))) + (kill-buffer buffer))) + + (if mh-previous-window-config + (set-window-configuration mh-previous-window-config)) + (run-hooks 'mh-quit-hook)) + +;;;###mh-autoload +(defun mh-refile-msg (range folder &optional dont-update-last-destination-flag) + "Refile (output) RANGE into FOLDER. + +You are prompted for the folder name. Note that this command can also +be used to create folders. If you specify a folder that does not +exist, you will be prompted to create it. + +The hook `mh-refile-msg-hook' is called after a message is marked to +be refiled. + +Check the documentation of `mh-interactive-range' to see how RANGE is +read in interactive use. + +In a program, the variables `mh-last-destination' and +`mh-last-destination-folder' are not updated if +DONT-UPDATE-LAST-DESTINATION-FLAG is non-nil." + (interactive (list (mh-interactive-range "Refile") + (intern (mh-prompt-for-refile-folder)))) + (unless dont-update-last-destination-flag + (setq mh-last-destination (cons 'refile folder) + mh-last-destination-folder mh-last-destination)) + (mh-iterate-on-range () range + (mh-refile-a-msg nil folder)) + (when (looking-at mh-scan-refiled-msg-regexp) (mh-next-msg))) + +;;;###mh-autoload +(defun mh-refile-or-write-again (range &optional interactive-flag) + "Repeat last output command. + +If you are refiling several messages into the same folder, you +can use this command to repeat the last +refile (\\[mh-refile-msg]) or write (\\[mh-write-msg-to-file]). +You can use a range. + +Check the documentation of `mh-interactive-range' to see how RANGE is +read in interactive use. + +In a program, a non-nil INTERACTIVE-FLAG means that the function was +called interactively." + (interactive (list (mh-interactive-range "Redo") t)) + (if (null mh-last-destination) + (error "No previous refile or write")) + (cond ((eq (car mh-last-destination) 'refile) + (mh-refile-msg range (cdr mh-last-destination)) + (message "Destination folder: %s" (cdr mh-last-destination))) + (t + (mh-iterate-on-range msg range + (apply 'mh-write-msg-to-file msg (cdr mh-last-destination))) + (mh-next-msg interactive-flag)))) + +;;;###mh-autoload +(defun mh-rescan-folder (&optional range dont-exec-pending) + "Rescan folder\\<mh-folder-mode-map>. + +This command is useful to grab all messages in your \"+inbox\" after +processing your new mail for the first time. If you don't want to +rescan the entire folder, this command will accept a RANGE. Check the +documentation of `mh-interactive-range' to see how RANGE is read in +interactive use. + +This command will ask if you want to process refiles or deletes first +and then either run \\[mh-execute-commands] for you or undo the +pending refiles and deletes, which are lost. + +In a program, the processing of outstanding commands is not performed +if DONT-EXEC-PENDING is non-nil." + (interactive (list (if current-prefix-arg + (mh-read-range "Rescan" mh-current-folder t nil t + mh-interpret-number-as-range-flag) + nil))) + (setq mh-next-direction 'forward) + (let ((threaded-flag (memq 'unthread mh-view-ops)) + (msg-num (mh-get-msg-num nil))) + (mh-scan-folder mh-current-folder (or range "all") dont-exec-pending) + ;; If there isn't a cur sequence, mh-scan-folder goes to the first message. + ;; Try to stay where we were. + (if (null (car (mh-seq-to-msgs 'cur))) + (mh-goto-msg msg-num t t)) + (cond (threaded-flag (mh-toggle-threads)) + (mh-index-data (mh-index-insert-folder-headers))))) + +(defun mh-show-mouse (event) + "Move point to mouse EVENT and show message." + (interactive "e") + (mouse-set-point event) + (mh-show)) + +;;;###mh-autoload +(defun mh-toggle-showing () + "Toggle between MH-Folder and MH-Folder Show modes. + +This command switches between MH-Folder mode and MH-Folder Show +mode. MH-Folder mode turns off the associated show buffer so that +you can perform operations on the messages quickly without +reading them. This is an excellent way to prune out your junk +mail or to refile a group of messages to another folder for later +examination." + (interactive) + (if mh-showing-mode + (mh-set-scan-mode) + (mh-show))) + +;;;###mh-autoload +(defun mh-undo (range) + "Undo pending deletes or refiles in RANGE. + +If you've deleted a message or refiled it, but changed your mind, +you can cancel the action before you've executed it. Use this +command to undo a refile on or deletion of a single message. You +can also undo refiles and deletes for messages that are found in +a given RANGE. + +Check the documentation of `mh-interactive-range' to see how +RANGE is read in interactive use." + (interactive (list (mh-interactive-range "Undo"))) + (cond ((numberp range) + (let ((original-position (point))) + (beginning-of-line) + (while (not (or (looking-at mh-scan-deleted-msg-regexp) + (looking-at mh-scan-refiled-msg-regexp) + (and (eq mh-next-direction 'forward) (bobp)) + (and (eq mh-next-direction 'backward) + (save-excursion (forward-line) (eobp))))) + (forward-line (if (eq mh-next-direction 'forward) -1 1))) + (if (or (looking-at mh-scan-deleted-msg-regexp) + (looking-at mh-scan-refiled-msg-regexp)) + (progn + (mh-undo-msg (mh-get-msg-num t)) + (mh-maybe-show)) + (goto-char original-position) + (error "Nothing to undo")))) + (t (mh-iterate-on-range () range + (mh-undo-msg nil)))) + (if (not (mh-outstanding-commands-p)) + (mh-set-folder-modified-p nil))) + +;;;###mh-autoload +(defun mh-visit-folder (folder &optional range index-data) + "Visit FOLDER. + +When you want to read the messages that you have refiled into folders, +use this command to visit the folder. You are prompted for the folder +name. + +The folder buffer will show just unseen messages if there are any; +otherwise, it will show all the messages in the buffer as long there +are fewer than `mh-large-folder' messages. If there are more, then you +are prompted for a range of messages to scan. + +You can provide a prefix argument in order to specify a RANGE of +messages to show when you visit the folder. In this case, regions are +not used to specify the range and `mh-large-folder' is ignored. Check +the documentation of `mh-interactive-range' to see how RANGE is read +in interactive use. + +Note that this command can also be used to create folders. If you +specify a folder that does not exist, you will be prompted to create +it. + +Do not call this function from outside MH-E; use \\[mh-rmail] instead. + +If, in a program, RANGE is nil (the default), then all messages in +FOLDER are displayed. If an index buffer is being created then +INDEX-DATA is used to initialize the index buffer specific data +structures." + (interactive (let ((folder-name (mh-prompt-for-folder "Visit" mh-inbox t))) + (list folder-name + (mh-read-range "Scan" folder-name t nil + current-prefix-arg + mh-interpret-number-as-range-flag)))) + (let ((config (current-window-configuration)) + (current-buffer (current-buffer)) + (threaded-view-flag mh-show-threads-flag)) + (delete-other-windows) + (save-excursion + (when (get-buffer folder) + (set-buffer folder) + (setq threaded-view-flag (memq 'unthread mh-view-ops)))) + (when index-data + (mh-make-folder folder) + (setq mh-index-data (car index-data) + mh-index-msg-checksum-map (make-hash-table :test #'equal) + mh-index-checksum-origin-map (make-hash-table :test #'equal)) + (mh-index-update-maps folder (cadr index-data)) + (mh-index-create-sequences)) + (mh-scan-folder folder (or range "all")) + (cond ((and threaded-view-flag + (save-excursion + (goto-char (point-min)) + (or (null mh-large-folder) + (not (equal (forward-line (1+ mh-large-folder)) 0)) + (and (message "Not threading since the number of messages exceeds `mh-large-folder'") + nil)))) + (mh-toggle-threads)) + (mh-index-data + (mh-index-insert-folder-headers))) + (unless (eq current-buffer (current-buffer)) + (setq mh-previous-window-config config))) + nil) + +;;;###mh-autoload +(defun mh-write-msg-to-file (message file no-header) + "Append MESSAGE to end of FILE\\<mh-folder-mode-map>. + +You are prompted for the filename. If the file already exists, +the message is appended to it. You can also write the message to +the file without the header by specifying a prefix argument +NO-HEADER. Subsequent writes to the same file can be made with +the command \\[mh-refile-or-write-again]." + (interactive + (list (mh-get-msg-num t) + (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-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 message)) + (output-file (mh-expand-file-name file))) + (setq mh-last-destination (list 'write file (if no-header 'no-header)) + mh-last-destination-write mh-last-destination) + (save-excursion + (set-buffer (get-buffer-create mh-temp-buffer)) + (erase-buffer) + (insert-file-contents msg-file-to-output) + (goto-char (point-min)) + (if no-header (search-forward "\n\n")) + (append-to-file (point) (point-max) output-file)))) + +;;;###mh-autoload +(defun mh-update-sequences () + "Flush MH-E's state out to MH. + +This function updates the sequence specified by your +\"Unseen-Sequence:\" profile component, \"cur\", and the sequence +listed by the `mh-tick-seq' option which is \"tick\" by default. +The message at the cursor is used for \"cur\"." + (interactive) + ;; mh-update-sequences is the opposite of mh-read-folder-sequences, + ;; which updates MH-E's state from MH. + (let ((folder-set (mh-update-unseen)) + (new-cur (mh-get-msg-num nil))) + (if new-cur + (let ((seq-entry (mh-find-seq 'cur))) + (mh-remove-cur-notation) + (setcdr seq-entry + (list new-cur)) ;delete-seq-locally, add-msgs-to-seq + (mh-define-sequence 'cur (list new-cur)) + (beginning-of-line) + (if (looking-at mh-scan-good-msg-regexp) + (mh-notate-cur))) + (or folder-set + (save-excursion + ;; psg - mh-current-folder is nil if mh-summary-height < 4 ! + ;; So I added this sanity check. + (if (stringp mh-current-folder) + (mh-exec-cmd-quiet t "folder" mh-current-folder "-fast") + (mh-exec-cmd-quiet t "folder" "-fast"))))))) + + + +;;; Support Routines + +(defun mh-get-new-mail (maildrop-name) + "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-flag nil)) + (with-mh-folder-updating (t) + (if maildrop-name + (message "inc %s -file %s..." folder maildrop-name) + (message "inc %s..." folder)) + (setq mh-next-direction 'forward) + (goto-char (point-max)) + (mh-remove-cur-notation) + (let ((start-of-inc (point))) + (if maildrop-name + ;; I think MH 5 used "-ms-file" instead of "-file", + ;; which would make inc'ing from maildrops fail. + (mh-exec-cmd-output mh-inc-prog nil folder + (mh-scan-format) + "-file" (expand-file-name maildrop-name) + "-width" (window-width) + "-truncate") + (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)) + (goto-char start-of-inc) + (cond ((save-excursion + (re-search-forward "^inc: no mail" nil t)) + (message "No new mail%s%s" (if maildrop-name " in " "") + (if maildrop-name maildrop-name ""))) + ((and (when mh-folder-view-stack + (let ((saved-text (buffer-substring-no-properties + start-of-inc (point-max)))) + (delete-region start-of-inc (point-max)) + (unwind-protect (mh-widen t) + (mh-remove-cur-notation) + (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 + (setq new-mail-flag t))) + (keep-lines mh-scan-valid-regexp) ; Flush random scan lines + (let* ((sequences (mh-read-folder-sequences folder t)) + (new-cur (assoc 'cur sequences)) + (new-unseen (assoc mh-unseen-seq sequences))) + (unless (assoc 'cur mh-seq-list) + (push (list 'cur) mh-seq-list)) + (unless (assoc mh-unseen-seq mh-seq-list) + (push (list mh-unseen-seq) mh-seq-list)) + (setcdr (assoc 'cur mh-seq-list) (cdr new-cur)) + (setcdr (assoc mh-unseen-seq mh-seq-list) (cdr new-unseen))) + (when (equal (point-max) start-of-inc) + (mh-notate-cur)) + (if new-mail-flag + (progn + (mh-make-folder-mode-line) + (when (mh-speed-flists-active-p) + (mh-speed-flists t mh-current-folder)) + (when (memq 'unthread mh-view-ops) + (mh-thread-inc folder start-of-inc)) + (mh-goto-cur-msg)) + (goto-char point-before-inc)) + (mh-notate-user-sequences (cons start-of-inc (point-max))))))) + +(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', adjusting the notation +column with the width of the largest 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-msg-num-width-to-column (mh-msg-num-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))))) + +;;;###mh-autoload +(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)) + (unless minimal-changes-flag + (mh-notate-cur) + (mh-recenter 0) + (mh-maybe-show cur-msg))) + (t + (setq overlay-arrow-position nil) + (message "No current message"))))) + +;;;###mh-autoload +(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-update-unseen () + "Synchronize the unseen sequence with MH. +Return non-nil iff the MH folder was set. +The hook `mh-unseen-updated-hook' is called 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))) + (if unseen-msgs + (progn + (mh-undefine-sequence mh-unseen-seq mh-seen-list) + (run-hooks 'mh-unseen-updated-hook) + (while mh-seen-list + (setq unseen-msgs (delq (car mh-seen-list) unseen-msgs)) + (setq mh-seen-list (cdr mh-seen-list))) + (setcdr unseen-seq unseen-msgs) + t) ;since we set the folder + (setq mh-seen-list nil))))) + +;;;###mh-autoload +(defun mh-outstanding-commands-p () + "Return non-nil if there are outstanding deletes or refiles." + (save-excursion + (when (eq major-mode 'mh-show-mode) + (set-buffer mh-show-folder-buffer)) + (or mh-delete-list mh-refile-list))) + +;;;###mh-autoload +(defun mh-set-folder-modified-p (flag) + "Mark current folder as modified or unmodified according to FLAG." + (set-buffer-modified-p flag)) + +(defun mh-process-commands (folder) + "Process outstanding commands for FOLDER. + +This function runs `mh-before-commands-processed-hook' before the +commands are processed and `mh-after-commands-processed-hook' +after the commands are processed." + (message "Processing deletes and refiles for %s..." folder) + (set-buffer folder) + (with-mh-folder-updating (nil) + ;; Run the before hook -- the refile and delete lists are still valid + (run-hooks 'mh-before-commands-processed-hook) + + ;; Update the unseen sequence if it exists + (mh-update-unseen) + + (let ((redraw-needed-flag mh-index-data) + (folders-changed (list mh-current-folder)) + (seq-map (and mh-refile-list mh-refile-preserves-sequences-flag + (mh-create-sequence-map mh-seq-list))) + (dest-map (and mh-refile-list mh-refile-preserves-sequences-flag + (make-hash-table)))) + ;; Remove invalid scan lines if we are in an index folder and then remove + ;; the real messages + (when mh-index-data + (mh-index-delete-folder-headers) + (setq folders-changed + (append folders-changed (mh-index-execute-commands)))) + + ;; Then refile messages + (mh-mapc #'(lambda (folder-msg-list) + (let* ((dest-folder (symbol-name (car folder-msg-list))) + (last (car (mh-translate-range dest-folder "last"))) + (msgs (cdr folder-msg-list))) + (push dest-folder folders-changed) + (setq redraw-needed-flag t) + (apply #'mh-exec-cmd + "refile" "-src" folder dest-folder + (mh-coalesce-msg-list msgs)) + (mh-delete-scan-msgs msgs) + ;; Preserve sequences in destination folder... + (when mh-refile-preserves-sequences-flag + (clrhash dest-map) + (loop for i from (1+ (or last 0)) + for msg in (sort (copy-sequence msgs) #'<) + do (loop for seq-name in (gethash msg seq-map) + do (push i (gethash seq-name dest-map)))) + (maphash + #'(lambda (seq msgs) + ;; Can't be run in the background, since the + ;; current folder is changed by mark this could + ;; lead to a race condition with the next refile. + (apply #'mh-exec-cmd "mark" + "-sequence" (symbol-name seq) dest-folder + "-add" (mapcar #'(lambda (x) (format "%s" x)) + (mh-coalesce-msg-list msgs)))) + dest-map)))) + mh-refile-list) + (setq mh-refile-list ()) + + ;; 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. + ;; Mark cur message + (if (> (buffer-size) 0) + (mh-define-sequence 'cur (list (or (mh-get-msg-num nil) "last")))) + + ;; Redraw folder buffer if needed + (when (and redraw-needed-flag) + (when (mh-speed-flists-active-p) + (apply #'mh-speed-flists t folders-changed)) + (cond ((memq 'unthread mh-view-ops) (mh-thread-inc folder (point-max))) + (mh-index-data (mh-index-insert-folder-headers)))) + + (and (buffer-file-name (get-buffer mh-show-buffer)) + (not (file-exists-p (buffer-file-name (get-buffer mh-show-buffer)))) + ;; If "inc" were to put a new msg in this file, + ;; we would not notice, so mark it invalid now. + (mh-invalidate-show-buffer)) + + (setq mh-seq-list (mh-read-folder-sequences mh-current-folder nil)) + (mh-remove-all-notation) + (mh-notate-user-sequences) + + ;; Run the after hook -- now folders-changed is valid, + ;; but not the lists of specific messages. + (let ((mh-folders-changed folders-changed)) + (run-hooks 'mh-after-commands-processed-hook))) + + (message "Processing deletes and refiles for %s...done" folder))) + +(defun mh-delete-scan-msgs (msgs) + "Delete the scan listing lines for MSGS." + (save-excursion + (while msgs + (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-set-scan-mode () + "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-flag + (mh-recenter nil))) + +;;;###mh-autoload +(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 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 + (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)) + ("")))))) + (mh-logo-display)))) + +;;;###mh-autoload +(defun mh-scan-folder (folder range &optional dont-exec-pending) + "Scan FOLDER over RANGE. + +After the scan is performed, switch to the buffer associated with +FOLDER. + +Check the documentation of `mh-interactive-range' to see how RANGE is +read in interactive use. + +The processing of outstanding commands is not performed if +DONT-EXEC-PENDING is non-nil." + (when (stringp range) + (setq range (delete "" (split-string range "[ \t\n]")))) + (cond ((null (get-buffer folder)) + (mh-make-folder folder)) + (t + (unless dont-exec-pending + (mh-process-or-undo-commands folder) + (mh-reset-threads-and-narrowing)) + (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)) + (when (mh-outstanding-commands-p) + (mh-notate-deleted-and-refiled))) + +;;;###mh-autoload +(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." + (set-buffer folder) + (if (mh-outstanding-commands-p) + (if (or mh-do-not-confirm-flag + (y-or-n-p + "Process outstanding deletes and refiles? ")) + (mh-process-commands folder) + (set-buffer folder) + (mh-undo-folder))) + (mh-update-unseen) + (mh-invalidate-show-buffer)) + +;;;###mh-autoload +(defun mh-regenerate-headers (range &optional update) + "Scan folder over 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) + (mh-remove-all-notation) + (with-mh-folder-updating (nil) + (if update + (goto-char (point-max)) + (delete-region (point-min) (point-max)) + (if mh-adaptive-cmd-note-flag + (mh-set-cmd-note (mh-msg-num-width-to-column (mh-msg-num-width + folder))))) + (setq scan-start (point)) + (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 + ((looking-at (if (mh-variant-p 'mu-mh) + "scan: message set .* does not exist" + "scan: bad message list ")) + (keep-lines mh-scan-valid-regexp)) + ((looking-at "scan: ")) ; Keep error messages + (t + (keep-lines mh-scan-valid-regexp))) ; Flush random scan lines + (setq mh-seq-list (mh-read-folder-sequences folder nil)) + (mh-notate-user-sequences) + (or update + (setq mh-mode-line-annotation + (if (equal range '("all")) + nil + mh-partial-folder-mode-line-annotation))) + (mh-make-folder-mode-line)) + (message "Scanning %s...done" folder))) + +;;;###mh-autoload +(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-folder-view-stack ()) + (setq mh-thread-scan-line-map-stack ()) + (let ((buffer-read-only nil)) (erase-buffer))) + +(defun mh-make-folder (name) + "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-msg-num-width-to-column (mh-msg-num-width name)))) + (setq buffer-read-only t) + (mh-folder-mode) + (mh-set-folder-modified-p nil) + (setq buffer-file-name mh-folder-filename) + (when (and (not mh-index-data) + (file-exists-p (concat buffer-file-name mh-index-data-file))) + (mh-index-read-data)) + (mh-make-folder-mode-line)) + +;;;###mh-autoload +(defun mh-next-msg (&optional wait-after-complaining-flag) + "Move backward or forward to the next undeleted message in the buffer. +If optional argument WAIT-AFTER-COMPLAINING-FLAG is non-nil and +we are at the last message, then wait for a second after telling +the user that there aren't any more unread messages." + (if (eq mh-next-direction 'forward) + (mh-next-undeleted-msg 1 wait-after-complaining-flag) + (mh-previous-undeleted-msg 1 wait-after-complaining-flag))) + +;;;###mh-autoload +(defun mh-prompt-for-refile-folder () + "Prompt the user for a folder in which the message should be filed. +The folder is returned as a string. + +The default folder name is generated by the option +`mh-default-folder-for-message-function' if it is non-nil or +`mh-folder-from-address'." + (mh-prompt-for-folder + "Destination" + (let ((refile-file (ignore-errors (mh-msg-filename (mh-get-msg-num t))))) + (if (null refile-file) "" + (save-excursion + (set-buffer (get-buffer-create mh-temp-buffer)) + (erase-buffer) + (insert-file-contents refile-file) + (or (and mh-default-folder-for-message-function + (let ((buffer-file-name refile-file)) + (funcall mh-default-folder-for-message-function))) + (mh-folder-from-address) + (and (eq 'refile (car mh-last-destination-folder)) + (symbol-name (cdr mh-last-destination-folder))) + "")))) + t)) + +;;;###mh-autoload +(defun mh-folder-from-address () + "Derive folder name from sender. + +The name of the folder is derived as follows: + + a) The folder name associated with the first address found in + the list `mh-default-folder-list' is used. Each element in + this list contains a \"Check Recipient\" item. If this item is + turned on, then the address is checked against the recipient + instead of the sender. This is useful for mailing lists. + + b) An alias prefixed by `mh-default-folder-prefix' + corresponding to the address is used. The prefix is used to + prevent clutter in your mail directory. + +Return nil if a folder name was not derived, or if the variable +`mh-default-folder-must-exist-flag' is t and the folder does not +exist." + ;; Loop for all entries in mh-default-folder-list + (save-restriction + (goto-char (point-min)) + (re-search-forward "\n\n" nil 'limit) + (narrow-to-region (point-min) (point)) + (let ((to/cc (concat (or (message-fetch-field "to") "") ", " + (or (message-fetch-field "cc") ""))) + (from (or (message-fetch-field "from") "")) + folder-name) + (setq folder-name + (loop for list in mh-default-folder-list + when (string-match (nth 0 list) (if (nth 2 list) to/cc from)) + return (nth 1 list) + finally return nil)) + + ;; Make sure a result from `mh-default-folder-list' begins with "+" + ;; since 'mh-expand-file-name below depends on it + (when (and folder-name (not (eq (aref folder-name 0) ?+))) + (setq folder-name (concat "+" folder-name))) + + ;; If not, is there an alias for the address? + (when (not folder-name) + (let* ((from-header (mh-extract-from-header-value)) + (address (and from-header + (nth 1 (mail-extract-address-components + from-header)))) + (alias (and address (mh-alias-address-to-alias address)))) + (when alias + (setq folder-name + (and alias (concat "+" mh-default-folder-prefix alias)))))) + + ;; If mh-default-folder-must-exist-flag set, check that folder exists. + (if (and folder-name + (or (not mh-default-folder-must-exist-flag) + (file-exists-p (mh-expand-file-name folder-name)))) + folder-name)))) + +;;;###mh-autoload +(defun mh-delete-a-msg (message) + "Delete MESSAGE. +If MESSAGE is nil then the message at point is deleted. +The hook `mh-delete-msg-hook' is called after you mark a message +for deletion. For example, a past maintainer of MH-E used this +once when he kept statistics on his mail usage." + (save-excursion + (if (numberp message) + (mh-goto-msg message nil t) + (beginning-of-line) + (setq message (mh-get-msg-num t))) + (if (looking-at mh-scan-refiled-msg-regexp) + (error "Message %d is refiled; undo refile before deleting" message)) + (if (looking-at mh-scan-deleted-msg-regexp) + nil + (mh-set-folder-modified-p t) + (setq mh-delete-list (cons message mh-delete-list)) + (mh-notate nil mh-note-deleted mh-cmd-note) + (run-hooks 'mh-delete-msg-hook)))) + +;;;###mh-autoload +(defun mh-refile-a-msg (message folder) + "Refile MESSAGE in FOLDER. +If MESSAGE is nil then the message at point is refiled. +Folder is a symbol, not a string. +The hook `mh-refile-msg-hook' is called after a message is marked to +be refiled." + (save-excursion + (if (numberp message) + (mh-goto-msg message nil t) + (beginning-of-line) + (setq message (mh-get-msg-num t))) + (cond ((looking-at mh-scan-deleted-msg-regexp) + (error "Message %d is deleted; undo delete before moving" message)) + ((looking-at mh-scan-refiled-msg-regexp) + (if (y-or-n-p + (format "Message %d already refiled; copy to %s as well? " + message folder)) + (mh-exec-cmd "refile" (mh-get-msg-num t) "-link" + "-src" mh-current-folder + (symbol-name folder)) + (message "Message not copied"))) + (t + (mh-set-folder-modified-p t) + (cond ((null (assoc folder mh-refile-list)) + (push (list folder message) mh-refile-list)) + ((not (member message (cdr (assoc folder mh-refile-list)))) + (push message (cdr (assoc folder mh-refile-list))))) + (mh-notate nil mh-note-refiled mh-cmd-note) + (run-hooks 'mh-refile-msg-hook))))) + +(defun mh-undo-msg (msg) + "Undo the deletion or refile of one MSG. +If MSG is nil then act on the message at point" + (save-excursion + (if (numberp msg) + (mh-goto-msg msg t t) + (beginning-of-line) + (setq msg (mh-get-msg-num t))) + (cond ((memq msg mh-delete-list) + (setq mh-delete-list (delq msg mh-delete-list))) + (t + (dolist (folder-msg-list mh-refile-list) + (setf (cdr folder-msg-list) (remove msg (cdr folder-msg-list)))) + (setq mh-refile-list (loop for x in mh-refile-list + unless (null (cdr x)) collect x)))) + (mh-notate nil ? mh-cmd-note))) + +;;;###mh-autoload +(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))) + +(provide 'mh-folder) + +;; Local Variables: +;; indent-tabs-mode: nil +;; sentence-end-double-space: nil +;; End: + +;;; mh-folder.el ends here diff --git a/lisp/mh-e/mh-funcs.el b/lisp/mh-e/mh-funcs.el index b05fdd9fc02..0565ed42e6b 100644 --- a/lisp/mh-e/mh-funcs.el +++ b/lisp/mh-e/mh-funcs.el @@ -27,34 +27,19 @@ ;;; Commentary: -;; 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. +;; Please add the functions in alphabetical order. If only one or two +;; small support routines are needed, place them with the function; +;; otherwise, create a separate section for them. + ;;; Change Log: ;;; Code: -;;(message "> mh-funcs") -(eval-when-compile (require 'mh-acros)) -(mh-require-cl) -(require 'mh-buffers) (require 'mh-e) -;;(message "< mh-funcs") - - - -;;; Scan Line Formats - -(defvar mh-note-copied "C" - "Messages that have been copied are marked by this character.") - -(defvar mh-note-printed "P" - "Messages that have been printed are marked by this character.") - - - -;;; Functions +(require 'mh-scan) ;;;###mh-autoload (defun mh-burst-digest () @@ -213,27 +198,6 @@ Display RANGE after packing, or the entire folder if RANGE is nil." (mh-regenerate-headers range)) ;;;###mh-autoload -(defun mh-pipe-msg (command include-header) - "Pipe message through shell command COMMAND. - -You are prompted for the Unix command through which you wish to -run your message. If you give a prefix argument INCLUDE-HEADER to -this command, the message header is included in the text passed -to the command." - (interactive - (list (read-string "Shell command on message: ") current-prefix-arg)) - (let ((msg-file-to-pipe (mh-msg-filename (mh-get-msg-num t))) - (message-directory default-directory)) - (save-excursion - (set-buffer (get-buffer-create mh-temp-buffer)) - (erase-buffer) - (insert-file-contents msg-file-to-pipe) - (goto-char (point-min)) - (if (not include-header) (search-forward "\n\n")) - (let ((default-directory message-directory)) - (shell-command-on-region (point) (point-max) command nil))))) - -;;;###mh-autoload (defun mh-page-digest () "Display next message in digest." (interactive) @@ -268,6 +232,27 @@ to the command." (mh-recenter 0))) ;;;###mh-autoload +(defun mh-pipe-msg (command include-header) + "Pipe message through shell command COMMAND. + +You are prompted for the Unix command through which you wish to +run your message. If you give a prefix argument INCLUDE-HEADER to +this command, the message header is included in the text passed +to the command." + (interactive + (list (read-string "Shell command on message: ") current-prefix-arg)) + (let ((msg-file-to-pipe (mh-msg-filename (mh-get-msg-num t))) + (message-directory default-directory)) + (save-excursion + (set-buffer (get-buffer-create mh-temp-buffer)) + (erase-buffer) + (insert-file-contents msg-file-to-pipe) + (goto-char (point-min)) + (if (not include-header) (search-forward "\n\n")) + (let ((default-directory message-directory)) + (shell-command-on-region (point) (point-max) command nil))))) + +;;;###mh-autoload (defun mh-sort-folder (&optional extra-args) "Sort folder. @@ -289,21 +274,6 @@ By default, messages are sorted by date. The option (mh-index-data (mh-index-insert-folder-headers))))) ;;;###mh-autoload -(defun mh-undo-folder () - "Undo all refiles and deletes in the current folder." - (interactive) - (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 - mh-seq-list nil - mh-next-direction 'forward) - (with-mh-folder-updating (nil) - (mh-remove-all-notation))) - (t - (message "Commands not undone")))) - -;;;###mh-autoload (defun mh-store-msg (directory) "Unpack message created with \"uudecode\" or \"shar\". @@ -326,7 +296,6 @@ storing the content of these messages." (insert-file-contents msg-file-to-store) (mh-store-buffer directory)))) -;;;###mh-autoload (defun mh-store-buffer (directory) "Unpack buffer created with \"uudecode\" or \"shar\". @@ -383,48 +352,20 @@ See `mh-store-msg' for a description of DIRECTORY." (insert "\n(mh-store finished)\n")) (error "Error occurred during execution of %s" command))))) - - -;;; Help Functions - -;;;###mh-autoload -(defun mh-ephem-message (string) - "Display STRING in the minibuffer momentarily." - (message "%s" string) - (sit-for 5) - (message "")) - ;;;###mh-autoload -(defun mh-help () - "Display cheat sheet for the MH-E commands." - (interactive) - (with-electric-help - (function - (lambda () - (insert - (substitute-command-keys - (mapconcat 'identity (cdr (assoc nil mh-help-messages)) "")))) - mh-help-buffer))) - -;;;###mh-autoload -(defun mh-prefix-help () - "Display cheat sheet for the commands of the current prefix in minibuffer." +(defun mh-undo-folder () + "Undo all refiles and deletes in the current folder." (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)))) - (with-electric-help - (function - (lambda () - (insert - (substitute-command-keys - (mapconcat 'identity - (cdr (assoc prefix-char mh-help-messages)) ""))))) - mh-help-buffer))) + (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 + mh-seq-list nil + mh-next-direction 'forward) + (with-mh-folder-updating (nil) + (mh-remove-all-notation))) + (t + (message "Commands not undone")))) (provide 'mh-funcs) diff --git a/lisp/mh-e/mh-gnus.el b/lisp/mh-e/mh-gnus.el index 2a5a9989b37..dd2a888f12f 100644 --- a/lisp/mh-e/mh-gnus.el +++ b/lisp/mh-e/mh-gnus.el @@ -1,4 +1,4 @@ -;;; mh-gnus.el --- Make MH-E compatible with installed version of Gnus. +;;; mh-gnus.el --- make MH-E compatible with various versions of Gnus ;; Copyright (C) 2003, 2004, 2006 Free Software Foundation, Inc. @@ -30,18 +30,13 @@ ;;; Code: -;;(message "> mh-gnus") -(eval-when-compile (require 'mh-acros)) -;;(message "< mh-gnus") +(require 'mh-e) -;; Load libraries in a non-fatal way in order to see if certain functions are -;; pre-defined. -(load "mailabbrev" t t) -(load "mailcap" t t) -(load "mm-decode" t t) -(load "mm-uu" t t) -(load "mml" t t) -(load "smiley" t t) +(require 'gnus-util nil t) +(require 'mm-bodies nil t) +(require 'mm-decode nil t) +(require 'mm-view nil t) +(require 'mml nil t) ;; Copy of function from gnus-util.el. (mh-defun-compat gnus-local-map-property (map) @@ -68,12 +63,12 @@ (mm-insert-inline handle (concat "\n-- \n" - (ignore-errors - (if (fboundp 'vcard-pretty-print) - (vcard-pretty-print (mm-get-part handle)) - (vcard-format-string - (vcard-parse-string (mm-get-part handle) - 'vcard-standard-filter)))))))) + (ignore-errors + (if (fboundp 'vcard-pretty-print) + (vcard-pretty-print (mm-get-part handle)) + (vcard-format-string + (vcard-parse-string (mm-get-part handle) + 'vcard-standard-filter)))))))) ;; Function from mm-decode.el used in PGP messages. Just define it with older ;; Gnus to avoid compiler warning. @@ -116,6 +111,10 @@ "Older versions of Emacs don't have this function." nil) +(mh-defun-compat mm-uu-dissect-text-parts (handles) + "Emacs 21 and XEmacs don't have this function." + nil) + ;; Copy of function in mml.el. (mh-defun-compat mml-minibuffer-read-disposition (type &optional default) (unless default (setq default @@ -128,7 +127,7 @@ '(("attachment") ("inline") ("")) nil t nil nil default))) (if (not (equal disposition "")) - disposition + disposition default))) ;; This is mm-save-part from Gnus 5.10 since that function in emacs21.2 is @@ -158,11 +157,6 @@ (or (and (boundp 'mm-inline-text-html-renderer) mm-inline-text-html-renderer) (and (boundp 'mm-text-html-renderer) mm-text-html-renderer))) -(defun mh-mail-abbrev-make-syntax-table () - "Call `mail-abbrev-make-syntax-table' if available." - (when (fboundp 'mail-abbrev-make-syntax-table) - (mail-abbrev-make-syntax-table))) - (provide 'mh-gnus) ;; Local Variables: diff --git a/lisp/mh-e/mh-identity.el b/lisp/mh-e/mh-identity.el index cd6cff1daed..faafea71f3f 100644 --- a/lisp/mh-e/mh-identity.el +++ b/lisp/mh-e/mh-identity.el @@ -1,4 +1,4 @@ -;;; mh-identity.el --- Multiple identify support for MH-E. +;;; mh-identity.el --- multiple identify support for MH-E ;; Copyright (C) 2002, 2003, 2004, 2005, 2006 Free Software Foundation, Inc. @@ -27,23 +27,19 @@ ;;; Commentary: ;; Multiple identity support for MH-E. -;; -;; Used to easily set different fields such as From and Organization, as -;; well as different signature files. -;; -;; Customize the variable `mh-identity-list' and an Identity menu will -;; appear in mh-letter-mode. The command 'mh-insert-identity can be used -;; from the command line. + +;; Used to easily set different fields such as From and Organization, +;; as well as different signature files. + +;; Customize the variable `mh-identity-list' and see the Identity menu +;; in MH-Letter mode. The command `mh-insert-identity' can be used +;; to manually insert an identity. ;;; Change Log: ;;; Code: -;;(message "> mh-identity") -(eval-when-compile (require 'mh-acros)) - -(require 'mh-comp) -;;(message "< mh-identity") +(require 'mh-e) (autoload 'mml-insert-tag "mml") @@ -53,11 +49,17 @@ This is normally set as part of an Identity in `mh-identity-list'.") (make-variable-buffer-local 'mh-identity-pgg-default-user-id) +(defvar mh-identity-menu nil + "The Identity menu.") + +(defalias 'mh-identity-make-menu-no-autoload 'mh-identity-make-menu) + ;;;###mh-autoload (defun mh-identity-make-menu () "Build the Identity menu. This should be called any time `mh-identity-list' or -`mh-auto-fields-list' change." +`mh-auto-fields-list' change. +See `mh-identity-add-menu'." (easy-menu-define mh-identity-menu mh-letter-mode-map "MH-E identity menu" (append @@ -88,13 +90,11 @@ This should be called any time `mh-identity-list' or )))) ;;;###mh-autoload -(defun mh-identity-list-set (symbol value) - "Update the `mh-identity-list' variable, and rebuild the menu. -Sets the default for SYMBOL (for example, `mh-identity-list') to -VALUE (as set in customization). This is called after 'customize -is used to alter `mh-identity-list'." - (set-default symbol value) - (mh-identity-make-menu)) +(defun mh-identity-add-menu () + "Add the current Identity menu. +See `mh-identity-make-menu'." + (if mh-identity-menu + (easy-menu-add mh-identity-menu))) (defvar mh-identity-local nil "Buffer-local variable that holds the identity currently in use.") @@ -134,8 +134,13 @@ valid header field." 'mh-identity-handler-default)) ;;;###mh-autoload -(defun mh-insert-identity (identity) +(defun mh-insert-identity (identity &optional maybe-insert) "Insert fields specified by given IDENTITY. + +In a program, do not insert fields if MAYBE-INSERT is non-nil, +`mh-identity-default' is non-nil, and fields have already been +inserted. + See `mh-identity-list'." (interactive (list (completing-read @@ -144,29 +149,35 @@ See `mh-identity-list'." (cons '("None") (mapcar 'list (mapcar 'car mh-identity-list))) (mapcar 'list (mapcar 'car mh-identity-list))) - nil t))) - (save-excursion - ;;First remove old settings, if any. - (when mh-identity-local - (let ((pers-list (cadr (assoc mh-identity-local mh-identity-list)))) - (while pers-list - (let* ((field (caar pers-list)) - (handler (mh-identity-field-handler field))) - (funcall handler field 'remove)) - (setq pers-list (cdr pers-list))))) - ;; Then insert the replacement - (when (not (equal "None" identity)) - (let ((pers-list (cadr (assoc identity mh-identity-list)))) - (while pers-list - (let* ((field (caar pers-list)) - (value (cdar pers-list)) - (handler (mh-identity-field-handler field))) - (funcall handler field 'add value)) - (setq pers-list (cdr pers-list)))))) - ;; Remember what is in use in this buffer - (if (equal "None" identity) - (setq mh-identity-local nil) - (setq mh-identity-local identity))) + nil t) + nil)) + + (when (or (not maybe-insert) + (and (boundp 'mh-identity-default) + mh-identity-default + (not mh-identity-local))) + (save-excursion + ;;First remove old settings, if any. + (when mh-identity-local + (let ((pers-list (cadr (assoc mh-identity-local mh-identity-list)))) + (while pers-list + (let* ((field (caar pers-list)) + (handler (mh-identity-field-handler field))) + (funcall handler field 'remove)) + (setq pers-list (cdr pers-list))))) + ;; Then insert the replacement + (when (not (equal "None" identity)) + (let ((pers-list (cadr (assoc identity mh-identity-list)))) + (while pers-list + (let* ((field (caar pers-list)) + (value (cdar pers-list)) + (handler (mh-identity-field-handler field))) + (funcall handler field 'add value)) + (setq pers-list (cdr pers-list)))))) + ;; Remember what is in use in this buffer + (if (equal "None" identity) + (setq mh-identity-local nil) + (setq mh-identity-local identity)))) ;;;###mh-autoload (defun mh-identity-handler-gpg-identity (field action &optional value) @@ -268,7 +279,7 @@ bottom of the header. If action is 'add, the VALUE is added." (t (goto-char (point-min)) (if (not top) - (mh-goto-header-end 0)) + (mh-goto-header-end 0)) (insert field-colon " " value "\n"))))))) ;;;###mh-autoload diff --git a/lisp/mh-e/mh-inc.el b/lisp/mh-e/mh-inc.el index 72d84353ff6..e35dfc57834 100644 --- a/lisp/mh-e/mh-inc.el +++ b/lisp/mh-e/mh-inc.el @@ -1,5 +1,5 @@ ;;; mh-inc.el --- MH-E "inc" and separate mail spool handling -;; + ;; Copyright (C) 2003, 2004, 2006 Free Software Foundation, Inc. ;; Author: Peter S. Galbraith <psg@debian.org> @@ -26,33 +26,42 @@ ;;; Commentary: -;; Support for inc. In addition to reading from the system mailbox, inc can -;; also be used to incorporate mail from multiple spool files into separate -;; folders. See "C-h v mh-inc-spool-list". +;; Support for inc. In addition to reading from the system mailbox, +;; inc can also be used to incorporate mail from multiple spool files +;; into separate folders. See "C-h v mh-inc-spool-list". ;;; Change Log: ;;; Code: -;;(message "> mh-inc") -(eval-when-compile (require 'mh-acros)) +(require 'mh-e) (mh-require-cl) -;;(message "< mh-inc") - -(defvar mh-inc-spool-map (make-sparse-keymap) - "Keymap for MH-E's mh-inc-spool commands.") (defvar mh-inc-spool-map-help nil - "Help text to for `mh-inc-spool-map'.") + "Help text for `mh-inc-spool-map'.") (define-key mh-inc-spool-map "?" '(lambda () (interactive) (if mh-inc-spool-map-help - (let ((mh-help-messages (list (list nil mh-inc-spool-map-help)))) - (mh-help)) + (mh-help mh-inc-spool-map-help) (mh-ephem-message - "There are no keys defined yet. Customize `mh-inc-spool-list'")))) + "There are no keys defined yet; customize `mh-inc-spool-list'")))) + +;;;###mh-autoload +(defun mh-inc-spool-make () + "Make all commands and defines keys for contents of `mh-inc-spool-list'." + (setq mh-inc-spool-map-help nil) + (when mh-inc-spool-list + (loop for elem in mh-inc-spool-list + do (let ((spool (nth 0 elem)) + (folder (nth 1 elem)) + (key (nth 2 elem))) + (progn + (mh-inc-spool-generator folder spool) + (mh-inc-spool-def-key key folder)))))) + +(defalias 'mh-inc-spool-make-no-autoload 'mh-inc-spool-make) (defun mh-inc-spool-generator (folder spool) "Create a command to inc into FOLDER from SPOOL file." @@ -62,7 +71,7 @@ (set spool1 spool) (setf (symbol-function (intern (concat "mh-inc-spool-" folder))) `(lambda () - ,(format "Inc spool file %s into folder %s" spool folder) + ,(format "Inc spool file %s into folder %s." spool folder) (interactive) (mh-inc-folder ,spool1 (concat "+" ,folder1)))))) @@ -71,32 +80,9 @@ (when (not (= 0 key)) (define-key mh-inc-spool-map (format "%c" key) (intern (concat "mh-inc-spool-" folder))) - (setq mh-inc-spool-map-help (concat mh-inc-spool-map-help "[" - (char-to-string key) - "] inc " folder " folder\n")))) - -;; Shush compiler. -(eval-when-compile (defvar mh-inc-spool-list)) - -(defun mh-inc-spool-make () - "Make all commands and defines keys for contents of `mh-inc-spool-list'." - (when mh-inc-spool-list - (setq mh-inc-spool-map-help nil) - (loop for elem in mh-inc-spool-list - do (let ((spool (nth 0 elem)) - (folder (nth 1 elem)) - (key (nth 2 elem))) - (progn - (mh-inc-spool-generator folder spool) - (mh-inc-spool-def-key key folder)))))) - -;;;###mh-autoload -(defun mh-inc-spool-list-set (symbol value) - "Set-default SYMBOL to VALUE to update the `mh-inc-spool-list' variable. -Also rebuilds the user commands. -This is called after 'customize is used to alter `mh-inc-spool-list'." - (set-default symbol value) - (mh-inc-spool-make)) + (add-to-list 'mh-inc-spool-map-help + (concat "[" (char-to-string key) "] inc " folder " folder\n") + t))) (provide 'mh-inc) diff --git a/lisp/mh-e/mh-init.el b/lisp/mh-e/mh-init.el deleted file mode 100644 index 180db2b22a5..00000000000 --- a/lisp/mh-e/mh-init.el +++ /dev/null @@ -1,441 +0,0 @@ -;;; mh-init.el --- MH-E initialization - -;; Copyright (C) 2003, 2004, 2005, 2006 Free Software Foundation, Inc. - -;; Author: Peter S. Galbraith <psg@debian.org> -;; 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., 51 Franklin Street, Fifth Floor, -;; Boston, MA 02110-1301, USA. - -;;; Commentary: - -;; Sets up the MH variant (currently nmh, MH, or GNU mailutils). -;; -;; Users may customize `mh-variant' to switch between available variants. -;; Available MH variants are returned by the function `mh-variants'. -;; Developers may check which variant is currently in use with the -;; variable `mh-variant-in-use' or the function `mh-variant-p'. -;; -;; Also contains code that is used at load or initialization time only. - -;;; Change Log: - -;;; Code: - -;;(message "> mh-init") -(eval-when-compile (require 'mh-acros)) -(mh-require-cl) -(require 'mh-buffers) -(require 'mh-exec) -;;(message "< mh-init") - -(defvar mh-sys-path - '("/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/" - "/usr/local/bin/mu-mh/" ; GNU mailutils - default - "/usr/bin/mu-mh/") ; GNU mailutils - packaged - "List of directories to search for variants of the MH variant. -The list `exec-path' is searched in addition to this list. -There's no need for users to modify this list. Instead add extra -directories to the customizable variable `mh-path'.") - -;; Set for local environment: -;; mh-progs and mh-lib used to be set in paths.el, which tried to -;; figure out at build time which of several possible directories MH -;; was installed into. But if you installed MH after building Emacs, -;; this would almost certainly be wrong, so now we do it at run time. - -(defvar mh-flists-present-flag nil - "Non-nil means that we have \"flists\".") - -(defvar mh-variants nil - "List describing known MH variants. -Do not access this variable directly as it may not have yet been initialized. -Use the function `mh-variants' instead.") - -;;;###mh-autoload -(defun mh-variants () - "Return a list of installed variants of MH on the system. -This function looks for MH in `mh-sys-path', `mh-path' and -`exec-path'. The format of the list of variants that is returned -is described by the variable `mh-variants'." - (if mh-variants - mh-variants - (let ((list-unique)) - ;; Make a unique list of directories, keeping the given order. - ;; We don't want the same MH variant to be listed multiple times. - (loop for dir in (append mh-path mh-sys-path exec-path) do - (setq dir (file-chase-links (directory-file-name dir))) - (add-to-list 'list-unique dir)) - (loop for dir in (nreverse list-unique) do - (when (and dir (file-directory-p dir) (file-readable-p dir)) - (let ((variant (mh-variant-info dir))) - (if variant - (add-to-list 'mh-variants variant))))) - mh-variants))) - -(defun mh-variant-info (dir) - "Return MH variant found in DIR, or nil if none present." - (save-excursion - (let ((tmp-buffer (get-buffer-create mh-temp-buffer))) - (set-buffer tmp-buffer) - (cond - ((mh-variant-mh-info dir)) - ((mh-variant-nmh-info dir)) - ((mh-variant-mu-mh-info dir)))))) - -(defun mh-variant-mh-info (dir) - "Return info for MH variant in DIR assuming a temporary buffer is setup." - ;; MH does not have the -version option. - ;; Its version number is included in the output of "-help" as: - ;; - ;; version: MH 6.8.4 #2[UCI] (burrito) of Fri Jan 15 20:01:39 EST 1999 - ;; options: [ATHENA] [BIND] [DUMB] [LIBLOCKFILE] [LOCALE] [MAILGROUP] [MHE] - ;; [MHRC] [MIME] [MORE='"/usr/bin/sensible-pager"'] [NLINK_HACK] - ;; [NORUSERPASS] [OVERHEAD] [POP] [POPSERVICE='"pop-3"'] [RENAME] - ;; [RFC1342] [RPATHS] [RPOP] [SENDMTS] [SMTP] [SOCKETS] - ;; [SPRINTFTYPE=int] [SVR4] [SYS5] [SYS5DIR] [TERMINFO] - ;; [TYPESIG=void] [UNISTD] [UTK] [VSPRINTF] - (let ((mhparam (expand-file-name "mhparam" dir))) - (when (mh-file-command-p mhparam) - (erase-buffer) - (call-process mhparam nil '(t nil) nil "-help") - (goto-char (point-min)) - (when (search-forward-regexp "version: MH \\(\\S +\\)" nil t) - (let ((version (format "MH %s" (match-string 1)))) - (erase-buffer) - (call-process mhparam nil '(t nil) nil "libdir") - (goto-char (point-min)) - (when (search-forward-regexp "^.*$" nil t) - (let ((libdir (match-string 0))) - `(,version - (variant mh) - (mh-lib-progs ,libdir) - (mh-lib ,libdir) - (mh-progs ,dir) - (flists nil))))))))) - -(defun mh-variant-mu-mh-info (dir) - "Return info for GNU mailutils variant in DIR. -This assumes that a temporary buffer is setup." - ;; 'mhparam -version' output: - ;; mhparam (GNU mailutils 0.3.2) - (let ((mhparam (expand-file-name "mhparam" dir))) - (when (mh-file-command-p mhparam) - (erase-buffer) - (call-process mhparam nil '(t nil) nil "-version") - (goto-char (point-min)) - (when (search-forward-regexp "mhparam (\\(GNU [Mm]ailutils \\S +\\))" - nil t) - (let ((version (match-string 1)) - (mh-progs dir)) - `(,version - (variant mu-mh) - (mh-lib-progs ,(mh-profile-component "libdir")) - (mh-lib ,(mh-profile-component "etcdir")) - (mh-progs ,dir) - (flists ,(file-exists-p - (expand-file-name "flists" dir))))))))) - -(defun mh-variant-nmh-info (dir) - "Return info for nmh variant in DIR assuming a temporary buffer is setup." - ;; `mhparam -version' outputs: - ;; mhparam -- nmh-1.1-RC1 [compiled on chaak at Fri Jun 20 11:03:28 PDT 2003] - (let ((mhparam (expand-file-name "mhparam" dir))) - (when (mh-file-command-p mhparam) - (erase-buffer) - (call-process mhparam nil '(t nil) nil "-version") - (goto-char (point-min)) - (when (search-forward-regexp "mhparam -- nmh-\\(\\S +\\)" nil t) - (let ((version (format "nmh %s" (match-string 1))) - (mh-progs dir)) - `(,version - (variant nmh) - (mh-lib-progs ,(mh-profile-component "libdir")) - (mh-lib ,(mh-profile-component "etcdir")) - (mh-progs ,dir) - (flists ,(file-exists-p - (expand-file-name "flists" dir))))))))) - -(defun mh-file-command-p (file) - "Return t if file FILE is the name of a executable regular file." - (and (file-regular-p file) (file-executable-p file))) - -(defvar mh-variant-in-use nil - "The MH variant currently in use; a string with variant and version number. -This differs from `mh-variant' when the latter is set to -\"autodetect\".") - -;;;###mh-autoload -(defun mh-variant-set (variant) - "Set the MH variant to VARIANT. -Sets `mh-progs', `mh-lib', `mh-lib-progs' and -`mh-flists-present-flag'. -If the VARIANT is \"autodetect\", then first try nmh, then MH and -finally GNU mailutils." - (interactive - (list (completing-read - "MH variant: " - (mapcar (lambda (x) (list (car x))) (mh-variants)) - nil t))) - (let ((valid-list (mapcar (lambda (x) (car x)) (mh-variants)))) - (cond - ((eq variant 'none)) - ((eq variant 'autodetect) - (cond - ((mh-variant-set-variant 'nmh) - (message "%s installed as MH variant" mh-variant-in-use)) - ((mh-variant-set-variant 'mh) - (message "%s installed as MH variant" mh-variant-in-use)) - ((mh-variant-set-variant 'mu-mh) - (message "%s installed as MH variant" mh-variant-in-use)) - (t - (message "No MH variant found on the system")))) - ((member variant valid-list) - (when (not (mh-variant-set-variant variant)) - (message "Warning: %s variant not found. Autodetecting..." variant) - (mh-variant-set 'autodetect))) - (t - (message "Unknown variant; use %s" - (mapconcat '(lambda (x) (format "%s" (car x))) - (mh-variants) " or ")))))) - -(defun mh-variant-set-variant (variant) - "Setup the system variables for the MH variant named VARIANT. -If VARIANT is a string, use that key in the alist returned by the -function `mh-variants'. -If VARIANT is a symbol, select the first entry that matches that -variant." - (cond - ((stringp variant) ;e.g. "nmh 1.1-RC1" - (when (assoc variant (mh-variants)) - (let* ((alist (cdr (assoc variant (mh-variants)))) - (lib-progs (cadr (assoc 'mh-lib-progs alist))) - (lib (cadr (assoc 'mh-lib alist))) - (progs (cadr (assoc 'mh-progs alist))) - (flists (cadr (assoc 'flists alist)))) - ;;(set-default mh-variant variant) - (setq mh-x-mailer-string nil - mh-flists-present-flag flists - mh-lib-progs lib-progs - mh-lib lib - mh-progs progs - mh-variant-in-use variant)))) - ((symbolp variant) ;e.g. 'nmh (pick the first match) - (loop for variant-list in (mh-variants) - when (eq variant (cadr (assoc 'variant (cdr variant-list)))) - return (let* ((version (car variant-list)) - (alist (cdr variant-list)) - (lib-progs (cadr (assoc 'mh-lib-progs alist))) - (lib (cadr (assoc 'mh-lib alist))) - (progs (cadr (assoc 'mh-progs alist))) - (flists (cadr (assoc 'flists alist)))) - ;;(set-default mh-variant flavor) - (setq mh-x-mailer-string nil - mh-flists-present-flag flists - mh-lib-progs lib-progs - mh-lib lib - mh-progs progs - mh-variant-in-use version) - t))))) - -;;;###mh-autoload -(defun mh-variant-p (&rest variants) - "Return t if variant is any of VARIANTS. -Currently known variants are 'MH, 'nmh, and 'mu-mh." - (let ((variant-in-use - (cadr (assoc 'variant (assoc mh-variant-in-use (mh-variants)))))) - (not (null (member variant-in-use variants))))) - - - -;;; Read MH Profile - -(defvar mh-find-path-run nil - "Non-nil if `mh-find-path' has been run already. -Do not access this variable; `mh-find-path' already uses it to -avoid running more than once.") - -(defun mh-find-path () - "Set variables from user's MH profile. - -This function sets `mh-user-path' from your \"Path:\" MH profile -component (but defaults to \"Mail\" if one isn't present), -`mh-draft-folder' from \"Draft-Folder:\", `mh-unseen-seq' from -\"Unseen-Sequence:\", `mh-previous-seq' from -\"Previous-Sequence:\", and `mh-inbox' from \"Inbox:\" (defaults -to \"+inbox\"). - -The hook `mh-find-path-hook' is run after these variables have -been set. This hook can be used the change the value of these -variables if you need to run with different values between MH and -MH-E." - (unless mh-find-path-run - ;; Sanity checks. - (if (and (getenv "MH") - (not (file-readable-p (getenv "MH")))) - (error "MH environment variable contains unreadable file %s" - (getenv "MH"))) - (if (null (mh-variants)) - (error "Install MH and run install-mh before running MH-E")) - (let ((profile "~/.mh_profile")) - (if (not (file-readable-p profile)) - (error "Run install-mh before running MH-E"))) - ;; Read MH profile. - (setq mh-user-path (mh-profile-component "Path")) - (if (not mh-user-path) - (setq mh-user-path "Mail")) - (setq mh-user-path - (file-name-as-directory - (expand-file-name mh-user-path (expand-file-name "~")))) - (unless mh-x-image-cache-directory - (setq mh-x-image-cache-directory - (expand-file-name ".mhe-x-image-cache" mh-user-path))) - (setq mh-draft-folder (mh-profile-component "Draft-Folder")) - (if mh-draft-folder - (progn - (if (not (mh-folder-name-p mh-draft-folder)) - (setq mh-draft-folder (format "+%s" mh-draft-folder))) - (if (not (file-exists-p (mh-expand-file-name mh-draft-folder))) - (error - "Draft folder \"%s\" not found; create it and try again" - (mh-expand-file-name mh-draft-folder))))) - (setq mh-inbox (mh-profile-component "Inbox")) - (cond ((not mh-inbox) - (setq mh-inbox "+inbox")) - ((not (mh-folder-name-p mh-inbox)) - (setq mh-inbox (format "+%s" mh-inbox)))) - (setq mh-unseen-seq (mh-profile-component "Unseen-Sequence")) - (if mh-unseen-seq - (setq mh-unseen-seq (intern mh-unseen-seq)) - (setq mh-unseen-seq 'unseen)) ;old MH default? - (setq mh-previous-seq (mh-profile-component "Previous-Sequence")) - (if mh-previous-seq - (setq mh-previous-seq (intern mh-previous-seq))) - (run-hooks 'mh-find-path-hook) - (mh-collect-folder-names) - (setq mh-find-path-run t))) - - - -;;; MH profile - -(defun mh-profile-component (component) - "Return COMPONENT value from mhparam, or nil if unset." - (save-excursion - (mh-exec-cmd-quiet nil "mhparam" "-components" component) - (mh-profile-component-value component))) - -(defun mh-profile-component-value (component) - "Find and return the value of COMPONENT in the current buffer. -Returns nil if the component is not in the buffer." - (let ((case-fold-search t)) - (goto-char (point-min)) - (cond ((not (re-search-forward (format "^%s:" component) nil t)) nil) - ((looking-at "[\t ]*$") nil) - (t - (re-search-forward "[\t ]*\\([^\t \n].*\\)$" nil t) - (let ((start (match-beginning 1))) - (end-of-line) - (buffer-substring start (point))))))) - - - -;;; MH-E images - -;; Shush compiler. -(eval-when-compile (defvar image-load-path)) - -(defvar mh-image-load-path-called-flag nil) - -;;;###mh-autoload -(defun mh-image-load-path () - "Ensure that the MH-E images are accessible by `find-image'. -Images for MH-E are found in ../../etc/images relative to the -files in \"lisp/mh-e\". If `image-load-path' exists (since Emacs -22), then the images directory is added to it if isn't already -there. Otherwise, the images directory is added to the -`load-path' if it isn't already there." - (unless mh-image-load-path-called-flag - (let (mh-library-name mh-image-load-path) - ;; First, find mh-e in the load-path. - (setq mh-library-name (locate-library "mh-e")) - (if (not mh-library-name) - (error "Can not find MH-E in load-path")) - (setq mh-image-load-path - (expand-file-name (concat (file-name-directory mh-library-name) - "../../etc/images"))) - (if (not (file-exists-p mh-image-load-path)) - (error "Can not find image directory %s" mh-image-load-path)) - (if (boundp 'image-load-path) - (add-to-list 'image-load-path mh-image-load-path) - (add-to-list 'load-path mh-image-load-path))) - (setq mh-image-load-path-called-flag t))) - - - -;;; Support routines for mh-customize.el - -(defvar mh-min-colors-defined-flag (and (not mh-xemacs-flag) - (>= emacs-major-version 22)) - "Non-nil means defface supports min-colors display requirement.") - -(defun mh-defface-compat (spec) - "Convert SPEC for defface if necessary to run on older platforms. -Modifies SPEC in place and returns it. See `defface' for the spec definition. - -When `mh-min-colors-defined-flag' is nil, this function finds -display entries with \"min-colors\" requirements and either -removes the \"min-colors\" requirement or strips the display -entirely if the display does not support the number of specified -colors." - (if mh-min-colors-defined-flag - spec - (let ((cells (display-color-cells)) - new-spec) - ;; Remove entries with min-colors, or delete them if we have fewer colors - ;; than they specify. - (loop for entry in (reverse spec) do - (let ((requirement (if (eq (car entry) t) - nil - (assoc 'min-colors (car entry))))) - (if requirement - (when (>= cells (nth 1 requirement)) - (setq new-spec (cons (cons (delq requirement (car entry)) - (cdr entry)) - new-spec))) - (setq new-spec (cons entry new-spec))))) - new-spec))) - -(provide 'mh-init) - -;; Local Variables: -;; indent-tabs-mode: nil -;; sentence-end-double-space: nil -;; End: - -;; arch-tag: e8372aeb-d803-42b1-9c95-3c93ad22f63c -;;; mh-init.el ends here diff --git a/lisp/mh-e/mh-junk.el b/lisp/mh-e/mh-junk.el index 24a2e3020e1..9d02db0dc11 100644 --- a/lisp/mh-e/mh-junk.el +++ b/lisp/mh-e/mh-junk.el @@ -1,4 +1,4 @@ -;;; mh-junk.el --- Interface to anti-spam measures +;;; mh-junk.el --- MH-E interface to anti-spam measures ;; Copyright (C) 2003, 2004, 2005, 2006 Free Software Foundation, Inc. @@ -32,14 +32,10 @@ ;;; Code: -;;(message "< mh-junk") -(eval-when-compile (require 'mh-acros)) -(mh-require-cl) -(require 'mh-buffers) (require 'mh-e) -;;(message "> mh-junk") +(require 'mh-scan) +(mh-require-cl) -;; Interactive functions callable from the folder buffer ;;;###mh-autoload (defun mh-junk-blacklist (range) "Blacklist RANGE as spam. @@ -108,6 +104,7 @@ RANGE is read in interactive use." (defvar mh-spamassassin-executable (executable-find "spamassassin")) (defvar mh-sa-learn-executable (executable-find "sa-learn")) +;;;###mh-autoload (defun mh-spamassassin-blacklist (msg) "Blacklist MSG with SpamAssassin. @@ -189,7 +186,7 @@ SpamAssassin, rebuilds the database after adding words, so you will need to run \"sa-learn --rebuild\" periodically. This can be done by adding the following to your crontab: - 0 * * * * sa-learn --rebuild > /dev/null 2>&1" + 0 * * * * sa-learn --rebuild > /dev/null 2>&1" (unless mh-spamassassin-executable (error "Unable to find the spamassassin executable")) (let ((current-folder mh-current-folder) @@ -220,6 +217,7 @@ done by adding the following to your crontab: (message "Blacklisting message %d...done" msg)) (message "Blacklisting message %d...not done (from my address)" msg))))) +;;;###mh-autoload (defun mh-spamassassin-whitelist (msg) "Whitelist MSG with SpamAssassin. @@ -273,6 +271,7 @@ The name of the rule is RULE and its body is BODY." (if (not buffer-exists) (kill-buffer nil))))) +;;;###mh-autoload (defun mh-spamassassin-identify-spammers () "Identify spammers who are repeat offenders. @@ -322,6 +321,7 @@ information can be used so that you can replace multiple (defvar mh-bogofilter-executable (executable-find "bogofilter")) +;;;###mh-autoload (defun mh-bogofilter-blacklist (msg) "Blacklist MSG with bogofilter. @@ -375,6 +375,7 @@ The \"Bogofilter tuning HOWTO\" describes how you can fine-tune Bogofilter." (call-process mh-bogofilter-executable msg-file mh-junk-background nil "-s"))) +;;;###mh-autoload (defun mh-bogofilter-whitelist (msg) "Whitelist MSG with bogofilter. @@ -391,6 +392,7 @@ See `mh-bogofilter-blacklist' for more information." (defvar mh-spamprobe-executable (executable-find "spamprobe")) +;;;###mh-autoload (defun mh-spamprobe-blacklist (msg) "Blacklist MSG with SpamProbe. @@ -421,6 +423,7 @@ update SpamProbe's training." (call-process mh-spamprobe-executable msg-file mh-junk-background nil "spam"))) +;;;###mh-autoload (defun mh-spamprobe-whitelist (msg) "Whitelist MSG with SpamProbe. diff --git a/lisp/mh-e/mh-letter.el b/lisp/mh-e/mh-letter.el new file mode 100644 index 00000000000..4c614da4ffe --- /dev/null +++ b/lisp/mh-e/mh-letter.el @@ -0,0 +1,1040 @@ +;;; mh-letter.el --- MH-Letter mode + +;; Copyright (C) 1993, 1995, 1997, +;; 2000, 2001, 2002, 2003, 2004, 2005, 2006 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., 51 Franklin Street, Fifth Floor, +;; Boston, MA 02110-1301, USA. + +;;; Commentary: + +;; Mode for composing and sending a draft message. + +;; Functions that would ordinarily be in here that are needed by +;; mh-show.el should be placed in the Message Utilities section in +;; mh-utils.el. That will help prevent the loading of this file until +;; a message is actually composed. + +;;; Change Log: + +;;; Code: + +(require 'mh-e) + +(require 'gnus-util) + +;; Dynamically-created function not found in mh-loaddefs.el. +(autoload 'mh-tool-bar-letter-buttons-init "mh-tool-bar") + +(autoload 'mml-insert-tag "mml") + +;;; Variables + +(defvar mh-letter-complete-function-alist + '((bcc . mh-alias-letter-expand-alias) + (cc . mh-alias-letter-expand-alias) + (dcc . mh-alias-letter-expand-alias) + (fcc . mh-folder-expand-at-point) + (from . mh-alias-letter-expand-alias) + (mail-followup-to . mh-alias-letter-expand-alias) + (mail-reply-to . mh-alias-letter-expand-alias) + (reply-to . mh-alias-letter-expand-alias) + (to . mh-alias-letter-expand-alias)) + "Alist of header fields and completion functions to use.") + +(defvar mh-hidden-header-keymap + (let ((map (make-sparse-keymap))) + (mh-do-in-gnu-emacs + (define-key map [mouse-2] 'mh-letter-toggle-header-field-display-button)) + (mh-do-in-xemacs + (define-key map '(button2) + 'mh-letter-toggle-header-field-display-button)) + map)) + +(defvar mh-yank-hooks nil + "Obsolete hook for modifying a citation just inserted in the mail buffer. + +Each hook function can find the citation between point and mark. +And each hook function should leave point and mark around the +citation text as modified. + +This is a normal hook, misnamed for historical reasons. It is +semi-obsolete and is only used if `mail-citation-hook' is nil.") + + + +;;; Letter Menu + +(eval-when-compile (defvar mh-letter-menu nil)) +(easy-menu-define + mh-letter-menu mh-letter-mode-map "Menu for MH-E letter mode." + '("Letter" + ["Send This Draft" mh-send-letter t] + ["Split Current Line" mh-open-line t] + ["Check Recipient" mh-check-whom t] + ["Yank Current Message" mh-yank-cur-msg t] + ["Insert a Message..." mh-insert-letter t] + ["Insert Signature" mh-insert-signature t] + ("Encrypt/Sign Message" + ["Sign Message" + mh-mml-secure-message-sign mh-pgp-support-flag] + ["Encrypt Message" + mh-mml-secure-message-encrypt mh-pgp-support-flag] + ["Sign+Encrypt Message" + mh-mml-secure-message-signencrypt mh-pgp-support-flag] + ["Disable Security" + mh-mml-unsecure-message mh-pgp-support-flag] + "--" + "Security Method" + ["PGP (MIME)" (setq mh-mml-method-default "pgpmime") + :style radio + :selected (equal mh-mml-method-default "pgpmime")] + ["PGP" (setq mh-mml-method-default "pgp") + :style radio + :selected (equal mh-mml-method-default "pgp")] + ["S/MIME" (setq mh-mml-method-default "smime") + :style radio + :selected (equal mh-mml-method-default "smime")] + "--" + ["Save Method as Default" + (customize-save-variable 'mh-mml-method-default mh-mml-method-default) t] + ) + ["Compose Insertion..." mh-compose-insertion t] + ["Compose Compressed tar (MH)..." + mh-mh-compose-external-compressed-tar t] + ["Compose Get File (MH)..." mh-mh-compose-anon-ftp t] + ["Compose Forward..." mh-compose-forward t] + ;; The next two will have to be merged. But I also need to make sure the + ;; user can't mix tags of both types. + ["Pull in All Compositions (MH)" + mh-mh-to-mime (mh-mh-directive-present-p)] + ["Pull in All Compositions (MML)" + mh-mml-to-mime (mh-mml-tag-present-p)] + ["Revert to Non-MIME Edit (MH)" + mh-mh-to-mime-undo (equal mh-compose-insertion 'mh)] + ["Kill This Draft" mh-fully-kill-draft t])) + + + +;;; MH-Letter Keys + +;; If this changes, modify mh-letter-mode-help-messages accordingly, above. +(gnus-define-keys mh-letter-mode-map + " " mh-letter-complete-or-space + "," mh-letter-confirm-address + "\C-c?" mh-help + "\C-c\C-\\" mh-fully-kill-draft ;if no C-q + "\C-c\C-^" mh-insert-signature ;if no C-s + "\C-c\C-c" mh-send-letter + "\C-c\C-d" mh-insert-identity + "\C-c\C-e" mh-mh-to-mime + "\C-c\C-f\C-a" mh-to-field + "\C-c\C-f\C-b" mh-to-field + "\C-c\C-f\C-c" mh-to-field + "\C-c\C-f\C-d" mh-to-field + "\C-c\C-f\C-f" mh-to-fcc + "\C-c\C-f\C-l" mh-to-field + "\C-c\C-f\C-m" mh-to-field + "\C-c\C-f\C-r" mh-to-field + "\C-c\C-f\C-s" mh-to-field + "\C-c\C-f\C-t" mh-to-field + "\C-c\C-fa" mh-to-field + "\C-c\C-fb" mh-to-field + "\C-c\C-fc" mh-to-field + "\C-c\C-fd" mh-to-field + "\C-c\C-ff" mh-to-fcc + "\C-c\C-fl" mh-to-field + "\C-c\C-fm" mh-to-field + "\C-c\C-fr" mh-to-field + "\C-c\C-fs" mh-to-field + "\C-c\C-ft" mh-to-field + "\C-c\C-i" mh-insert-letter + "\C-c\C-m\C-e" mh-mml-secure-message-encrypt + "\C-c\C-m\C-f" mh-compose-forward + "\C-c\C-m\C-g" mh-mh-compose-anon-ftp + "\C-c\C-m\C-i" mh-compose-insertion + "\C-c\C-m\C-m" mh-mml-to-mime + "\C-c\C-m\C-n" mh-mml-unsecure-message + "\C-c\C-m\C-s" mh-mml-secure-message-sign + "\C-c\C-m\C-t" mh-mh-compose-external-compressed-tar + "\C-c\C-m\C-u" mh-mh-to-mime-undo + "\C-c\C-m\C-x" mh-mh-compose-external-type + "\C-c\C-mee" mh-mml-secure-message-encrypt + "\C-c\C-mes" mh-mml-secure-message-signencrypt + "\C-c\C-mf" mh-compose-forward + "\C-c\C-mg" mh-mh-compose-anon-ftp + "\C-c\C-mi" mh-compose-insertion + "\C-c\C-mm" mh-mml-to-mime + "\C-c\C-mn" mh-mml-unsecure-message + "\C-c\C-mse" mh-mml-secure-message-signencrypt + "\C-c\C-mss" mh-mml-secure-message-sign + "\C-c\C-mt" mh-mh-compose-external-compressed-tar + "\C-c\C-mu" mh-mh-to-mime-undo + "\C-c\C-mx" mh-mh-compose-external-type + "\C-c\C-o" mh-open-line + "\C-c\C-q" mh-fully-kill-draft + "\C-c\C-s" mh-insert-signature + "\C-c\C-t" mh-letter-toggle-header-field-display + "\C-c\C-w" mh-check-whom + "\C-c\C-y" mh-yank-cur-msg + "\C-c\M-d" mh-insert-auto-fields + "\M-\t" mh-letter-complete + "\t" mh-letter-next-header-field-or-indent + [backtab] mh-letter-previous-header-field) + +;; "C-c /" prefix is used in mh-letter-mode by pgp.el and mailcrypt.el. + + + +;;; MH-Letter Help Messages + +;; Group messages logically, more or less. +(defvar mh-letter-mode-help-messages + '((nil + "Send letter: \\[mh-send-letter] " + "Open line: \\[mh-open-line]\n" + "Kill letter: \\[mh-fully-kill-draft] " + "Check recipients: \\[mh-check-whom]\n\n" + "Insert:\n" + " Current message: \\[mh-yank-cur-msg]\n" + " Attachment: \\[mh-compose-insertion]\n" + " Message to forward: \\[mh-compose-forward]\n" + " Signature: \\[mh-insert-signature]\n\n" + "Security:\n" + " Encrypt message: \\[mh-mml-secure-message-encrypt]\n" + " Sign message: \\[mh-mml-secure-message-sign]\n" + " Sign+Encrypt message: \\[mh-mml-secure-message-signencrypt]")) + "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.") + + + +;;; MH-Letter Font Lock + +(defvar mh-letter-font-lock-keywords + `(,@(mh-show-font-lock-keywords-with-cite) + (mh-font-lock-field-data + (1 'mh-letter-header-field prepend t))) + "Additional expressions to highlight in MH-Letter buffers.") + +(defun mh-font-lock-field-data (limit) + "Find header field region between point and LIMIT." + (and (< (point) (mh-letter-header-end)) + (< (point) limit) + (let ((end (min limit (mh-letter-header-end))) + (point (point)) + data-end data-begin field) + (end-of-line) + (setq data-end (if (re-search-forward "^[^ \t]" end t) + (match-beginning 0) + end)) + (goto-char (1- data-end)) + (if (not (re-search-backward "\\(^[^ \t][^:]*\\):[ \t]*" nil t)) + (setq data-begin (point-min)) + (setq data-begin (match-end 0)) + (setq field (match-string 1))) + (setq data-begin (max point data-begin)) + (goto-char (if (equal point data-end) (1+ data-end) data-end)) + (cond ((and field (mh-letter-skipped-header-field-p field)) + (set-match-data nil) + nil) + (t (set-match-data + (list data-begin data-end data-begin data-end)) + t))))) + +(defun mh-letter-header-end () + "Find the end of the message header. +This function is to be used only for font locking. It works by +searching for `mh-mail-header-separator' in the buffer." + (save-excursion + (goto-char (point-min)) + (cond ((equal mh-mail-header-separator "") (point-min)) + ((search-forward (format "\n%s\n" mh-mail-header-separator) nil t) + (line-beginning-position 0)) + (t (point-min))))) + + + +;;; MH-Letter Mode + +(defvar mh-letter-buttons-init-flag nil) + +;; Shush compiler. +(eval-when-compile (mh-do-in-xemacs (defvar font-lock-defaults))) + +;; Ensure new buffers won't get this mode if default-major-mode is nil. +(put 'mh-letter-mode 'mode-class 'special) + +;;;###mh-autoload +(define-derived-mode mh-letter-mode mail-mode "MH-Letter" + "Mode for composing letters in MH-E\\<mh-letter-mode-map>. + +When you have finished composing, type \\[mh-send-letter] to send +the message using the MH mail handling system. + +There are two types of tags used by MH-E when composing MIME +messages: MML and MH. The option `mh-compose-insertion' controls +what type of tags are inserted by MH-E commands. These tags can +be converted to MIME body parts by running \\[mh-mh-to-mime] for +MH-style directives or \\[mh-mml-to-mime] for MML tags. + +Options that control this mode can be changed with +\\[customize-group]; specify the \"mh-compose\" group. + +When a message is composed, the hooks `text-mode-hook', +`mail-mode-hook', and `mh-letter-mode-hook' are run (in that +order). + +\\{mh-letter-mode-map}" + (mh-find-path) + (make-local-variable 'mh-send-args) + (make-local-variable 'mh-annotate-char) + (make-local-variable 'mh-annotate-field) + (make-local-variable 'mh-previous-window-config) + (make-local-variable 'mh-sent-from-folder) + (make-local-variable 'mh-sent-from-msg) + (mh-do-in-gnu-emacs + (unless mh-letter-buttons-init-flag + (mh-tool-bar-letter-buttons-init) + (setq mh-letter-buttons-init-flag t))) + ;; Set the local value of mh-mail-header-separator according to what is + ;; present in the buffer... + (set (make-local-variable 'mh-mail-header-separator) + (save-excursion + (goto-char (mh-mail-header-end)) + (buffer-substring-no-properties (point) (line-end-position)))) + (make-local-variable 'mail-header-separator) + (setq mail-header-separator mh-mail-header-separator) ;override sendmail.el + (mh-set-help mh-letter-mode-help-messages) + (setq buffer-invisibility-spec '((vanish . t) t)) + (set (make-local-variable 'line-move-ignore-invisible) t) + + ;; Enable undo since a show-mode buffer might have been reused. + (buffer-enable-undo) + (set (make-local-variable 'tool-bar-map) mh-letter-tool-bar-map) + (mh-funcall-if-exists mh-tool-bar-init :letter) + (make-local-variable 'font-lock-defaults) + (cond + ((or (equal mh-highlight-citation-style 'font-lock) + (equal mh-highlight-citation-style 'gnus)) + ;; Let's use font-lock even if gnus is used in show-mode. The reason + ;; is that gnus uses static text properties which are not appropriate + ;; for a buffer that will be edited. So the choice here is either fontify + ;; the citations and header... + (setq font-lock-defaults '(mh-letter-font-lock-keywords t))) + (t + ;; ...or the header only + (setq font-lock-defaults '((mh-show-font-lock-keywords) t)))) + (easy-menu-add mh-letter-menu) + (setq fill-column mh-letter-fill-column) + ;; If text-mode-hook turned on auto-fill, tune it for messages + (when auto-fill-function + (make-local-variable 'auto-fill-function) + (setq auto-fill-function 'mh-auto-fill-for-letter))) + + + +;;; MH-Letter Commands + +;; Alphabetical. +;; See also mh-comp.el and mh-mime.el. + +(defun mh-check-whom () + "Verify recipients, showing expansion of any aliases. + +This command expands aliases so you can check the actual address(es) +in the alias. A new buffer named \"*MH-E Recipients*\" is created with +the output of \"whom\"." + (interactive) + (let ((file-name buffer-file-name)) + (save-buffer) + (message "Checking recipients...") + (mh-in-show-buffer (mh-recipients-buffer) + (bury-buffer (current-buffer)) + (erase-buffer) + (mh-exec-cmd-output "whom" t file-name)) + (message "Checking recipients...done"))) + +(defun mh-insert-letter (folder message verbatim) + "Insert a message. + +This command prompts you for the FOLDER and MESSAGE number, which +defaults to the current message in that folder. It then inserts +the message, indented by `mh-ins-buf-prefix' (\"> \") unless +`mh-yank-behavior' is set to one of the supercite flavors in +which case supercite is used to format the message. Certain +undesirable header fields (see +`mh-invisible-header-fields-compiled') are removed before +insertion. + +If given a prefix argument VERBATIM, the header is left intact, the +message is not indented, and \"> \" is not inserted before each line. +This command leaves the mark before the letter and point after it." + (interactive + (let* ((folder + (mh-prompt-for-folder "Message from" + mh-sent-from-folder nil)) + (default + (if (and (equal folder mh-sent-from-folder) + (numberp mh-sent-from-msg)) + mh-sent-from-msg + (nth 0 (mh-translate-range folder "cur")))) + (message + (read-string (concat "Message number" + (or (and default + (format " (default %d): " default)) + ": "))))) + (list folder message current-prefix-arg))) + (save-restriction + (narrow-to-region (point) (point)) + (let ((start (point-min))) + (if (and (equal message "") (numberp mh-sent-from-msg)) + (setq message (int-to-string mh-sent-from-msg))) + (insert-file-contents + (expand-file-name message (mh-expand-file-name folder))) + (when (not verbatim) + (mh-clean-msg-header start mh-invisible-header-fields-compiled nil) + (goto-char (point-max)) ;Needed for sc-cite-original + (push-mark) ;Needed for sc-cite-original + (goto-char (point-min)) ;Needed for sc-cite-original + (mh-insert-prefix-string mh-ins-buf-prefix))))) + +;;;###mh-autoload +(defun mh-insert-signature (&optional file) + "Insert signature in message. + +This command inserts your signature at the current cursor location. + +By default, the text of your signature is taken from the file +\"~/.signature\". You can read from other sources by changing the +option `mh-signature-file-name'. + +A signature separator (\"-- \") will be added if the signature block +does not contain one and `mh-signature-separator-flag' is on. + +The hook `mh-insert-signature-hook' is run after the signature is +inserted. Hook functions may access the actual name of the file or the +function used to insert the signature with `mh-signature-file-name'. + +The signature can also be inserted using Identities (see +`mh-identity-list'). + +In a program, you can pass in a signature FILE." + (interactive) + (save-excursion + (insert "\n") + (let ((mh-signature-file-name (or file mh-signature-file-name)) + (mh-mh-p (mh-mh-directive-present-p)) + (mh-mml-p (mh-mml-tag-present-p))) + (save-restriction + (narrow-to-region (point) (point)) + (cond + ((mh-file-is-vcard-p mh-signature-file-name) + (if (equal mh-compose-insertion 'mml) + (insert "<#part type=\"text/x-vcard\" filename=\"" + mh-signature-file-name + "\" disposition=inline description=VCard>\n<#/part>") + (insert "#text/x-vcard; name=\"" + (file-name-nondirectory mh-signature-file-name) + "\" [VCard] " (expand-file-name mh-signature-file-name)))) + (t + (cond + (mh-mh-p + (insert "#\n" "Content-Description: Signature\n")) + (mh-mml-p + (mml-insert-tag 'part 'type "text/plain" 'disposition "inline" + 'description "Signature"))) + (cond ((null mh-signature-file-name)) + ((and (stringp mh-signature-file-name) + (file-readable-p mh-signature-file-name)) + (insert-file-contents mh-signature-file-name)) + ((functionp mh-signature-file-name) + (funcall mh-signature-file-name))))) + (save-restriction + (widen) + (run-hooks 'mh-insert-signature-hook)) + (goto-char (point-min)) + (when (and (not (mh-file-is-vcard-p mh-signature-file-name)) + mh-signature-separator-flag + (> (point-max) (point-min)) + (not (mh-signature-separator-p))) + (cond (mh-mh-p + (forward-line 2)) + (mh-mml-p + (forward-line 1))) + (insert mh-signature-separator)) + (if (not (> (point-max) (point-min))) + (message "No signature found"))))) + (force-mode-line-update)) + +(defun mh-letter-complete (arg) + "Perform completion on header field or word preceding point. + +If the field contains addresses (for example, \"To:\" or \"Cc:\") +or folders (for example, \"Fcc:\") then this command will provide +alias completion. In the body of the message, this command runs +`mh-letter-complete-function' instead, which is set to +`ispell-complete-word' by default. This command takes a prefix +argument ARG that is passed to the +`mh-letter-complete-function'." + (interactive "P") + (let ((func nil)) + (cond ((not (mh-in-header-p)) + (funcall mh-letter-complete-function arg)) + ((setq func (cdr (assoc (mh-letter-header-field-at-point) + mh-letter-complete-function-alist))) + (funcall func)) + (t (funcall mh-letter-complete-function arg))))) + +(defun mh-letter-complete-or-space (arg) + "Perform completion or insert space. + +Turn on the option `mh-compose-space-does-completion-flag' to use +this command to perform completion in the header. Otherwise, a +space is inserted; use a prefix argument ARG to specify more than +one space." + (interactive "p") + (let ((func nil) + (end-of-prev (save-excursion + (goto-char (mh-beginning-of-word)) + (mh-beginning-of-word -1)))) + (cond ((not mh-compose-space-does-completion-flag) + (self-insert-command arg)) + ((not (mh-in-header-p)) (self-insert-command arg)) + ((> (point) end-of-prev) (self-insert-command arg)) + ((setq func (cdr (assoc (mh-letter-header-field-at-point) + mh-letter-complete-function-alist))) + (funcall func)) + (t (self-insert-command arg))))) + +(defun mh-letter-confirm-address () + "Flash alias expansion. + +Addresses are separated by a comma\; when you press the comma, +this command flashes the alias expansion in the minibuffer if +`mh-alias-flash-on-comma' is turned on." + (interactive) + (cond ((not (mh-in-header-p)) (self-insert-command 1)) + ((eq (cdr (assoc (mh-letter-header-field-at-point) + mh-letter-complete-function-alist)) + 'mh-alias-letter-expand-alias) + (mh-alias-reload-maybe) + (mh-alias-minibuffer-confirm-address)) + (t (self-insert-command 1)))) + +(defun mh-letter-next-header-field-or-indent (arg) + "Cycle to next field. + +Within the header of the message, this command moves between +fields that are highlighted with the face +`mh-letter-header-field', skipping those fields listed in +`mh-compose-skipped-header-fields'. After the last field, this +command then moves point to the message body before cycling back +to the first field. If point is already past the first line of +the message body, then this command indents by calling +`indent-relative' with the given prefix argument ARG." + (interactive "P") + (let ((header-end (save-excursion + (goto-char (mh-mail-header-end)) + (forward-line) + (point)))) + (if (> (point) header-end) + (indent-relative arg) + (mh-letter-next-header-field)))) + +(defun mh-letter-previous-header-field () + "Cycle to the previous header field. + +This command moves backwards between the fields and cycles to the +body of the message after the first field. Unlike the command +\\[mh-letter-next-header-field-or-indent], it will always take +point to the last field from anywhere in the body." + (interactive) + (let ((header-end (mh-mail-header-end))) + (if (>= (point) header-end) + (goto-char header-end) + (mh-header-field-beginning)) + (cond ((re-search-backward mh-letter-header-field-regexp nil t) + (if (mh-letter-skipped-header-field-p (match-string 1)) + (mh-letter-previous-header-field) + (goto-char (match-end 0)) + (mh-letter-skip-leading-whitespace-in-header-field))) + (t (goto-char header-end) + (forward-line))))) + +;;;###mh-autoload +(defun mh-letter-toggle-header-field-display (arg) + "Toggle display of header field at point. + +Use this command to display truncated header fields. This command +is a toggle so entering it again will hide the field. This +command takes a prefix argument ARG: if negative then the field +is hidden, if positive then the field is displayed." + (interactive (list nil)) + (when (and (mh-in-header-p) + (progn + (end-of-line) + (re-search-backward mh-letter-header-field-regexp nil t))) + (let ((buffer-read-only nil) + (modified-flag (buffer-modified-p)) + (begin (point)) + end) + (end-of-line) + (setq end (1- (if (re-search-forward "^[^ \t]" nil t) + (match-beginning 0) + (point-max)))) + (goto-char begin) + ;; Make it clickable... + (add-text-properties begin end `(keymap ,mh-hidden-header-keymap + mouse-face highlight)) + (unwind-protect + (cond ((or (and (not arg) + (text-property-any begin end 'invisible 'vanish)) + (and (numberp arg) (>= arg 0)) + (and (eq arg 'long) (> (line-beginning-position 5) end))) + (remove-text-properties begin end '(invisible nil)) + (search-forward ":" (line-end-position) t) + (mh-letter-skip-leading-whitespace-in-header-field)) + ;; XXX Redesign to make usable by user. Perhaps use a positive + ;; numeric prefix to make that many lines visible. + ((eq arg 'long) + (end-of-line 4) + (mh-letter-truncate-header-field end) + (beginning-of-line)) + (t (end-of-line) + (mh-letter-truncate-header-field end) + (beginning-of-line))) + (set-buffer-modified-p modified-flag))))) + +(defun mh-open-line () + "Insert a newline and leave point before it. + +This command is similar to the command \\[open-line] in that it +inserts a newline after point. It differs in that it also inserts +the right number of quoting characters and spaces so that the +next line begins in the same column as it was. This is useful +when breaking up paragraphs in replies." + (interactive) + (let ((column (current-column)) + (prefix (mh-current-fill-prefix))) + (if (> (length prefix) column) + (message "Sorry, point seems to be within the line prefix") + (newline 2) + (insert prefix) + (while (> column (current-column)) + (insert " ")) + (forward-line -1)))) + +(defun mh-to-fcc (&optional folder) + "Move to \"Fcc:\" header field. + +This command will prompt you for the FOLDER name in which to file +a copy of the draft." + (interactive (list (mh-prompt-for-folder + "Fcc" + (or (and mh-default-folder-for-message-function + (save-excursion + (goto-char (point-min)) + (funcall + mh-default-folder-for-message-function))) + "") + t))) + (let ((last-input-char ?\C-f)) + (expand-abbrev) + (save-excursion + (mh-to-field) + (insert (if (mh-folder-name-p folder) + (substring folder 1) + folder))))) + +(defvar mh-to-field-choices '(("a" . "Mail-Reply-To:") + ("b" . "Bcc:") + ("c" . "Cc:") + ("d" . "Dcc:") + ("f" . "Fcc:") + ("l" . "Mail-Followup-To:") + ("m" . "From:") + ("r" . "Reply-To:") + ("s" . "Subject:") + ("t" . "To:")) + "Alist of (final-character . field-name) choices for `mh-to-field'.") + +(defun mh-to-field () + "Move to specified header field. + +The field is indicated by the previous keystroke (the last +keystroke of the command) according to the list in the variable +`mh-to-field-choices'. +Create the field if it does not exist. +Set the mark to point before moving." + (interactive) + (expand-abbrev) + (let ((target (cdr (or (assoc (char-to-string (logior last-input-char ?`)) + mh-to-field-choices) + ;; also look for a char for version 4 compat + (assoc (logior last-input-char ?`) + mh-to-field-choices)))) + (case-fold-search t)) + (push-mark) + (cond ((mh-position-on-field target) + (let ((eol (point))) + (skip-chars-backward " \t") + (delete-region (point) eol)) + (if (and (not (eq (logior last-input-char ?`) ?s)) + (save-excursion + (backward-char 1) + (not (looking-at "[:,]")))) + (insert ", ") + (insert " "))) + (t + (if (mh-position-on-field "To:") + (forward-line 1)) + (insert (format "%s \n" target)) + (backward-char 1))))) + +;;;###mh-autoload +(defun mh-yank-cur-msg () + "Insert the current message into the draft buffer. + +It is often useful to insert a snippet of text from a letter that +someone mailed to provide some context for your reply. This +command does this by adding an attribution, yanking a portion of +text from the message to which you're replying, and inserting +`mh-ins-buf-prefix' (`> ') before each line. + +The attribution consists of the sender's name and email address +followed by the content of the option +`mh-extract-from-attribution-verb'. + +You can also turn on the option +`mh-delete-yanked-msg-window-flag' to delete the window +containing the original message after yanking it to make more +room on your screen for your reply. + +You can control how the message to which you are replying is +yanked into your reply using `mh-yank-behavior'. + +If this isn't enough, you can gain full control over the +appearance of the included text by setting `mail-citation-hook' +to a function that modifies it. For example, if you set this hook +to `trivial-cite' (which is NOT part of Emacs), set +`mh-yank-behavior' to \"Body and Header\" (see URL +`http://shasta.cs.uiuc.edu/~lrclause/tc.html'). + +Note that if `mail-citation-hook' is set, `mh-ins-buf-prefix' is +not inserted. If the option `mh-yank-behavior' is set to one of +the supercite flavors, the hook `mail-citation-hook' is ignored +and `mh-ins-buf-prefix' is not inserted." + (interactive) + (if (and mh-sent-from-folder + (save-excursion (set-buffer mh-sent-from-folder) mh-show-buffer) + (save-excursion (set-buffer mh-sent-from-folder) + (get-buffer mh-show-buffer)) + mh-sent-from-msg) + (let ((to-point (point)) + (to-buffer (current-buffer))) + (set-buffer mh-sent-from-folder) + (if mh-delete-yanked-msg-window-flag + (delete-windows-on mh-show-buffer)) + (set-buffer mh-show-buffer) ; Find displayed message + (let* ((from-attr (mh-extract-from-attribution)) + (yank-region (mh-mark-active-p nil)) + (mh-ins-str + (cond ((and yank-region + (or (eq 'supercite mh-yank-behavior) + (eq 'autosupercite mh-yank-behavior) + (eq t mh-yank-behavior))) + ;; supercite needs the full header + (concat + (buffer-substring (point-min) (mh-mail-header-end)) + "\n" + (buffer-substring (region-beginning) (region-end)))) + (yank-region + (buffer-substring (region-beginning) (region-end))) + ((or (eq 'body mh-yank-behavior) + (eq 'attribution mh-yank-behavior) + (eq 'autoattrib mh-yank-behavior)) + (buffer-substring + (save-excursion + (goto-char (point-min)) + (mh-goto-header-end 1) + (point)) + (point-max))) + ((or (eq 'supercite mh-yank-behavior) + (eq 'autosupercite mh-yank-behavior) + (eq t mh-yank-behavior)) + (buffer-substring (point-min) (point-max))) + (t + (buffer-substring (point) (point-max)))))) + (set-buffer to-buffer) + (save-restriction + (narrow-to-region to-point to-point) + (insert (mh-filter-out-non-text mh-ins-str)) + (goto-char (point-max)) ;Needed for sc-cite-original + (push-mark) ;Needed for sc-cite-original + (goto-char (point-min)) ;Needed for sc-cite-original + (mh-insert-prefix-string mh-ins-buf-prefix) + (when (or (eq 'attribution mh-yank-behavior) + (eq 'autoattrib mh-yank-behavior)) + (insert from-attr) + (mh-identity-insert-attribution-verb nil) + (insert "\n\n")) + ;; If the user has selected a region, he has already "edited" the + ;; text, so leave the cursor at the end of the yanked text. In + ;; either case, leave a mark at the opposite end of the included + ;; text to make it easy to jump or delete to the other end of the + ;; text. + (push-mark) + (goto-char (point-max)) + (if (null yank-region) + (mh-exchange-point-and-mark-preserving-active-mark))))) + (error "There is no current message"))) + + + +;;; Support Routines + +(defun mh-auto-fill-for-letter () + "Perform auto-fill for message. +Header is treated specially by inserting a tab before continuation +lines." + (if (mh-in-header-p) + (let ((fill-prefix "\t")) + (do-auto-fill)) + (do-auto-fill))) + +(defun mh-filter-out-non-text (string) + "Return STRING but without adornments such as MIME buttons and smileys." + (with-temp-buffer + ;; Insert the string to filter + (insert string) + (goto-char (point-min)) + + ;; Remove the MIME buttons + (let ((can-move-forward t) + (in-button nil)) + (while can-move-forward + (cond ((and (not (get-text-property (point) 'mh-data)) + in-button) + (delete-region (1- (point)) (point)) + (setq in-button nil)) + ((get-text-property (point) 'mh-data) + (delete-region (point) + (save-excursion (forward-line) (point))) + (setq in-button t)) + (t (setq can-move-forward (= (forward-line) 0)))))) + + ;; Return the contents without properties... This gets rid of emphasis + ;; and smileys + (buffer-substring-no-properties (point-min) (point-max)))) + +(defun mh-current-fill-prefix () + "Return the `fill-prefix' on the current line as a string." + (save-excursion + (beginning-of-line) + ;; This assumes that the major-mode sets up adaptive-fill-regexp + ;; correctly such as mh-letter-mode or sendmail.el's mail-mode. But + ;; perhaps I should use the variable and simply inserts its value here, + ;; and set it locally in a let scope. --psg + (if (re-search-forward adaptive-fill-regexp nil t) + (match-string 0) + ""))) + +;;;###mh-autoload +(defun mh-letter-next-header-field () + "Cycle to the next header field. +If we are at the last header field go to the start of the message +body." + (let ((header-end (mh-mail-header-end))) + (cond ((>= (point) header-end) (goto-char (point-min))) + ((< (point) (progn + (beginning-of-line) + (re-search-forward mh-letter-header-field-regexp + (line-end-position) t) + (point))) + (beginning-of-line)) + (t (end-of-line))) + (cond ((re-search-forward mh-letter-header-field-regexp header-end t) + (if (mh-letter-skipped-header-field-p (match-string 1)) + (mh-letter-next-header-field) + (mh-letter-skip-leading-whitespace-in-header-field))) + (t (goto-char header-end) + (forward-line))))) + +;;;###mh-autoload +(defun mh-letter-skipped-header-field-p (field) + "Check if FIELD is to be skipped." + (let ((field (downcase field))) + (loop for x in mh-compose-skipped-header-fields + when (equal (downcase x) field) return t + finally return nil))) + +(defun mh-letter-skip-leading-whitespace-in-header-field () + "Skip leading whitespace in a header field. +If the header field doesn't have at least one space after the +colon then a space character is added." + (let ((need-space t)) + (while (memq (char-after) '(?\t ?\ )) + (forward-char) + (setq need-space nil)) + (when need-space (insert " ")))) + +;;;###mh-autoload +(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-letter-header-field-at-point () + "Return the header field name at point. +A symbol is returned whose name is the string obtained by +downcasing the field name." + (save-excursion + (end-of-line) + (and (re-search-backward mh-letter-header-field-regexp nil t) + (intern (downcase (match-string 1)))))) + +(defun mh-folder-expand-at-point () + "Do folder name completion in Fcc header field." + (let* ((end (point)) + (beg (mh-beginning-of-word)) + (folder (buffer-substring beg end)) + (leading-plus (and (> (length folder) 0) (equal (aref folder 0) ?+))) + (last-slash (mh-search-from-end ?/ folder)) + (prefix (and last-slash (substring folder 0 last-slash))) + (choices (mapcar #'(lambda (x) + (list (cond (prefix (format "%s/%s" prefix x)) + (leading-plus (format "+%s" x)) + (t x)))) + (mh-folder-completion-function folder nil t)))) + (mh-complete-word folder choices beg end))) + +;;;###mh-autoload +(defun mh-complete-word (word choices begin end) + "Complete WORD at from CHOICES. +Any match found replaces the text from BEGIN to END." + (let ((completion (try-completion word choices)) + (completions-buffer "*Completions*")) + (cond ((eq completion t) + (ignore-errors + (kill-buffer completions-buffer)) + (message "Completed: %s" word)) + ((null completion) + (ignore-errors + (kill-buffer completions-buffer)) + (message "No completion for %s" word)) + ((stringp completion) + (if (equal word completion) + (with-output-to-temp-buffer completions-buffer + (mh-display-completion-list (all-completions word choices) + choices)) + (ignore-errors + (kill-buffer completions-buffer)) + (delete-region begin end) + (insert completion)))))) + +(defun mh-file-is-vcard-p (file) + "Return t if FILE is a .vcf vcard." + (let ((case-fold-search t)) + (and (stringp file) + (file-exists-p file) + (or (and (not (mh-have-file-command)) + (not (null (string-match "\.vcf$" file)))) + (string-equal "text/x-vcard" (mh-file-mime-type file)))))) + +(defun mh-letter-toggle-header-field-display-button (event) + "Toggle header field display at location of EVENT. +This function does the same thing as +`mh-letter-toggle-header-field-display' except that it is +callable from a mouse button." + (interactive "e") + (mh-do-at-event-location event + (mh-letter-toggle-header-field-display nil))) + +(defun mh-letter-truncate-header-field (end) + "Replace text from current line till END with an ellipsis. +If the current line is too long truncate a part of it as well." + (let ((max-len (min (window-width) 62))) + (when (> (+ (current-column) 4) max-len) + (backward-char (- (+ (current-column) 5) max-len))) + (when (> end (point)) + (add-text-properties (point) end '(invisible vanish))))) + +(defun mh-extract-from-attribution () + "Extract phrase or comment from From header field." + (save-excursion + (if (not (mh-goto-header-field "From: ")) + nil + (skip-chars-forward " ") + (cond + ((looking-at "\"\\([^\"\n]+\\)\" \\(<.+>\\)") + (format "%s %s " (match-string 1)(match-string 2))) + ((looking-at "\\([^<\n]+<.+>\\)$") + (format "%s " (match-string 1))) + ((looking-at "\\([^ ]+@[^ ]+\\) +(\\(.+\\))$") + (format "%s <%s> " (match-string 2)(match-string 1))) + ((looking-at " *\\(.+\\)$") + (format "%s " (match-string 1))))))) + +(defun mh-insert-prefix-string (mh-ins-string) + "Insert prefix string before each line in buffer. +The inserted letter is cited using `sc-cite-original' if +`mh-yank-behavior' is one of 'supercite or 'autosupercite. +Otherwise, simply insert MH-INS-STRING before each line." + (goto-char (point-min)) + (cond ((or (eq mh-yank-behavior 'supercite) + (eq mh-yank-behavior 'autosupercite)) + (sc-cite-original)) + (mail-citation-hook + (run-hooks 'mail-citation-hook)) + (mh-yank-hooks ;old hook name + (run-hooks 'mh-yank-hooks)) + (t + (or (bolp) (forward-line 1)) + (while (< (point) (point-max)) + (insert mh-ins-string) + (forward-line 1)) + (goto-char (point-min))))) ;leave point like sc-cite-original + +(provide 'mh-letter) + +;; Local Variables: +;; indent-tabs-mode: nil +;; sentence-end-double-space: nil +;; End: + +;;; mh-letter.el ends here diff --git a/lisp/mh-e/mh-limit.el b/lisp/mh-e/mh-limit.el new file mode 100644 index 00000000000..bc48aa64a29 --- /dev/null +++ b/lisp/mh-e/mh-limit.el @@ -0,0 +1,329 @@ +;;; mh-limit.el --- MH-E display limits + +;; Copyright (C) 2001, 2002, 2003, 2006 Free Software Foundation, Inc. + +;; Author: Peter S. Galbraith <psg@debian.org> +;; 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., 51 Franklin Street, Fifth Floor, +;; Boston, MA 02110-1301, USA. + +;;; Commentary: + +;; "Poor man's threading" by psg. + +;;; Change Log: + +;;; Code: + +(require 'mh-e) +(mh-require-cl) +(require 'mh-scan) + +(autoload 'message-fetch-field "message") + + + +;;; MH-Folder Commands + +;; Alphabetical. + +;;;###mh-autoload +(defun mh-delete-subject () + "Delete messages with same subject\\<mh-folder-mode-map>. + +To delete messages faster, you can use this command to delete all +the messages with the same subject as the current message. This +command puts these messages in a sequence named \"subject\". You +can undo this action by using \\[mh-undo] with a prefix argument +and then specifying the \"subject\" sequence." + (interactive) + (let ((count (mh-subject-to-sequence nil))) + (cond + ((not count) ; No subject line, delete msg anyway + (mh-delete-msg (mh-get-msg-num t))) + ((= 0 count) ; No other msgs, delete msg anyway. + (message "No other messages with same Subject following this one") + (mh-delete-msg (mh-get-msg-num t))) + (t ; We have a subject sequence. + (message "Marked %d messages for deletion" count) + (mh-delete-msg 'subject))))) + +;;;###mh-autoload +(defun mh-delete-subject-or-thread () + "Delete messages with same subject or thread\\<mh-folder-mode-map>. + +To delete messages faster, you can use this command to delete all +the messages with the same subject as the current message. This +command puts these messages in a sequence named \"subject\". You +can undo this action by using \\[mh-undo] with a prefix argument +and then specifying the \"subject\" sequence. + +However, if the buffer is displaying a threaded view of the +folder then this command behaves like \\[mh-thread-delete]." + (interactive) + (if (memq 'unthread mh-view-ops) + (mh-thread-delete) + (mh-delete-subject))) + +;;;###mh-autoload +(defun mh-narrow-to-cc (&optional pick-expr) + "Limit to messages with the same \"Cc:\" field. +With a prefix argument, edit PICK-EXPR. + +Use \\<mh-folder-mode-map>\\[mh-widen] to undo this command." + (interactive + (list (mh-edit-pick-expr (mh-current-message-header-field 'cc)))) + (mh-narrow-to-header-field 'cc pick-expr)) + +;;;###mh-autoload +(defun mh-narrow-to-from (&optional pick-expr) + "Limit to messages with the same \"From:\" field. +With a prefix argument, edit PICK-EXPR. + +Use \\<mh-folder-mode-map>\\[mh-widen] to undo this command." + (interactive + (list (mh-edit-pick-expr (mh-current-message-header-field 'from)))) + (mh-narrow-to-header-field 'from pick-expr)) + +;;;###mh-autoload +(defun mh-narrow-to-range (range) + "Limit to RANGE. + +Check the documentation of `mh-interactive-range' to see how +RANGE is read in interactive use. + +Use \\<mh-folder-mode-map>\\[mh-widen] to undo this command." + (interactive (list (mh-interactive-range "Narrow to"))) + (when (assoc 'range mh-seq-list) (mh-delete-seq 'range)) + (mh-add-msgs-to-seq (mh-range-to-msg-list range) 'range) + (mh-narrow-to-seq 'range)) + +;;;###mh-autoload +(defun mh-narrow-to-subject (&optional pick-expr) + "Limit to messages with same subject. +With a prefix argument, edit PICK-EXPR. + +Use \\<mh-folder-mode-map>\\[mh-widen] to undo this command." + (interactive + (list (mh-edit-pick-expr (mh-current-message-header-field 'subject)))) + (mh-narrow-to-header-field 'subject pick-expr)) + +;;;###mh-autoload +(defun mh-narrow-to-to (&optional pick-expr) + "Limit to messages with the same \"To:\" field. +With a prefix argument, edit PICK-EXPR. + +Use \\<mh-folder-mode-map>\\[mh-widen] to undo this command." + (interactive + (list (mh-edit-pick-expr (mh-current-message-header-field 'to)))) + (mh-narrow-to-header-field 'to pick-expr)) + + + +;;; Support Routines + +(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." + (if (memq 'unthread mh-view-ops) + (mh-subject-to-sequence-threaded all) + (mh-subject-to-sequence-unthreaded all))) + +(defun mh-subject-to-sequence-threaded (all) + "Put all messages with the same subject in the 'subject sequence. + +This function works when the folder is threaded. In this +situation the subject could get truncated and so the normal +matching doesn't work. + +The parameter ALL is non-nil then all the messages in the buffer +are considered, otherwise only the messages after the current one +are taken into account." + (let* ((cur (mh-get-msg-num nil)) + (subject (mh-thread-find-msg-subject cur)) + region msgs) + (if (null subject) + (and (message "No subject line") nil) + (setq region (cons (if all (point-min) (point)) (point-max))) + (mh-iterate-on-range msg region + (when (eq (mh-thread-find-msg-subject msg) subject) + (push msg msgs))) + (setq msgs (sort msgs #'mh-lessp)) + (if (null msgs) + 0 + (when (assoc 'subject mh-seq-list) + (mh-delete-seq 'subject)) + (mh-add-msgs-to-seq msgs 'subject) + (length msgs))))) + +(defvar mh-limit-max-subject-size 41 + "Maximum size of the subject part. +It would be desirable to avoid hard-coding this.") + +(defun mh-subject-to-sequence-unthreaded (all) + "Put all following messages with same subject in sequence 'subject. + +This function only works with an unthreaded folder. 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." + (if (not (eq major-mode 'mh-folder-mode)) + (error "Not in a folder buffer")) + (save-excursion + (beginning-of-line) + (if (or (not (looking-at mh-scan-subject-regexp)) + (not (match-string 3)) + (string-equal "" (match-string 3))) + (progn (message "No subject line") + nil) + (let ((subject (match-string-no-properties 3)) + (list)) + (if (> (length subject) mh-limit-max-subject-size) + (setq subject (substring subject 0 mh-limit-max-subject-size))) + (save-excursion + (if all + (goto-char (point-min))) + (while (re-search-forward mh-scan-subject-regexp nil t) + (let ((this-subject (match-string-no-properties 3))) + (if (> (length this-subject) mh-limit-max-subject-size) + (setq this-subject (substring this-subject + 0 mh-limit-max-subject-size))) + (if (string-equal this-subject subject) + (setq list (cons (mh-get-msg-num t) list)))))) + (cond + (list + ;; 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))) + (if (assoc 'subject mh-seq-list) (mh-delete-seq 'subject)) + ;; sort the result into a sequence + (let ((sorted-list (sort (copy-sequence list) 'mh-lessp))) + (while sorted-list + (mh-add-msgs-to-seq (car sorted-list) 'subject nil) + (setq sorted-list (cdr sorted-list))) + (safe-length list))) + (t + 0)))))) + +(defun mh-edit-pick-expr (default) + "With prefix arg edit a pick expression. +If no prefix arg is given, then return DEFAULT." + (let ((default-string (loop for x in default concat (format " %s" x)))) + (if (or current-prefix-arg (equal default-string "")) + (mh-pick-args-list (read-string "Pick expression: " + default-string)) + default))) + +(defun mh-pick-args-list (s) + "Form list by grouping elements in string S suitable for pick arguments. +For example, the string \"-subject a b c -from Joe User +<user@domain.com>\" is converted to (\"-subject\" \"a b c\" +\"-from\" \"Joe User <user@domain.com>\"" + (let ((full-list (split-string s)) + current-arg collection arg-list) + (while full-list + (setq current-arg (car full-list)) + (if (null (string-match "^-" current-arg)) + (setq collection + (if (null collection) + current-arg + (format "%s %s" collection current-arg))) + (when collection + (setq arg-list (append arg-list (list collection))) + (setq collection nil)) + (setq arg-list (append arg-list (list current-arg)))) + (setq full-list (cdr full-list))) + (when collection + (setq arg-list (append arg-list (list collection)))) + arg-list)) + +(defun mh-current-message-header-field (header-field) + "Return a pick regexp to match HEADER-FIELD of the message at point." + (let ((num (mh-get-msg-num nil))) + (when num + (let ((folder mh-current-folder)) + (with-temp-buffer + (insert-file-contents-literally (mh-msg-filename num folder)) + (goto-char (point-min)) + (when (search-forward "\n\n" nil t) + (narrow-to-region (point-min) (point))) + (let* ((field (or (message-fetch-field (format "%s" header-field)) + "")) + (field-option (format "-%s" header-field)) + (patterns (loop for x in (split-string field "[ ]*,[ ]*") + unless (equal x "") + collect (if (string-match "<\\(.*@.*\\)>" x) + (match-string 1 x) + x)))) + (when patterns + (loop with accum = `(,field-option ,(car patterns)) + for e in (cdr patterns) + do (setq accum `(,field-option ,e "-or" ,@accum)) + finally return accum)))))))) + +(defun mh-narrow-to-header-field (header-field pick-expr) + "Limit to messages whose HEADER-FIELD match PICK-EXPR. +The MH command pick is used to do the match." + (let ((folder mh-current-folder) + (original (mh-coalesce-msg-list + (mh-range-to-msg-list (cons (point-min) (point-max))))) + (msg-list ())) + (with-temp-buffer + (apply #'mh-exec-cmd-output "pick" nil folder + (append original (list "-list") pick-expr)) + (goto-char (point-min)) + (while (not (eobp)) + (let ((num (ignore-errors + (string-to-number + (buffer-substring (point) (line-end-position)))))) + (when num (push num msg-list)) + (forward-line)))) + (if (null msg-list) + (message "No matches") + (when (assoc 'header mh-seq-list) (mh-delete-seq 'header)) + (mh-add-msgs-to-seq msg-list 'header) + (mh-narrow-to-seq 'header)))) + +(provide 'mh-limit) + +;; Local Variables: +;; indent-tabs-mode: nil +;; sentence-end-double-space: nil +;; End: + +;;; mh-limit.el ends here diff --git a/lisp/mh-e/mh-mime.el b/lisp/mh-e/mh-mime.el index a91d7b1212a..de4c01a9604 100644 --- a/lisp/mh-e/mh-mime.el +++ b/lisp/mh-e/mh-mime.el @@ -1,4 +1,4 @@ -;;; mh-mime.el --- MH-E support for composing MIME messages +;;; mh-mime.el --- MH-E MIME support ;; Copyright (C) 1993, 1995, ;; 2001, 2002, 2003, 2004, 2005, 2006 Free Software Foundation, Inc. @@ -27,733 +27,159 @@ ;;; Commentary: -;; Internal support for MH-E package. -;; Support for generating MH-style directives for mhn or mhbuild as well as -;; MML (MIME Meta Language) tags. MH-style directives are supported by MH 6.8 -;; or later. +;; Message composition of MIME message is done with either MH-style +;; directives for mhn or mhbuild (MH 6.8 or later) or MML (MIME Meta +;; Language) tags. + +;; TODO: +;; Paragraph code should not fill # lines if MIME enabled. +;; Implement mh-auto-mh-to-mime (if non-nil, \\[mh-send-letter] +;; invokes mh-mh-to-mime automatically before sending.) +;; Actually, instead of mh-auto-mh-to-mime, +;; should read automhnproc from profile. +;; MIME option to mh-forward command to move to content-description +;; insertion point. ;;; Change Log: ;;; Code: -;;(message "> mh-mime") -(eval-when-compile (require 'mh-acros)) -(mh-require-cl) +(require 'mh-e) +(require 'mh-gnus) ;needed because mh-gnus.el not compiled +(require 'font-lock) (require 'gnus-util) -(require 'mh-buffers) -(require 'mh-comp) -(require 'mh-gnus) -;;(message "< mh-mime") +(require 'mailcap) +(require 'mm-decode) +(require 'mm-view) +(require 'mml) (autoload 'article-emphasize "gnus-art") -(autoload 'gnus-article-goto-header "gnus-art") (autoload 'gnus-eval-format "gnus-spec") -(autoload 'gnus-get-buffer-create "gnus") +(autoload 'mail-content-type-get "mail-parse") +(autoload 'mail-decode-encoded-word-string "mail-parse") +(autoload 'mail-header-parse-content-type "mail-parse") +(autoload 'mail-header-strip "mail-parse") (autoload 'message-options-set-recipient "message") +(autoload 'mm-decode-body "mm-bodies") (autoload 'mm-uu-dissect "mm-uu") (autoload 'mml-unsecure-message "mml-sec") (autoload 'rfc2047-decode-region "rfc2047") (autoload 'widget-convert-button "wid-edit") -;;;###mh-autoload -(defun mh-compose-insertion (&optional inline) - "Add tag to include a file such as an image or sound. - -You are prompted for the filename containing the object, the -media type if it cannot be determined automatically, and a -content description. If you're using MH-style directives, you -will also be prompted for additional attributes. - -The option `mh-compose-insertion' controls what type of tags are -inserted. Optional argument INLINE means make it an inline -attachment." - (interactive "P") - (if (equal mh-compose-insertion 'mml) - (if inline - (mh-mml-attach-file "inline") - (mh-mml-attach-file)) - (call-interactively 'mh-mh-attach-file))) - -;;;###mh-autoload -(defun mh-compose-forward (&optional description folder range) - "Add tag to forward a message. - -You are prompted for a content DESCRIPTION, the name of the -FOLDER in which the messages to forward are located, and a RANGE -of messages, which defaults to the current message in that -folder. Check the documentation of `mh-interactive-range' to see -how RANGE is read in interactive use. - -The option `mh-compose-insertion' controls what type of tags are inserted." - (interactive - (let* ((description - (mml-minibuffer-read-description)) - (folder - (mh-prompt-for-folder "Message from" - mh-sent-from-folder nil)) - (default - (if (and (equal folder mh-sent-from-folder) - (numberp mh-sent-from-msg)) - mh-sent-from-msg - (nth 0 (mh-translate-range folder "cur")))) - (range - (mh-read-range "Forward" folder - (or (and default - (number-to-string default)) - t) - t t))) - (list description folder range))) - (let ((messages (mapconcat 'identity (mh-list-to-string range) " "))) - (dolist (message (mh-translate-range folder messages)) - (if (equal mh-compose-insertion 'mml) - (mh-mml-forward-message description folder (format "%s" message)) - (mh-mh-forward-message description folder (format "%s" message)))))) - -;; To do: -;; paragraph code should not fill # lines if MIME enabled. -;; implement mh-auto-mh-to-mime (if non-nil, \\[mh-send-letter] -;; invokes mh-mh-to-mime automatically before sending.) -;; actually, instead of mh-auto-mh-to-mime, -;; should read automhnproc from profile -;; MIME option to mh-forward -;; command to move to content-description insertion point - -(defvar mh-mh-to-mime-args nil - "Extra arguments for \\[mh-mh-to-mime] to pass to the \"mhbuild\" command. -The arguments are passed to \"mhbuild\" if \\[mh-mh-to-mime] is -given a prefix argument. Normally default arguments to -\"mhbuild\" are specified in the MH profile.") - -(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.") - -(defvar mh-have-file-command 'undefined - "Cached value of function `mh-have-file-command'. -Do not reference this variable directly as it might not have been -initialized. Always use the command `mh-have-file-command'.") - -;;;###mh-autoload -(defun mh-have-file-command () - "Return t if 'file' command is on the system. -'file -i' is used to get MIME type of composition insertion." - (when (eq mh-have-file-command 'undefined) - (setq mh-have-file-command - (and (fboundp 'executable-find) - (executable-find "file") ; file command exists - ; and accepts -i and -b args. - (zerop (call-process "file" nil nil nil "-i" "-b" - (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") - ("text/plain" "\.vcf" "text/x-vcard")) - "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)) - -;;;###mh-autoload -(defun mh-file-mime-type (filename) - "Return MIME type of FILENAME from file command. -Returns nil if file command not on system." - (cond - ((not (mh-have-file-command)) - nil) ;no file command, exit now - ((not (and (file-exists-p filename) - (file-readable-p filename))) - nil) ;no file or not readable, ditto - (t - (save-excursion - (let ((tmp-buffer (get-buffer-create mh-temp-buffer))) - (set-buffer tmp-buffer) - (unwind-protect - (progn - (call-process "file" nil '(t nil) nil "-b" "-i" - (expand-file-name filename)) - (goto-char (point-min)) - (if (not (re-search-forward mh-media-type-regexp nil t)) - nil - (mh-file-mime-type-substitute (match-string 0) filename))) - (kill-buffer tmp-buffer))))))) - -(defun mh-minibuffer-read-type (filename &optional default) - "Return the content type associated with the given FILENAME. -If the \"file\" command exists and recognizes the given file, -then its value is returned\; otherwise, the user is prompted for -a type (see `mailcap-mime-types' and for Emacs 20, -`mh-mime-content-types'). -Optional argument DEFAULT is returned if a type isn't entered." - (mailcap-parse-mimetypes) - (let* ((default (or default - (mm-default-file-encoding filename) - "application/octet-stream")) - (probed-type (mh-file-mime-type filename)) - (type (or (and (not (equal probed-type "application/octet-stream")) - probed-type) - (completing-read - (format "Content type (default %s): " default) - (mapcar 'list (mailcap-mime-types)))))) - (if (not (equal type "")) - type - default))) - -;; RFC 2045 - Multipurpose Internet Mail Extensions (MIME) Part One: -;; Format of Internet Message Bodies. -;; RFC 2046 - Multipurpose Internet Mail Extensions (MIME) Part Two: -;; Media Types. -;; RFC 2049 - Multipurpose Internet Mail Extensions (MIME) Part Five: -;; Conformance Criteria and Examples. -;; RFC 2017 - Definition of the URL MIME External-Body Access-Type -;; RFC 1738 - Uniform Resource Locators (URL) -(defvar mh-access-types - '(("anon-ftp") ; RFC2046 Anonymous File Transfer Protocol - ("file") ; RFC1738 Host-specific file names - ("ftp") ; RFC2046 File Transfer Protocol - ("gopher") ; RFC1738 The Gopher Protocol - ("http") ; RFC1738 Hypertext Transfer Protocol - ("local-file") ; RFC2046 Local file access - ("mail-server") ; RFC2046 mail-server Electronic mail address - ("mailto") ; RFC1738 Electronic mail address - ("news") ; RFC1738 Usenet news - ("nntp") ; RFC1738 Usenet news using NNTP access - ("propspero") ; RFC1738 Prospero Directory Service - ("telnet") ; RFC1738 Telnet - ("tftp") ; RFC2046 Trivial File Transfer Protocol - ("url") ; RFC2017 URL scheme MIME access-type Protocol - ("wais")) ; RFC1738 Wide Area Information Servers - "Valid MIME access-type values.") - -;;;###mh-autoload -(defun mh-mh-attach-file (filename type description attributes) - "Add a tag to insert a MIME message part from a file. -You are prompted for the FILENAME containing the object, the -media TYPE if it cannot be determined automatically, and a -content DESCRIPTION. In addition, you are also prompted for -additional ATTRIBUTES. - -See also \\[mh-mh-to-mime]." - (interactive (let ((filename (mml-minibuffer-read-file "Attach file: "))) - (list - filename - (mh-minibuffer-read-type filename) - (mml-minibuffer-read-description) - (read-string "Attributes: " - (concat "name=\"" - (file-name-nondirectory filename) - "\""))))) - (mh-mh-compose-type filename type description attributes)) - -(defun mh-mh-compose-type (filename type - &optional description attributes comment) - "Insert an MH-style 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." - (beginning-of-line) - (insert "#" type) - (and attributes - (insert "; " attributes)) - (and comment - (insert " (" comment ")")) - (insert " [") - (and description - (insert description)) - (insert "] " (expand-file-name filename)) - (insert "\n")) - -;;;###mh-autoload -(defun mh-mh-compose-anon-ftp (host filename type description) - "Add tag to include anonymous ftp reference to a file. - -You can have your message initiate an \"ftp\" transfer when the -recipient reads the message. You are prompted for the remote HOST -and FILENAME, the media TYPE, and the content DESCRIPTION. - -See also \\[mh-mh-to-mime]." - (interactive (list - (read-string "Remote host: ") - (read-string "Remote filename: ") - (mh-minibuffer-read-type "DUMMY-FILENAME") - (mml-minibuffer-read-description))) - (mh-mh-compose-external-type "anon-ftp" host filename - type description)) - -;;;###mh-autoload -(defun mh-mh-compose-external-compressed-tar (host filename description) - "Add tag to include anonymous ftp reference to a compressed tar file. - -In addition to retrieving the file via anonymous \"ftp\" as per -the command \\[mh-mh-compose-anon-ftp], the file will also be -uncompressed and untarred. You are prompted for the remote HOST -and FILENAME and the content DESCRIPTION. - -See also \\[mh-mh-to-mime]." - (interactive (list - (read-string "Remote host: ") - (read-string "Remote filename: ") - (mml-minibuffer-read-description))) - (mh-mh-compose-external-type "anon-ftp" host filename - "application/octet-stream" - description - "type=tar; conversions=x-compress" - "mode=image")) - -;;;###mh-autoload -(defun mh-mh-compose-external-type (access-type host filename type - &optional description - attributes parameters - comment) - "Add tag to refer to a remote file. - -This command is a general utility for referencing external files. -In fact, all of the other commands that insert directives to -access external files call this command. You are prompted for the -ACCESS-TYPE, remote HOST and FILENAME, and content TYPE. If you -provide a prefix argument, you are also prompted for a content -DESCRIPTION, ATTRIBUTES, PARAMETERS, and a COMMENT. - -See also \\[mh-mh-to-mime]." - (interactive (list - (completing-read "Access type: " mh-access-types) - (read-string "Remote host: ") - (read-string "Remote filename: ") - (mh-minibuffer-read-type "DUMMY-FILENAME") - (if current-prefix-arg (mml-minibuffer-read-description)) - (if current-prefix-arg (read-string "Attributes: ")) - (if current-prefix-arg (read-string "Parameters: ")) - (if current-prefix-arg (read-string "Comment: ")))) - (beginning-of-line) - (insert "#@" type) - (and attributes - (insert "; " attributes)) - (and comment - (insert " (" comment ") ")) - (insert " [") - (and description - (insert description)) - (insert "] ") - (insert "access-type=" access-type "; ") - (insert "site=" host) - (insert "; name=" (file-name-nondirectory filename)) - (let ((directory (file-name-directory filename))) - (and directory - (insert "; directory=\"" directory "\""))) - (and parameters - (insert "; " parameters)) - (insert "\n")) - -;;;###mh-autoload -(defun mh-mh-forward-message (&optional description folder messages) - "Add tag to forward a message. -You are prompted for a content DESCRIPTION, the name of the -FOLDER in which the messages to forward are located, and the -MESSAGES' numbers. - -See also \\[mh-mh-to-mime]." - (interactive (list - (mml-minibuffer-read-description) - (mh-prompt-for-folder "Message from" mh-sent-from-folder nil) - (read-string (concat "Messages" - (if (numberp mh-sent-from-msg) - (format " (default %d): " - mh-sent-from-msg) - ": "))))) - (beginning-of-line) - (insert "#forw [") - (and description - (not (string= description "")) - (insert description)) - (insert "]") - (and folder - (not (string= folder "")) - (insert " " folder)) - (if (and messages - (not (string= messages ""))) - (let ((start (point))) - (insert " " messages) - (subst-char-in-region start (point) ?, ? )) - (if (numberp mh-sent-from-msg) - (insert " " (int-to-string mh-sent-from-msg)))) - (insert "\n")) - -;;;###mh-autoload -(defun mh-mh-to-mime (&optional extra-args) - "Compose MIME message from MH-style directives. - -Typically, you send a message with attachments just like any other -message. However, you may take a sneak preview of the MIME encoding if -you wish by running this command. - -If you wish to pass additional arguments to \"mhbuild\" (\"mhn\") -to affect how it builds your message, use the option -`mh-mh-to-mime-args'. For example, you can build a consistency -check into the message by setting `mh-mh-to-mime-args' to -\"-check\". The recipient of your message can then run \"mhbuild --check\" on the message--\"mhbuild\" (\"mhn\") will complain if -the message has been corrupted on the way. This command only -consults this option when given a prefix argument EXTRA-ARGS. - -The hook `mh-mh-to-mime-hook' is called after the message has been -formatted. - -The effects of this command can be undone by running -\\[mh-mh-to-mime-undo]." - (interactive "*P") - (mh-mh-quote-unescaped-sharp) - (save-buffer) - (message "Running %s..." (if (mh-variant-p 'nmh) "mhbuild" "mhn")) - (cond - ((mh-variant-p 'nmh) - (mh-exec-cmd-error nil - "mhbuild" - (if extra-args mh-mh-to-mime-args) - buffer-file-name)) - (t - (mh-exec-cmd-error (format "mhdraft=%s" buffer-file-name) - "mhn" - (if extra-args mh-mh-to-mime-args) - buffer-file-name))) - (revert-buffer t t) - (message "Running %s...done" (if (mh-variant-p 'nmh) "mhbuild" "mhn")) - (run-hooks 'mh-mh-to-mime-hook)) - -(defun mh-mh-quote-unescaped-sharp () - "Quote \"#\" characters that haven't been quoted for \"mhbuild\". -If the \"#\" character is present in the first column, but it isn't -part of a MH-style directive then \"mhbuild\" gives an error. -This function will quote all such characters." - (save-excursion - (goto-char (point-min)) - (while (re-search-forward "^#" nil t) - (beginning-of-line) - (unless (mh-mh-directive-present-p (point) (line-end-position)) - (insert "#")) - (goto-char (line-end-position))))) - -;;;###mh-autoload -(defun mh-mh-to-mime-undo (noconfirm) - "Undo effects of \\[mh-mh-to-mime]. - -It does this by reverting to a backup file. You are prompted to -confirm this action, but you can avoid the confirmation by adding -a prefix argument NOCONFIRM." - (interactive "*P") - (if (null buffer-file-name) - (error "Buffer does not seem to be associated with any file")) - (let ((backup-strings '("," "#")) - backup-file) - (while (and backup-strings - (not (file-exists-p - (setq backup-file - (concat (file-name-directory buffer-file-name) - (car backup-strings) - (file-name-nondirectory buffer-file-name) - ".orig"))))) - (setq backup-strings (cdr backup-strings))) - (or backup-strings - (error "Backup file for %s no longer exists" buffer-file-name)) - (or noconfirm - (yes-or-no-p (format "Revert buffer from file %s? " - backup-file)) - (error "Revert not confirmed")) - (let ((buffer-read-only nil)) - (erase-buffer) - (insert-file-contents backup-file)) - (after-find-file nil))) - -;;;###mh-autoload -(defun mh-mh-directive-present-p (&optional begin end) - "Check if the text between BEGIN and END might be a MH-style directive. -The optional argument BEGIN defaults to the beginning of the -buffer, while END defaults to the the end of the buffer." - (unless begin (setq begin (point-min))) - (unless end (setq end (point-max))) - (save-excursion - (block 'search-for-mh-directive - (goto-char begin) - (while (re-search-forward "^#" end t) - (let ((s (buffer-substring-no-properties (point) (line-end-position)))) - (cond ((equal s "")) - ((string-match "^forw[ \t\n]+" s) - (return-from 'search-for-mh-directive t)) - (t (let ((first-token (car (split-string s "[ \t;@]")))) - (when (and first-token - (string-match mh-media-type-regexp - first-token)) - (return-from 'search-for-mh-directive t))))))) - nil))) - -;;; MIME composition functions - -;;;###mh-autoload -(defun mh-mml-to-mime () - "Compose MIME message from MML tags. - -Typically, you send a message with attachments just like any -other message. However, you may take a sneak preview of the MIME -encoding if you wish by running this command. - -This action can be undone by running \\[undo]." - (interactive) - (require 'message) - (when mh-pgp-support-flag ;; This is only needed for PGP - (message-options-set-recipient)) - (let ((saved-text (buffer-string)) - (buffer (current-buffer)) - (modified-flag (buffer-modified-p))) - (condition-case err (mml-to-mime) - (error - (with-current-buffer buffer - (delete-region (point-min) (point-max)) - (insert saved-text) - (set-buffer-modified-p modified-flag)) - (error (error-message-string err)))))) - -;;;###mh-autoload -(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 (and (equal message "") (numberp mh-sent-from-msg)) - mh-sent-from-msg - (string-to-number 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))) - (t (error "The message number, %s, is not a integer" msg))))) - -(defvar mh-mml-cryptographic-method-history ()) - -;;;###mh-autoload -(defun mh-mml-query-cryptographic-method () - "Read the cryptographic method to use." - (if current-prefix-arg - (let ((def (or (car mh-mml-cryptographic-method-history) - mh-mml-method-default))) - (completing-read (format "Method (default %s): " def) - '(("pgp") ("pgpmime") ("smime")) - nil t nil 'mh-mml-cryptographic-method-history def)) - mh-mml-method-default)) +;;; Variables +;; This has to be a macro, since we do: (setf (mh-buffer-data) ...) ;;;###mh-autoload -(defun mh-mml-attach-file (&optional disposition) - "Add a tag to insert a MIME message part from a file. - -You are prompted for the filename containing the object, the -media type if it cannot be determined automatically, a content -description and the DISPOSITION of the attachment. - -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 (mh-minibuffer-read-type file)) - (description (mml-minibuffer-read-description)) - (dispos (or disposition - (mml-minibuffer-read-disposition type)))) - (mml-insert-empty-tag 'part 'type type 'filename file - 'disposition dispos 'description description))) - -;; Shush compiler. -(eval-when-compile (defvar mh-identity-pgg-default-user-id)) - -(defun mh-secure-message (method mode &optional identity) - "Add tag to encrypt or sign message. +(defmacro mh-buffer-data () + "Convenience macro to get the MIME data structures of the current buffer." + `(gethash (current-buffer) mh-globals-hash)) + +;; Structure to keep track of MIME handles on a per buffer basis. +(mh-defstruct (mh-buffer-data (:conc-name mh-mime-) + (:constructor mh-make-buffer-data)) + (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 + +(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.") -METHOD should be one of: \"pgpmime\", \"pgp\", \"smime\". -MODE should be one of: \"sign\", \"encrypt\", \"signencrypt\", \"none\". -IDENTITY is optionally the default-user-id to use." - (if (not mh-pgp-support-flag) - (error "Your version of Gnus does not support PGP/GPG") - ;; Check the arguments - (let ((valid-methods (list "pgpmime" "pgp" "smime")) - (valid-modes (list "sign" "encrypt" "signencrypt" "none"))) - (if (not (member method valid-methods)) - (error "Method %s is invalid" method)) - (if (not (member mode valid-modes)) - (error "Mode %s is invalid" mode)) - (mml-unsecure-message) - (if (not (string= mode "none")) - (save-excursion - (goto-char (point-min)) - (mh-goto-header-end 1) - (if mh-identity-pgg-default-user-id - (mml-insert-tag 'secure 'method method 'mode mode - 'sender mh-identity-pgg-default-user-id) - (mml-insert-tag 'secure 'method method 'mode mode))))))) - -;;;###mh-autoload -(defun mh-mml-unsecure-message () - "Remove any secure message tags." - (interactive) - (if (not mh-pgp-support-flag) - (error "Your version of Gnus does not support PGP/GPG") - (mml-unsecure-message))) - -;;;###mh-autoload -(defun mh-mml-secure-message-sign (method) - "Add tag to sign the message. - -A proper multipart message is created for you when you send the -message. Use the command \\[mh-mml-unsecure-message] to remove -this tag. Use a prefix argument METHOD to be prompted for one of -the possible security methods (see `mh-mml-method-default')." - (interactive (list (mh-mml-query-cryptographic-method))) - (mh-secure-message method "sign" mh-identity-pgg-default-user-id)) - -;;;###mh-autoload -(defun mh-mml-secure-message-encrypt (method) - "Add tag to encrypt the message. - -A proper multipart message is created for you when you send the -message. Use the command \\[mh-mml-unsecure-message] to remove -this tag. Use a prefix argument METHOD to be prompted for one of -the possible security methods (see `mh-mml-method-default')." - (interactive (list (mh-mml-query-cryptographic-method))) - (mh-secure-message method "encrypt" mh-identity-pgg-default-user-id)) - -;;;###mh-autoload -(defun mh-mml-secure-message-signencrypt (method) - "Add tag to encrypt and sign the message. - -A proper multipart message is created for you when you send the -message. Use the command \\[mh-mml-unsecure-message] to remove -this tag. Use a prefix argument METHOD to be prompted for one of -the possible security methods (see `mh-mml-method-default')." - (interactive (list (mh-mml-query-cryptographic-method))) - (mh-secure-message method "signencrypt" mh-identity-pgg-default-user-id)) - -;;;###mh-autoload -(defun mh-mml-tag-present-p () - "Check if the current buffer has text which may be a MML tag." - (save-excursion - (goto-char (point-min)) - (re-search-forward - (concat - "\\(<#\\(mml\\|part\\)\\(.\\|\n\\)*>[ \n\t]*<#/\\(mml\\|part\\)>\\|" - "^<#secure.+>$\\)") - nil t))) - - - -;;; MIME cleanup - -;;;###mh-autoload -(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? - (mh-funcall-if-exists remove-images (point-min) (point-max)) - (when mime-data - (mm-destroy-parts (mh-mime-handles mime-data)) - (remhash (current-buffer) mh-globals-hash)))) - -;;;###mh-autoload -(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 -(eval-when-compile (require 'font-lock)) - -;;;###mh-autoload -(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)) - (re-search-forward "\n\n" nil t) - (save-restriction - (narrow-to-region (point-min) (point)) - (when (and (message-fetch-field "content-type") - (not (message-fetch-field "mime-version"))) - (goto-char (point-min)) - (insert "MIME-Version: 1.0\n"))))) - -(defun mh-small-show-buffer-p () - "Check if show buffer is small. -This is used to decide if smileys and graphical emphasis will be -displayed." - (let ((max nil)) - (when (and (boundp 'font-lock-maximum-size) font-lock-maximum-size) - (cond ((numberp font-lock-maximum-size) - (setq max font-lock-maximum-size)) - ((listp font-lock-maximum-size) - (setq max (cdr (or (assoc 'mh-show-mode font-lock-maximum-size) - (assoc t font-lock-maximum-size))))))) - (or (not (numberp max)) (>= (/ max 8) (buffer-size))))) - -;;;###mh-autoload -(defun mh-display-smileys () - "Display smileys." - (when (and mh-graphical-smileys-flag (mh-small-show-buffer-p)) - (mh-funcall-if-exists smiley-region (point-min) (point-max)))) - -;;;###mh-autoload -(defun mh-display-emphasis () - "Display graphical emphasis." - (when (and mh-graphical-emphasis-flag (mh-small-show-buffer-p)) - (flet ((article-goto-body ())) ; shadow this function to do nothing - (save-excursion - (goto-char (point-min)) - (article-emphasize))))) +(defvar mh-mime-save-parts-directory nil + "Default to use for `mh-mime-save-parts-default-directory'. +Set from last use.") ;; Copied from gnus-art.el (should be checked for other cool things that can ;; be added to the buttons) @@ -796,9 +222,148 @@ displayed." (define-key map '(button2) '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.") + + +;;; MH-Folder Commands + +;; Alphabetical. + +;;;###mh-autoload +(defun mh-display-with-external-viewer (part-index) + "View attachment externally. + +If Emacs does not know how to view an attachment, you could save +it into a file and then run some program to open it. It is +easier, however, to launch the program directly from MH-E with +this command. While you'll most likely use this to view +spreadsheets and documents, it is also useful to use your browser +to view HTML attachments with higher fidelity than what Emacs can +provide. + +This command displays the attachment associated with the button +under the cursor. If the cursor is not located over a button, +then the cursor first moves to the next button, wrapping to the +beginning of the message if necessary. You can provide a numeric +prefix argument PART-INDEX to view the attachment labeled with +that number. + +This command tries to provide a reasonable default for the viewer +by calling the Emacs function `mailcap-mime-info'. This function +usually reads the file \"/etc/mailcap\"." + (interactive "P") + (when (consp part-index) (setq part-index (car part-index))) + (mh-folder-mime-action + part-index + #'(lambda () + (let* ((part (get-text-property (point) 'mh-data)) + (type (mm-handle-media-type part)) + (methods (mapcar (lambda (x) (list (cdr (assoc 'viewer x)))) + (mailcap-mime-info type 'all))) + (def (caar methods)) + (prompt (format "Viewer%s: " (if def + (format " (default %s)" def) + ""))) + (method (completing-read prompt methods nil nil nil nil def)) + (folder mh-show-folder-buffer) + (buffer-read-only nil)) + (when (string-match "^[^% \t]+$" method) + (setq method (concat method " %s"))) + (flet ((mm-handle-set-external-undisplayer (handle function) + (mh-handle-set-external-undisplayer folder handle function))) + (unwind-protect (mm-display-external part method) + (set-buffer-modified-p nil))))) + nil)) + +;;;###mh-autoload +(defun mh-folder-inline-mime-part (part-index) + "Show attachment verbatim. + +You can view the raw contents of an attachment with this command. +This command displays (or hides) the contents of the attachment +associated with the button under the cursor verbatim. If the +cursor is not located over a button, then the cursor first moves +to the next button, wrapping to the beginning of the message if +necessary. + +You can also provide a numeric prefix argument PART-INDEX to view +the attachment labeled with that number." + (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-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))) + +;;;###mh-autoload +(defun mh-folder-save-mime-part (part-index) + "Save (output) attachment. + +This command saves the attachment associated with the button under the +cursor. If the cursor is not located over a button, then the cursor +first moves to the next button, wrapping to the beginning of the +message if necessary. + +You can also provide a numeric prefix argument PART-INDEX to save the +attachment labeled with that number. + +This command prompts you for a filename and suggests a specific name +if it is available." + (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-mime-save-part () + "Save MIME part at point." + (interactive) + (let ((data (get-text-property (point) 'mh-data))) + (when data + (let ((mm-default-directory + (file-name-as-directory (or mh-mime-save-parts-directory + default-directory)))) + (mh-mm-save-part data) + (setq mh-mime-save-parts-directory mm-default-directory))))) + +;;;###mh-autoload +(defun mh-folder-toggle-mime-part (part-index) + "View attachment. + +This command displays (or hides) the attachment associated with +the button under the cursor. If the cursor is not located over a +button, then the cursor first moves to the next button, wrapping +to the beginning of the message if necessary. This command has +the advantage over related commands of working from the MH-Folder +buffer. + +You can also provide a numeric prefix argument PART-INDEX to view +the attachment labeled with that number. If Emacs does not know +how to display the attachment, then Emacs offers to save the +attachment in a file." + (interactive "P") + (when (consp part-index) (setq part-index (car part-index))) + (mh-folder-mime-action part-index #'mh-press-button t)) ;;;###mh-autoload (defun mh-mime-save-parts (prompt) @@ -856,32 +421,6 @@ do the work." (switch-to-buffer-other-window mh-log-buffer) (sit-for 3)))))))) -;; Avoid errors if gnus-sum isn't loaded yet... -(defvar gnus-newsgroup-charset nil) -(defvar gnus-newsgroup-name nil) - -(defun mh-decode-message-body () - "Decode message based on charset. -If message has been encoded for transfer take that into account." - (let (ct charset cte) - (goto-char (point-min)) - (re-search-forward "\n\n" nil t) - (save-restriction - (narrow-to-region (point-min) (point)) - (setq ct (ignore-errors (mail-header-parse-content-type - (message-fetch-field "Content-Type" t))) - charset (mail-content-type-get ct 'charset) - cte (message-fetch-field "Content-Transfer-Encoding"))) - (when (stringp cte) (setq cte (mail-header-strip cte))) - (when (or (not ct) (equal (car ct) "text/plain")) - (save-restriction - (narrow-to-region (min (1+ (mh-mail-header-end)) (point-max)) - (point-max)) - (mm-decode-body charset - (and cte (intern (downcase - (gnus-strip-whitespace cte)))) - (car ct)))))) - ;;;###mh-autoload (defun mh-toggle-mh-decode-mime-flag () "Toggle the value of `mh-decode-mime-flag'." @@ -893,6 +432,72 @@ If message has been encoded for transfer take that into account." "Displaying raw message"))) ;;;###mh-autoload +(defun mh-toggle-mime-buttons () + "Toggle option `mh-display-buttons-for-inline-parts-flag'." + (interactive) + (setq mh-display-buttons-for-inline-parts-flag + (not mh-display-buttons-for-inline-parts-flag)) + (mh-show nil t)) + + + +;;; MIME Display Routines + +(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)) + (clean-message-header mh-clean-message-header-flag) + (invisible-headers mh-invisible-header-fields-compiled) + (visible-headers 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 (mm-dissect-buffer nil))) + (if handles + (mm-uu-dissect-text-parts handles) + (setq handles (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)) + (mh-show-xface) + (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-decode-message-header) + (mh-show-addr) + ;; The other highlighting types don't need anything special + (when (eq mh-highlight-citation-style '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))))))))) + +;;;###mh-autoload (defun mh-decode-message-header () "Decode RFC2047 encoded message header fields." (when mh-decode-mime-flag @@ -922,34 +527,60 @@ parsed and then displayed." (if pre-dissected-handles (setq handles pre-dissected-handles) (if (setq handles (mm-dissect-buffer nil)) - (when (fboundp 'mm-uu-dissect-text-parts) - (mm-uu-dissect-text-parts handles)) + (mm-uu-dissect-text-parts handles) (setq handles (mm-uu-dissect))) (setf (mh-mime-handles (mh-buffer-data)) (mm-merge-handles handles (mh-mime-handles (mh-buffer-data)))) - (unless handles (mh-decode-message-body))) + (unless handles + (mh-decode-message-body))) (cond ((and handles - (or (not (stringp (car handles))) (cdr handles))) - ;; Goto start of message body + (or (not (stringp (car handles))) + (cdr handles))) + ;; Go to start of message body (goto-char (point-min)) - (or (search-forward "\n\n" nil t) (goto-char (point-max))) + (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)) - (t (mh-signature-highlight)))) + (t + (mh-signature-highlight)))) (error (message "Could not display body: %s" (error-message-string err)) (delete-region (point-min) (point-max)) (insert raw-message-data)))))) +(defun mh-decode-message-body () + "Decode message based on charset. +If message has been encoded for transfer take that into account." + (let (ct charset cte) + (goto-char (point-min)) + (re-search-forward "\n\n" nil t) + (save-restriction + (narrow-to-region (point-min) (point)) + (setq ct (ignore-errors (mail-header-parse-content-type + (message-fetch-field "Content-Type" t))) + charset (mail-content-type-get ct 'charset) + cte (message-fetch-field "Content-Transfer-Encoding"))) + (when (stringp cte) (setq cte (mail-header-strip cte))) + (when (or (not ct) (equal (car ct) "text/plain")) + (save-restriction + (narrow-to-region (min (1+ (mh-mail-header-end)) (point-max)) + (point-max)) + (mm-decode-body charset + (and cte (intern (downcase + (gnus-strip-whitespace cte)))) + (car ct)))))) + (defun mh-mime-display-part (handle) "Decides the viewer to call based on the type of HANDLE." - (cond ((null handle) nil) + (cond ((null handle) + nil) ((not (stringp (car handle))) (mh-mime-display-single handle)) ((equal (car handle) "multipart/alternative") @@ -958,14 +589,20 @@ parsed and then displayed." (or (equal (car handle) "multipart/signed") (equal (car handle) "multipart/encrypted"))) (mh-mime-display-security handle)) - (t (mh-mime-display-mixed (cdr handle))))) + (t + (mh-mime-display-mixed (cdr handle))))) + +(defun mh-mime-display-mixed (handles) + "Display the list of MIME parts, HANDLES recursively." + (mapcar #'mh-mime-display-part handles)) (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)) (others (loop for x in handles unless (eq x preferred) collect x))) - (cond ((and preferred (stringp (car preferred))) + (cond ((and preferred + (stringp (car preferred))) (mh-mime-display-part preferred) (mh-mime-maybe-display-alternatives others)) (preferred @@ -974,7 +611,8 @@ If no part is preferred then all the parts are displayed." (mh-mime-display-single preferred) (mh-mime-maybe-display-alternatives others) (goto-char (point-max)))) - (t (mh-mime-display-mixed handles))))) + (t + (mh-mime-display-mixed handles))))) (defun mh-mime-maybe-display-alternatives (alternatives) "Show buttons for ALTERNATIVES. @@ -988,9 +626,128 @@ buttons for alternative parts that are usually suppressed." (mh-insert-mime-button x (mh-mime-part-index x) nil)) (insert "\n----------------------------------------------------\n"))) -(defun mh-mime-display-mixed (handles) - "Display the list of MIME parts, HANDLES recursively." - (mapcar #'mh-mime-display-part handles)) +(defun mh-mime-display-security (handle) + "Display PGP encrypted/signed message, HANDLE." + (save-restriction + (narrow-to-region (point) (point)) + (insert "\n") + (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 (point-min-marker) (point-max-marker))))) + +(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 ; show if inline OR + (mh-inline-vcard-p handle); inline vcard OR + (and (not attachmentp) ; if not an attachment + (or small-image-flag ; and small image + ; and 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-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)) + (mh-signature-highlight 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))))) + +;; 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 + (mh-funcall-if-exists + 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-style 'gnus) + (mh-gnus-article-highlight-citation)) + (mh-display-smileys) + (mh-display-emphasis) + (mh-signature-highlight handle)) + (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-mime-part-index (handle) "Generate the button number for MIME part, HANDLE. @@ -1009,7 +766,7 @@ This is only useful if a Content-Disposition header is not present." (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, + (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))) @@ -1040,43 +797,6 @@ This is only useful if a Content-Disposition header is not present." (goto-char (point-min)) (not (mh-signature-separator-p))))))) -(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 ; show if inline OR - (mh-inline-vcard-p handle); inline vcard OR - (and (not attachmentp) ; if not an attachment - (or small-image-flag ; and small image - ; and 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-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)) - (mh-signature-highlight 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-signature-highlight (&optional handle) "Highlight message signature in HANDLE. The optional argument, HANDLE is a MIME handle if the function is @@ -1099,9 +819,12 @@ being used to highlight the signature in a MIME part." (set-extent-property (make-extent (point) (point-max)) 'face 'mh-show-signature)))))) -(mh-do-in-xemacs - (defvar dots) - (defvar type)) + + +;;; Button Display + +;; Shush compiler. +(eval-when-compile (mh-do-in-xemacs (defvar dots) (defvar type) (defvar ov))) (defun mh-insert-mime-button (handle index displayed) "Insert MIME button for HANDLE. @@ -1145,76 +868,161 @@ by commands like \"K v\" which operate on individual MIME parts." (dolist (ov (mh-funcall-if-exists overlays-in begin end)) (mh-funcall-if-exists overlay-put ov 'evaporate t)))) -;; 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) +;; Shush compiler. +(eval-when-compile + (when (< emacs-major-version 22) + (defvar mm-verify-function-alist) + (defvar mm-decrypt-function-alist)) + (mh-do-in-xemacs + (defvar pressed-details))) - (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 - (mh-funcall-if-exists - 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-style 'gnus) - (mh-gnus-article-highlight-citation)) - (mh-display-smileys) - (mh-display-emphasis) - (mh-signature-highlight handle)) - (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-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 face) + (setq details (if details (concat "\n" details) "")) + (setq pressed-details (if mh-mime-security-button-pressed details "")) + (setq face (mh-mime-security-button-face info)) + (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 + :button-face face + :help-echo "Mouse-2 click or press RET (in show buffer) to see security details.") + (dolist (ov (mh-funcall-if-exists overlays-in begin end)) + (mh-funcall-if-exists overlay-put ov 'evaporate t)) + (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-mime-security-button-face (info) + "Return the button face to use for encrypted/signed mail based on INFO." + (cond ((string-match "OK" info) ;Decrypted mail + 'mh-show-pgg-good) + ((string-match "Failed" info) ;Decryption failed or signature invalid + 'mh-show-pgg-bad) + ((string-match "Undecided" info);Unprocessed mail + 'mh-show-pgg-unknown) + ((string-match "Untrusted" info);Key not trusted + 'mh-show-pgg-unknown) + (t + 'mh-show-pgg-good))) + + + +;;; Button Handlers + +(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))))))) ;;;###mh-autoload +(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-widget-press-button (widget el) + "Callback for widget, WIDGET. +Parameter EL is unused." + (goto-char (widget-get widget :from)) + (mh-press-button)) + (defun mh-press-button () "View contents of button. @@ -1234,7 +1042,6 @@ attachment, the attachment is hidden." (unwind-protect (and function (funcall function data)) (set-buffer-modified-p nil))))) -;;;###mh-autoload (defun mh-push-button (event) "Click MIME button for EVENT. @@ -1251,110 +1058,40 @@ to click the MIME button." (mh-handle-set-external-undisplayer folder handle func))) (and function (funcall function data)))))) -;;;###mh-autoload -(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 - (file-name-as-directory (or mh-mime-save-parts-directory - default-directory)))) - (mh-mm-save-part data) - (setq mh-mime-save-parts-directory mm-default-directory))))) - -;;;###mh-autoload -(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))) - -;;;###mh-autoload -(defun mh-display-with-external-viewer (part-index) - "View attachment externally. - -If Emacs does not know how to view an attachment, you could save -it into a file and then run some program to open it. It is -easier, however, to launch the program directly from MH-E with -this command. While you'll most likely use this to view -spreadsheets and documents, it is also useful to use your browser -to view HTML attachments with higher fidelity than what Emacs can -provide. - -This command displays the attachment associated with the button -under the cursor. If the cursor is not located over a button, -then the cursor first moves to the next button, wrapping to the -beginning of the message if necessary. You can provide a numeric -prefix argument PART-INDEX to view the attachment labeled with -that number. - -This command tries to provide a reasonable default for the viewer -by calling the Emacs function `mailcap-mime-info'. This function -usually reads the file \"/etc/mailcap\"." - (interactive "P") - (when (consp part-index) (setq part-index (car part-index))) - (mh-folder-mime-action - part-index - #'(lambda () - (let* ((part (get-text-property (point) 'mh-data)) - (type (mm-handle-media-type part)) - (methods (mapcar (lambda (x) (list (cdr (assoc 'viewer x)))) - (mailcap-mime-info type 'all))) - (def (caar methods)) - (prompt (format "Viewer%s: " (if def - (format " (default %s)" def) - ""))) - (method (completing-read prompt methods nil nil nil nil def)) - (folder mh-show-folder-buffer) - (buffer-read-only nil)) - (when (string-match "^[^% \t]+$" method) - (setq method (concat method " %s"))) - (flet ((mm-handle-set-external-undisplayer (handle function) - (mh-handle-set-external-undisplayer folder handle function))) - (unwind-protect (mm-display-external part method) - (set-buffer-modified-p nil))))) - nil)) +(defun mh-handle-set-external-undisplayer (folder handle function) + "Replacement for `mm-handle-set-external-undisplayer'. -(defun mh-widget-press-button (widget el) - "Callback for widget, WIDGET. -Parameter EL is unused." - (goto-char (widget-get widget :from)) - (mh-press-button)) +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))) -(defun mh-mime-display-security (handle) - "Display PGP encrypted/signed message, HANDLE." - (save-restriction - (narrow-to-region (point) (point)) - (insert "\n") - (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 (point-min-marker) (point-max-marker))))) +(defun mh-mime-security-press-button (handle) + "Callback from security button for part HANDLE." + (if (mm-handle-multipart-ctl-parameter handle 'gnus-info) + (mh-mime-security-show-details handle) + (let ((region (mm-handle-multipart-ctl-parameter handle 'mh-region)) + point) + (setq point (point)) + (goto-char (car region)) + (delete-region (car region) (cdr region)) + (with-current-buffer (mm-handle-multipart-ctl-parameter handle 'buffer) + (let* ((mm-verify-option 'known) + (mm-decrypt-option 'known) + (new (mm-possibly-verify-or-decrypt (cdr handle) handle))) + (unless (eq new (cdr handle)) + (mm-destroy-parts (cdr handle)) + (setcdr handle new)))) + (mh-mime-display-security handle) + (goto-char point)))) ;; 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 @@ -1383,142 +1120,680 @@ Parameter EL is unused." (point-max))) (forward-line -1))))) -(defun mh-mime-security-button-face (info) - "Return the button face to use for encrypted/signed mail based on INFO." - (cond ((string-match "OK" info) ;Decrypted mail - 'mh-show-pgg-good) - ((string-match "Failed" info) ;Decryption failed or signature invalid - 'mh-show-pgg-bad) - ((string-match "Undecided" info);Unprocessed mail - 'mh-show-pgg-unknown) - ((string-match "Untrusted" info);Key not trusted - 'mh-show-pgg-unknown) - (t - 'mh-show-pgg-good))) + -(defun mh-mime-security-press-button (handle) - "Callback from security button for part HANDLE." - (if (mm-handle-multipart-ctl-parameter handle 'gnus-info) - (mh-mime-security-show-details handle) - (let ((region (mm-handle-multipart-ctl-parameter handle 'mh-region)) - point) - (setq point (point)) - (goto-char (car region)) - (delete-region (car region) (cdr region)) - (with-current-buffer (mm-handle-multipart-ctl-parameter handle 'buffer) - (let* ((mm-verify-option 'known) - (mm-decrypt-option 'known) - (new (mm-possibly-verify-or-decrypt (cdr handle) handle))) - (unless (eq new (cdr handle)) - (mm-destroy-parts (cdr handle)) - (setcdr handle new)))) - (mh-mime-display-security handle) - (goto-char point)))) +;;; Miscellaneous Article Washing + +;;;###mh-autoload +(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)) + (re-search-forward "\n\n" nil t) + (save-restriction + (narrow-to-region (point-min) (point)) + (when (and (message-fetch-field "content-type") + (not (message-fetch-field "mime-version"))) + (goto-char (point-min)) + (insert "MIME-Version: 1.0\n"))))) + +;;;###mh-autoload +(defun mh-display-smileys () + "Display smileys." + (when (and mh-graphical-smileys-flag (mh-small-show-buffer-p)) + (mh-funcall-if-exists smiley-region (point-min) (point-max)))) + +;;;###mh-autoload +(defun mh-display-emphasis () + "Display graphical emphasis." + (when (and mh-graphical-emphasis-flag (mh-small-show-buffer-p)) + (flet ((article-goto-body ())) ; shadow this function to do nothing + (save-excursion + (goto-char (point-min)) + (article-emphasize))))) + +(defun mh-small-show-buffer-p () + "Check if show buffer is small. +This is used to decide if smileys and graphical emphasis should be +displayed." + (let ((max nil)) + (when (and (boundp 'font-lock-maximum-size) font-lock-maximum-size) + (cond ((numberp font-lock-maximum-size) + (setq max font-lock-maximum-size)) + ((listp font-lock-maximum-size) + (setq max (cdr (or (assoc 'mh-show-mode font-lock-maximum-size) + (assoc t font-lock-maximum-size))))))) + (or (not (numberp max)) (>= (/ max 8) (buffer-size))))) + + + +;;; MH-Letter Commands + +;; MH-E commands are alphabetical; specific support routines follow command. + +;;;###mh-autoload +(defun mh-compose-forward (&optional description folder range) + "Add tag to forward a message. + +You are prompted for a content DESCRIPTION, the name of the +FOLDER in which the messages to forward are located, and a RANGE +of messages, which defaults to the current message in that +folder. Check the documentation of `mh-interactive-range' to see +how RANGE is read in interactive use. + +The option `mh-compose-insertion' controls what type of tags are inserted." + (interactive + (let* ((description + (mml-minibuffer-read-description)) + (folder + (mh-prompt-for-folder "Message from" + mh-sent-from-folder nil)) + (default + (if (and (equal folder mh-sent-from-folder) + (numberp mh-sent-from-msg)) + mh-sent-from-msg + (nth 0 (mh-translate-range folder "cur")))) + (range + (mh-read-range "Forward" folder + (or (and default + (number-to-string default)) + t) + t t))) + (list description folder range))) + (let ((messages (mapconcat 'identity (mh-list-to-string range) " "))) + (dolist (message (mh-translate-range folder messages)) + (if (equal mh-compose-insertion 'mml) + (mh-mml-forward-message description folder (format "%s" message)) + (mh-mh-forward-message description folder (format "%s" message)))))) + +;;;###mh-autoload +(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 (and (equal message "") (numberp mh-sent-from-msg)) + mh-sent-from-msg + (string-to-number 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))) + (t (error "The message number, %s, is not a integer" msg))))) + +(defun mh-mh-forward-message (&optional description folder messages) + "Add tag to forward a message. +You are prompted for a content DESCRIPTION, the name of the +FOLDER in which the messages to forward are located, and the +MESSAGES' numbers. + +See also \\[mh-mh-to-mime]." + (interactive (list + (mml-minibuffer-read-description) + (mh-prompt-for-folder "Message from" mh-sent-from-folder nil) + (read-string (concat "Messages" + (if (numberp mh-sent-from-msg) + (format " (default %d): " + mh-sent-from-msg) + ": "))))) + (beginning-of-line) + (insert "#forw [") + (and description + (not (string= description "")) + (insert description)) + (insert "]") + (and folder + (not (string= folder "")) + (insert " " folder)) + (if (and messages + (not (string= messages ""))) + (let ((start (point))) + (insert " " messages) + (subst-char-in-region start (point) ?, ? )) + (if (numberp mh-sent-from-msg) + (insert " " (int-to-string mh-sent-from-msg)))) + (insert "\n")) + +;;;###mh-autoload +(defun mh-compose-insertion (&optional inline) + "Add tag to include a file such as an image or sound. + +You are prompted for the filename containing the object, the +media type if it cannot be determined automatically, and a +content description. If you're using MH-style directives, you +will also be prompted for additional attributes. + +The option `mh-compose-insertion' controls what type of tags are +inserted. Optional argument INLINE means make it an inline +attachment." + (interactive "P") + (if (equal mh-compose-insertion 'mml) + (if inline + (mh-mml-attach-file "inline") + (mh-mml-attach-file)) + (call-interactively 'mh-mh-attach-file))) + +(defun mh-mml-attach-file (&optional disposition) + "Add a tag to insert a MIME message part from a file. + +You are prompted for the filename containing the object, the +media type if it cannot be determined automatically, a content +description and the DISPOSITION of the attachment. + +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 (mh-minibuffer-read-type file)) + (description (mml-minibuffer-read-description)) + (dispos (or disposition + (mml-minibuffer-read-disposition type)))) + (mml-insert-empty-tag 'part 'type type 'filename file + 'disposition dispos 'description description))) + +(defun mh-mh-attach-file (filename type description attributes) + "Add a tag to insert a MIME message part from a file. +You are prompted for the FILENAME containing the object, the +media TYPE if it cannot be determined automatically, and a +content DESCRIPTION. In addition, you are also prompted for +additional ATTRIBUTES. + +See also \\[mh-mh-to-mime]." + (interactive (let ((filename (mml-minibuffer-read-file "Attach file: "))) + (list + filename + (mh-minibuffer-read-type filename) + (mml-minibuffer-read-description) + (read-string "Attributes: " + (concat "name=\"" + (file-name-nondirectory filename) + "\""))))) + (mh-mh-compose-type filename type description attributes)) + +(defun mh-mh-compose-type (filename type + &optional description attributes comment) + "Insert an MH-style 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." + (beginning-of-line) + (insert "#" type) + (and attributes + (insert "; " attributes)) + (and comment + (insert " (" comment ")")) + (insert " [") + (and description + (insert description)) + (insert "] " (expand-file-name filename)) + (insert "\n")) + +;;;###mh-autoload +(defun mh-mh-compose-anon-ftp (host filename type description) + "Add tag to include anonymous ftp reference to a file. + +You can have your message initiate an \"ftp\" transfer when the +recipient reads the message. You are prompted for the remote HOST +and FILENAME, the media TYPE, and the content DESCRIPTION. + +See also \\[mh-mh-to-mime]." + (interactive (list + (read-string "Remote host: ") + (read-string "Remote filename: ") + (mh-minibuffer-read-type "DUMMY-FILENAME") + (mml-minibuffer-read-description))) + (mh-mh-compose-external-type "anon-ftp" host filename + type description)) + +;;;###mh-autoload +(defun mh-mh-compose-external-compressed-tar (host filename description) + "Add tag to include anonymous ftp reference to a compressed tar file. + +In addition to retrieving the file via anonymous \"ftp\" as per +the command \\[mh-mh-compose-anon-ftp], the file will also be +uncompressed and untarred. You are prompted for the remote HOST +and FILENAME and the content DESCRIPTION. + +See also \\[mh-mh-to-mime]." + (interactive (list + (read-string "Remote host: ") + (read-string "Remote filename: ") + (mml-minibuffer-read-description))) + (mh-mh-compose-external-type "anon-ftp" host filename + "application/octet-stream" + description + "type=tar; conversions=x-compress" + "mode=image")) + +;; RFC 2045 - Multipurpose Internet Mail Extensions (MIME) Part One: +;; Format of Internet Message Bodies. +;; RFC 2046 - Multipurpose Internet Mail Extensions (MIME) Part Two: +;; Media Types. +;; RFC 2049 - Multipurpose Internet Mail Extensions (MIME) Part Five: +;; Conformance Criteria and Examples. +;; RFC 2017 - Definition of the URL MIME External-Body Access-Type +;; RFC 1738 - Uniform Resource Locators (URL) +(defvar mh-access-types + '(("anon-ftp") ; RFC2046 Anonymous File Transfer Protocol + ("file") ; RFC1738 Host-specific file names + ("ftp") ; RFC2046 File Transfer Protocol + ("gopher") ; RFC1738 The Gopher Protocol + ("http") ; RFC1738 Hypertext Transfer Protocol + ("local-file") ; RFC2046 Local file access + ("mail-server") ; RFC2046 mail-server Electronic mail address + ("mailto") ; RFC1738 Electronic mail address + ("news") ; RFC1738 Usenet news + ("nntp") ; RFC1738 Usenet news using NNTP access + ("propspero") ; RFC1738 Prospero Directory Service + ("telnet") ; RFC1738 Telnet + ("tftp") ; RFC2046 Trivial File Transfer Protocol + ("url") ; RFC2017 URL scheme MIME access-type Protocol + ("wais")) ; RFC1738 Wide Area Information Servers + "Valid MIME access-type values.") + +;;;###mh-autoload +(defun mh-mh-compose-external-type (access-type host filename type + &optional description + attributes parameters + comment) + "Add tag to refer to a remote file. + +This command is a general utility for referencing external files. +In fact, all of the other commands that insert directives to +access external files call this command. You are prompted for the +ACCESS-TYPE, remote HOST and FILENAME, and content TYPE. If you +provide a prefix argument, you are also prompted for a content +DESCRIPTION, ATTRIBUTES, PARAMETERS, and a COMMENT. + +See also \\[mh-mh-to-mime]." + (interactive (list + (completing-read "Access type: " mh-access-types) + (read-string "Remote host: ") + (read-string "Remote filename: ") + (mh-minibuffer-read-type "DUMMY-FILENAME") + (if current-prefix-arg (mml-minibuffer-read-description)) + (if current-prefix-arg (read-string "Attributes: ")) + (if current-prefix-arg (read-string "Parameters: ")) + (if current-prefix-arg (read-string "Comment: ")))) + (beginning-of-line) + (insert "#@" type) + (and attributes + (insert "; " attributes)) + (and comment + (insert " (" comment ") ")) + (insert " [") + (and description + (insert description)) + (insert "] ") + (insert "access-type=" access-type "; ") + (insert "site=" host) + (insert "; name=" (file-name-nondirectory filename)) + (let ((directory (file-name-directory filename))) + (and directory + (insert "; directory=\"" directory "\""))) + (and parameters + (insert "; " parameters)) + (insert "\n")) + +(defvar mh-mh-to-mime-args nil + "Extra arguments for \\[mh-mh-to-mime] to pass to the \"mhbuild\" command. +The arguments are passed to \"mhbuild\" if \\[mh-mh-to-mime] is +given a prefix argument. Normally default arguments to +\"mhbuild\" are specified in the MH profile.") + +;;;###mh-autoload +(defun mh-mh-to-mime (&optional extra-args) + "Compose MIME message from MH-style directives. + +Typically, you send a message with attachments just like any other +message. However, you may take a sneak preview of the MIME encoding if +you wish by running this command. + +If you wish to pass additional arguments to \"mhbuild\" (\"mhn\") +to affect how it builds your message, use the option +`mh-mh-to-mime-args'. For example, you can build a consistency +check into the message by setting `mh-mh-to-mime-args' to +\"-check\". The recipient of your message can then run \"mhbuild +-check\" on the message--\"mhbuild\" (\"mhn\") will complain if +the message has been corrupted on the way. This command only +consults this option when given a prefix argument EXTRA-ARGS. + +The hook `mh-mh-to-mime-hook' is called after the message has been +formatted. + +The effects of this command can be undone by running +\\[mh-mh-to-mime-undo]." + (interactive "*P") + (mh-mh-quote-unescaped-sharp) + (save-buffer) + (message "Running %s..." (if (mh-variant-p 'nmh) "mhbuild" "mhn")) + (cond + ((mh-variant-p 'nmh) + (mh-exec-cmd-error nil + "mhbuild" + (if extra-args mh-mh-to-mime-args) + buffer-file-name)) + (t + (mh-exec-cmd-error (format "mhdraft=%s" buffer-file-name) + "mhn" + (if extra-args mh-mh-to-mime-args) + buffer-file-name))) + (revert-buffer t t) + (message "Running %s...done" (if (mh-variant-p 'nmh) "mhbuild" "mhn")) + (run-hooks 'mh-mh-to-mime-hook)) + +(defun mh-mh-quote-unescaped-sharp () + "Quote \"#\" characters that haven't been quoted for \"mhbuild\". +If the \"#\" character is present in the first column, but it isn't +part of a MH-style directive then \"mhbuild\" gives an error. +This function will quote all such characters." + (save-excursion + (goto-char (point-min)) + (while (re-search-forward "^#" nil t) + (beginning-of-line) + (unless (mh-mh-directive-present-p (point) (line-end-position)) + (insert "#")) + (goto-char (line-end-position))))) + +;;;###mh-autoload +(defun mh-mh-to-mime-undo (noconfirm) + "Undo effects of \\[mh-mh-to-mime]. + +It does this by reverting to a backup file. You are prompted to +confirm this action, but you can avoid the confirmation by adding +a prefix argument NOCONFIRM." + (interactive "*P") + (if (null buffer-file-name) + (error "Buffer does not seem to be associated with any file")) + (let ((backup-strings '("," "#")) + backup-file) + (while (and backup-strings + (not (file-exists-p + (setq backup-file + (concat (file-name-directory buffer-file-name) + (car backup-strings) + (file-name-nondirectory buffer-file-name) + ".orig"))))) + (setq backup-strings (cdr backup-strings))) + (or backup-strings + (error "Backup file for %s no longer exists" buffer-file-name)) + (or noconfirm + (yes-or-no-p (format "Revert buffer from file %s? " + backup-file)) + (error "Revert not confirmed")) + (let ((buffer-read-only nil)) + (erase-buffer) + (insert-file-contents backup-file)) + (after-find-file nil))) ;; Shush compiler. -(eval-when-compile - (defvar mm-verify-function-alist nil) - (defvar mm-decrypt-function-alist nil)) +(eval-when-compile (defvar mh-identity-pgg-default-user-id)) -(defvar pressed-details) +;;;###mh-autoload +(defun mh-mml-secure-message-encrypt (method) + "Add tag to encrypt the message. -(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 face) - (setq details (if details (concat "\n" details) "")) - (setq pressed-details (if mh-mime-security-button-pressed details "")) - (setq face (mh-mime-security-button-face info)) - (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 - :button-face face - :help-echo "Mouse-2 click or press RET (in show buffer) to see security details.") - (dolist (ov (mh-funcall-if-exists overlays-in begin end)) - (mh-funcall-if-exists overlay-put ov 'evaporate t)) - (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))))) +A proper multipart message is created for you when you send the +message. Use the command \\[mh-mml-unsecure-message] to remove +this tag. Use a prefix argument METHOD to be prompted for one of +the possible security methods (see `mh-mml-method-default')." + (interactive (list (mh-mml-query-cryptographic-method))) + (mh-secure-message method "encrypt" mh-identity-pgg-default-user-id)) -(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)) - (clean-message-header mh-clean-message-header-flag) - (invisible-headers mh-invisible-header-fields-compiled) - (visible-headers nil)) +;;;###mh-autoload +(defun mh-mml-secure-message-sign (method) + "Add tag to sign the message. + +A proper multipart message is created for you when you send the +message. Use the command \\[mh-mml-unsecure-message] to remove +this tag. Use a prefix argument METHOD to be prompted for one of +the possible security methods (see `mh-mml-method-default')." + (interactive (list (mh-mml-query-cryptographic-method))) + (mh-secure-message method "sign" mh-identity-pgg-default-user-id)) + +;;;###mh-autoload +(defun mh-mml-secure-message-signencrypt (method) + "Add tag to encrypt and sign the message. + +A proper multipart message is created for you when you send the +message. Use the command \\[mh-mml-unsecure-message] to remove +this tag. Use a prefix argument METHOD to be prompted for one of +the possible security methods (see `mh-mml-method-default')." + (interactive (list (mh-mml-query-cryptographic-method))) + (mh-secure-message method "signencrypt" mh-identity-pgg-default-user-id)) + +(defvar mh-mml-cryptographic-method-history ()) + +(defun mh-mml-query-cryptographic-method () + "Read the cryptographic method to use." + (if current-prefix-arg + (let ((def (or (car mh-mml-cryptographic-method-history) + mh-mml-method-default))) + (completing-read (format "Method (default %s): " def) + '(("pgp") ("pgpmime") ("smime")) + nil t nil 'mh-mml-cryptographic-method-history def)) + mh-mml-method-default)) + +(defun mh-secure-message (method mode &optional identity) + "Add tag to encrypt or sign message. + +METHOD should be one of: \"pgpmime\", \"pgp\", \"smime\". +MODE should be one of: \"sign\", \"encrypt\", \"signencrypt\", \"none\". +IDENTITY is optionally the default-user-id to use." + (if (not mh-pgp-support-flag) + (error "Your version of Gnus does not support PGP/GPG") + ;; Check the arguments + (let ((valid-methods (list "pgpmime" "pgp" "smime")) + (valid-modes (list "sign" "encrypt" "signencrypt" "none"))) + (if (not (member method valid-methods)) + (error "Method %s is invalid" method)) + (if (not (member mode valid-modes)) + (error "Mode %s is invalid" mode)) + (mml-unsecure-message) + (if (not (string= mode "none")) + (save-excursion + (goto-char (point-min)) + (mh-goto-header-end 1) + (if mh-identity-pgg-default-user-id + (mml-insert-tag 'secure 'method method 'mode mode + 'sender mh-identity-pgg-default-user-id) + (mml-insert-tag 'secure 'method method 'mode mode))))))) + +;;;###mh-autoload +(defun mh-mml-to-mime () + "Compose MIME message from MML tags. + +Typically, you send a message with attachments just like any +other message. However, you may take a sneak preview of the MIME +encoding if you wish by running this command. + +This action can be undone by running \\[undo]." + (interactive) + (require 'message) + (when mh-pgp-support-flag ;; This is only needed for PGP + (message-options-set-recipient)) + (let ((saved-text (buffer-string)) + (buffer (current-buffer)) + (modified-flag (buffer-modified-p))) + (condition-case err (mml-to-mime) + (error + (with-current-buffer buffer + (delete-region (point-min) (point-max)) + (insert saved-text) + (set-buffer-modified-p modified-flag)) + (error (error-message-string err)))))) + +;;;###mh-autoload +(defun mh-mml-unsecure-message () + "Remove any secure message tags." + (interactive) + (if (not mh-pgp-support-flag) + (error "Your version of Gnus does not support PGP/GPG") + (mml-unsecure-message))) + + + +;;; Support Routines for MH-Letter Commands + +;;;###mh-autoload +(defun mh-mml-tag-present-p () + "Check if the current buffer has text which may be a MML tag." + (save-excursion + (goto-char (point-min)) + (re-search-forward + (concat + "\\(<#\\(mml\\|part\\)\\(.\\|\n\\)*>[ \n\t]*<#/\\(mml\\|part\\)>\\|" + "^<#secure.+>$\\)") + nil t))) + +(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.") + +;;;###mh-autoload +(defun mh-mh-directive-present-p (&optional begin end) + "Check if the text between BEGIN and END might be a MH-style directive. +The optional argument BEGIN defaults to the beginning of the +buffer, while END defaults to the the end of the buffer." + (unless begin (setq begin (point-min))) + (unless end (setq end (point-max))) + (save-excursion + (block 'search-for-mh-directive + (goto-char begin) + (while (re-search-forward "^#" end t) + (let ((s (buffer-substring-no-properties (point) (line-end-position)))) + (cond ((equal s "")) + ((string-match "^forw[ \t\n]+" s) + (return-from 'search-for-mh-directive t)) + (t (let ((first-token (car (split-string s "[ \t;@]")))) + (when (and first-token + (string-match mh-media-type-regexp + first-token)) + (return-from 'search-for-mh-directive t))))))) + nil))) + +(defun mh-minibuffer-read-type (filename &optional default) + "Return the content type associated with the given FILENAME. +If the \"file\" command exists and recognizes the given file, +then its value is returned\; otherwise, the user is prompted for +a type (see `mailcap-mime-types' and for Emacs 20, +`mh-mime-content-types'). +Optional argument DEFAULT is returned if a type isn't entered." + (mailcap-parse-mimetypes) + (let* ((default (or default + (mm-default-file-encoding filename) + "application/octet-stream")) + (probed-type (mh-file-mime-type filename)) + (type (or (and (not (equal probed-type "application/octet-stream")) + probed-type) + (completing-read + (format "Content type (default %s): " default) + (mapcar 'list (mailcap-mime-types)))))) + (if (not (equal type "")) + type + default))) + +;;;###mh-autoload +(defun mh-file-mime-type (filename) + "Return MIME type of FILENAME from file command. +Returns nil if file command not on system." + (cond + ((not (mh-have-file-command)) + nil) ;no file command, exit now + ((not (and (file-exists-p filename) + (file-readable-p filename))) + nil) ;no file or not readable, ditto + (t (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 (mm-dissect-buffer nil))) - (if handles - (when (fboundp 'mm-uu-dissect-text-parts) - (mm-uu-dissect-text-parts handles)) - (setq handles (mm-uu-dissect))) - (setf (mh-mime-handles (mh-buffer-data)) - (mm-merge-handles - handles (mh-mime-handles (mh-buffer-data)))) - handles)))) + (let ((tmp-buffer (get-buffer-create mh-temp-buffer))) + (set-buffer tmp-buffer) + (unwind-protect + (progn + (call-process "file" nil '(t nil) nil "-b" "-i" + (expand-file-name filename)) + (goto-char (point-min)) + (if (not (re-search-forward mh-media-type-regexp nil t)) + nil + (mh-file-mime-type-substitute (match-string 0) filename))) + (kill-buffer tmp-buffer))))))) - (goto-char (point-min)) - (mh-show-xface) - (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-decode-message-header) - (mh-show-addr) - ;; The other highlighting types don't need anything special - (when (eq mh-highlight-citation-style '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))))))))) +(defvar mh-file-mime-type-substitutions + '(("application/msword" "\.xls" "application/ms-excel") + ("application/msword" "\.ppt" "application/ms-powerpoint") + ("text/plain" "\.vcf" "text/x-vcard")) + "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)) + +(defvar mh-have-file-command 'undefined + "Cached value of function `mh-have-file-command'. +Do not reference this variable directly as it might not have been +initialized. Always use the command `mh-have-file-command'.") + +;;;###mh-autoload +(defun mh-have-file-command () + "Return t if 'file' command is on the system. +'file -i' is used to get MIME type of composition insertion." + (when (eq mh-have-file-command 'undefined) + (setq mh-have-file-command + (and (fboundp 'executable-find) + (executable-find "file") ; file command exists + ; and accepts -i and -b args. + (zerop (call-process "file" nil nil nil "-i" "-b" + (expand-file-name "inc" mh-progs)))))) + mh-have-file-command) + + + +;;; MIME Cleanup + +;;;###mh-autoload +(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? + (mh-funcall-if-exists remove-images (point-min) (point-max)) + (when mime-data + (mm-destroy-parts (mh-mime-handles mime-data)) + (remhash (current-buffer) mh-globals-hash)))) + +;;;###mh-autoload +(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))) (provide 'mh-mime) diff --git a/lisp/mh-e/mh-print.el b/lisp/mh-e/mh-print.el index 79534789caf..9358f485bfd 100644 --- a/lisp/mh-e/mh-print.el +++ b/lisp/mh-e/mh-print.el @@ -30,15 +30,10 @@ ;;; Code: -;;(message "> mh-print") -(eval-when-compile (require 'mh-acros)) -(mh-require-cl) +(require 'mh-e) +(require 'mh-scan) + (require 'ps-print) -(require 'mh-buffers) -(require 'mh-utils) -(require 'mh-funcs) -(eval-when-compile (require 'mh-seq)) -;;(message "< mh-print") (defvar mh-ps-print-color-option ps-print-color-p "Specify how buffer's text color is printed. @@ -48,7 +43,7 @@ Valid values are: nil - Do not print colors. t - Print colors. black-white - Print colors on black/white printer. - See also `ps-black-white-faces'. + See also `ps-black-white-faces'. Any other value is treated as t. This variable is initialized from `ps-print-color-p'.") @@ -59,54 +54,6 @@ from `ps-print-color-p'.") Sensible choices are the functions `ps-spool-buffer' and `ps-spool-buffer-with-faces'.") -(defun mh-ps-spool-buffer (buffer) - "Spool BUFFER." - (save-excursion - (set-buffer buffer) - (let ((ps-print-color-p mh-ps-print-color-option) - (ps-left-header - (list - (concat "(" (mh-get-header-field "Subject:") ")") - (concat "(" (mh-get-header-field "From:") ")"))) - (ps-right-header - (list - "/pagenumberstring load" - (concat "(" (mh-get-header-field "Date:") ")")))) - (funcall mh-ps-print-func)))) - -(defun mh-ps-spool-msg (msg) - "Spool MSG." - (let* ((folder mh-current-folder) - (buffer (mh-in-show-buffer (mh-show-buffer) - (if (not (equal (mh-msg-filename msg folder) - buffer-file-name)) - (get-buffer-create mh-temp-buffer))))) - (unwind-protect - (save-excursion - (if buffer - (let ((mh-show-buffer buffer)) - (mh-display-msg msg folder))) - (mh-ps-spool-buffer (if buffer buffer mh-show-buffer))) - (if buffer - (kill-buffer buffer))))) - -(defun mh-ps-print-range (range file) - "Print RANGE to FILE. - -This is the function that actually does the work. -If FILE is nil, then the messages are spooled to the printer." - (mh-iterate-on-range msg range - (unwind-protect - (mh-ps-spool-msg msg)) - (mh-notate msg mh-note-printed mh-cmd-note)) - (ps-despool file)) - -(defun mh-ps-print-preprint (prefix-arg) - "Provide a better default file name for `ps-print-preprint'. -Pass along the PREFIX-ARG to it." - (let ((buffer-file-name (format "mh-%s" (substring (buffer-name) 1)))) - (ps-print-preprint prefix-arg))) - ;;;###mh-autoload (defun mh-ps-print-msg (range) "Print RANGE\\<mh-folder-mode-map>. @@ -130,6 +77,48 @@ commands \\[mh-ps-print-toggle-color] and (interactive (list (mh-interactive-range "Print"))) (mh-ps-print-range range nil)) +(defun mh-ps-print-range (range file) + "Print RANGE to FILE. + +This is the function that actually does the work. +If FILE is nil, then the messages are spooled to the printer." + (mh-iterate-on-range msg range + (unwind-protect + (mh-ps-spool-msg msg)) + (mh-notate msg mh-note-printed mh-cmd-note)) + (ps-despool file)) + +(defun mh-ps-spool-msg (msg) + "Spool MSG." + (let* ((folder mh-current-folder) + (buffer (mh-in-show-buffer (mh-show-buffer) + (if (not (equal (mh-msg-filename msg folder) + buffer-file-name)) + (get-buffer-create mh-temp-buffer))))) + (unwind-protect + (save-excursion + (if buffer + (let ((mh-show-buffer buffer)) + (mh-display-msg msg folder))) + (mh-ps-spool-buffer (if buffer buffer mh-show-buffer))) + (if buffer + (kill-buffer buffer))))) + +(defun mh-ps-spool-buffer (buffer) + "Spool BUFFER." + (save-excursion + (set-buffer buffer) + (let ((ps-print-color-p mh-ps-print-color-option) + (ps-left-header + (list + (concat "(" (mh-get-header-field "Subject:") ")") + (concat "(" (mh-get-header-field "From:") ")"))) + (ps-right-header + (list + "/pagenumberstring load" + (concat "(" (mh-get-header-field "Date:") ")")))) + (funcall mh-ps-print-func)))) + ;;;###mh-autoload (defun mh-ps-print-msg-file (range file) "Print RANGE to FILE\\<mh-folder-mode-map>. @@ -153,6 +142,12 @@ commands \\[mh-ps-print-toggle-color] and (interactive (list (mh-interactive-range "Print") (mh-ps-print-preprint 1))) (mh-ps-print-range range file)) +(defun mh-ps-print-preprint (prefix-arg) + "Provide a better default file name for `ps-print-preprint'. +Pass along the PREFIX-ARG to it." + (let ((buffer-file-name (format "mh-%s" (substring (buffer-name) 1)))) + (ps-print-preprint prefix-arg))) + ;;;###mh-autoload (defun mh-ps-print-toggle-faces () "Toggle whether printing is done with faces or not. @@ -185,8 +180,8 @@ change this setting permanently by customizing the option (message "Colors will be printed as black & white")) (if (eq mh-ps-print-color-option 'black-white) (progn - (setq mh-ps-print-color-option t) - (message "Colors will be printed")) + (setq mh-ps-print-color-option t) + (message "Colors will be printed")) (setq mh-ps-print-color-option nil) (message "Colors will not be printed")))) diff --git a/lisp/mh-e/mh-scan.el b/lisp/mh-e/mh-scan.el new file mode 100644 index 00000000000..b52f2b4eeb8 --- /dev/null +++ b/lisp/mh-e/mh-scan.el @@ -0,0 +1,490 @@ +;;; mh-scan.el --- MH-E scan line constants and utilities + +;; Copyright (C) 1993, 1995, 1997, +;; 2000, 2001, 2002, 2003, 2004, 2005, 2006 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., 51 Franklin Street, Fifth Floor, +;; Boston, MA 02110-1301, USA. + +;;; Commentary: + +;; This file contains constants and a few functions for interpreting +;; scan lines. + +;;; Change Log: + +;;; Code: + +(require 'mh-e) + + + +;;; Scan Formats + +;; The following scan formats are passed to the scan program if the setting of +;; `mh-scan-format-file' is t. They are identical except the later one makes +;; use of the nmh `decode' function to decode RFC 2047 encodings. If you just +;; want to change the column of the notations, use the `mh-set-cmd-note' +;; function. + +(defvar mh-scan-format-mh + (concat + "%4(msg)" + "%<(cur)+%| %>" + "%<{replied}-" + "%?(nonnull(comp{to}))%<(mymbox{to})t%>" + "%?(nonnull(comp{cc}))%<(mymbox{cc})c%>" + "%?(nonnull(comp{bcc}))%<(mymbox{bcc})b%>" + "%?(nonnull(comp{newsgroups}))n%>" + "%<(zero) %>" + "%02(mon{date})/%02(mday{date})%<{date} %|*%>" + "%<(mymbox{from})%<{to}To:%14(friendly{to})%>%>" + "%<(zero)%17(friendly{from})%> " + "%{subject}%<{body}<<%{body}%>") + "*Scan format string for MH. +This string is passed to the scan program via the -format +argument. This format is identical to the default except that +additional hints for fontification have been added to the fifth +column (remember that in Emacs, the first column is 0). + +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-format-nmh + (concat + "%4(msg)" + "%<(cur)+%| %>" + "%<{replied}-" + "%?(nonnull(comp{to}))%<(mymbox{to})t%>" + "%?(nonnull(comp{cc}))%<(mymbox{cc})c%>" + "%?(nonnull(comp{bcc}))%<(mymbox{bcc})b%>" + "%?(nonnull(comp{newsgroups}))n%>" + "%<(zero) %>" + "%02(mon{date})/%02(mday{date})%<{date} %|*%>" + "%<(mymbox{from})%<{to}To:%14(decode(friendly{to}))%>%>" + "%<(zero)%17(decode(friendly{from}))%> " + "%(decode{subject})%<{body}<<%{body}%>") + "*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 fifth +column (remember that in Emacs, the first column is 0). + +The values of the fifth column, in priority order, are: \"-\" if +the message has been replied to, t if an address on the To: field +matches one of the mailboxes of the current user, \"c\" if the Cc: +field matches, \"b\" if the Bcc: field matches, and \"n\" if a +non-empty Newsgroups: field is present.") + + + +;;; Regular Expressions + +;; Alphabetical. + +(defvar mh-scan-body-regexp "\\(<<\\([^\n]+\\)?\\)" + "This regular expression matches the message body fragment. + +Note that the default setting of `mh-folder-font-lock-keywords' +expects this expression to contain at least one parenthesized +expression which matches the body text as in the default of +\"\\\\(<<\\\\([^\\n]+\\\\)?\\\\)\". If this regular expression is +not correct, the body fragment will not be highlighted with the +face `mh-folder-body'.") + +(defvar mh-scan-cur-msg-number-regexp "^\\( *[0-9]+\\+\\).*" + "This regular expression matches the current message. + +It must match from the beginning of the line. Note that the +default setting of `mh-folder-font-lock-keywords' expects this +expression to contain at least one parenthesized expression which +matches the message number as in the default of + + \"^\\\\( *[0-9]+\\\\+\\\\).*\". + +This expression includes the leading space and current message +marker \"+\" within the parenthesis since it looks better to +highlight these items as well. The highlighting is done with the +face `mh-folder-cur-msg-number'. This regular expression should +be correct as it is needed by non-fontification functions. See +also `mh-note-cur'.") + +(defvar mh-scan-date-regexp "\\([0-9][0-9]/[0-9][0-9]\\)" + "This regular expression matches a valid date. + +It must not be anchored to the beginning or the end of the line. +Note that the default setting of `mh-folder-font-lock-keywords' +expects this expression to contain only one parenthesized +expression which matches the date field as in the default of +\"\\\\([0-9][0-9]/[0-9][0-9]\\\\)\"}. If this regular expression +is not correct, the date will not be highlighted with the face +`mh-folder-date'.") + +(defvar mh-scan-deleted-msg-regexp "^\\( *[0-9]+\\)D" + "This regular expression matches deleted messages. + +It must match from the beginning of the line. Note that the +default setting of `mh-folder-font-lock-keywords' expects this +expression to contain at least one parenthesized expression which +matches the message number as in the default of + + \"^\\\\( *[0-9]+\\\\)D\". + +This expression includes the leading space within the parenthesis +since it looks better to highlight it as well. The highlighting +is done with the face `mh-folder-deleted'. This regular +expression should be correct as it is needed by non-fontification +functions. See also `mh-note-deleted'.") + +(defvar mh-scan-good-msg-regexp "^\\( *[0-9]+\\)[^D^0-9]" + "This regular expression matches \"good\" messages. + +It must match from the beginning of the line. Note that the +default setting of `mh-folder-font-lock-keywords' expects this +expression to contain at least one parenthesized expression which +matches the message number as in the default of + + \"^\\\\( *[0-9]+\\\\)[^D^0-9]\". + +This expression includes the leading space within the parenthesis +since it looks better to highlight it as well. The highlighting +is done with the face `mh-folder-msg-number'. This regular +expression should be correct as it is needed by non-fontification +functions.") + +(defvar mh-scan-msg-format-regexp "%\\([0-9]*\\)(msg)" + "This regular expression finds the message number width in a scan format. + +Note that the message number must be placed in a parenthesized +expression as in the default of \"%\\\\([0-9]*\\\\)(msg)\". This +variable is only consulted if `mh-scan-format-file' is set to +\"Use MH-E scan Format\".") + +(defvar mh-scan-msg-format-string "%d" + "This is a format string for width of the message number in a scan format. + +Use \"0%d\" for zero-filled message numbers. This variable is only +consulted if `mh-scan-format-file' is set to \"Use MH-E scan +Format\".") + +(defvar mh-scan-msg-number-regexp "^ *\\([0-9]+\\)" + "This regular expression extracts the message number. + +It must match from the beginning of the line. Note that the +message number must be placed in a parenthesized expression as in +the default of \"^ *\\\\([0-9]+\\\\)\".") + +(defvar mh-scan-msg-overflow-regexp "^[?0-9][0-9]" + "This regular expression matches overflowed message numbers.") + +(defvar mh-scan-msg-search-regexp "^[^0-9]*%d[^0-9]" + "This regular expression matches a particular message. + +It is a format string; use \"%d\" to represent the location of the +message number within the expression as in the default of +\"^[^0-9]*%d[^0-9]\".") + +(defvar mh-scan-rcpt-regexp "\\(To:\\)\\(..............\\)" + "This regular expression specifies the recipient in messages you sent. + +Note that the default setting of `mh-folder-font-lock-keywords' +expects this expression to contain two parenthesized expressions. +The first is expected to match the \"To:\" that the default scan +format file generates. The second is expected to match the +recipient's name as in the default of +\"\\\\(To:\\\\)\\\\(..............\\\\)\". If this regular +expression is not correct, the \"To:\" string will not be +highlighted with the face `mh-folder-to' and the recipient will +not be highlighted with the face `mh-folder-address'") + +(defvar mh-scan-refiled-msg-regexp "^\\( *[0-9]+\\)\\^" + "This regular expression matches refiled messages. + +It must match from the beginning of the line. Note that the +default setting of `mh-folder-font-lock-keywords' expects this +expression to contain at least one parenthesized expression which +matches the message number as in the default of + + \"^\\\\( *[0-9]+\\\\)\\\\^\". + +This expression includes the leading space within the parenthesis +since it looks better to highlight it as well. The highlighting +is done with the face `mh-folder-refiled'. This regular +expression should be correct as it is needed by non-fontification +functions. See also `mh-note-refiled'.") + +(defvar mh-scan-sent-to-me-sender-regexp + "^ *[0-9]+.\\([bct]\\).....[ ]*\\(..................\\)" + "This regular expression matches messages sent to us. + +Note that the default setting of `mh-folder-font-lock-keywords' +expects this expression to contain at least two parenthesized +expressions. The first should match the fontification hint (see +`mh-scan-format-nmh') and the second should match the user name +as in the default of + + ^ *[0-9]+.\\\\([bct]\\\\).....[ ]*\\\\(..................\\\\) + +If this regular expression is not correct, the notation hints +will not be highlighted with the face +`mh-mh-folder-sent-to-me-hint' and the sender will not be +highlighted with the face `mh-folder-sent-to-me-sender'.") + +(defvar mh-scan-subject-regexp + "^ *[0-9]+........[ ]*...................\\([Rr][Ee]\\(\\[[0-9]+\\]\\)?:\\s-*\\)*\\([^<\n]*\\)" + "This regular expression matches the subject. + +It must match from the beginning of the line. Note that the +default setting of `mh-folder-font-lock-keywords' expects this +expression to contain at least three parenthesized expressions. +The first is expected to match the \"Re:\" string, if any, and is +highlighted with the face `mh-folder-followup'. The second +matches an optional bracketed number after \"Re:\", such as in +\"Re[2]:\" (and is thus a sub-expression of the first expression) +and the third is expected to match the subject line itself which +is highlighted with the face `mh-folder-subject'. For example, +the default (broken on multiple lines for readability) is + + ^ *[0-9]+........[ ]*................... + \\\\([Rr][Ee]\\\\(\\\\\\=[[0-9]+\\\\]\\\\)?:\\\\s-*\\\\)* + \\\\([^<\\n]*\\\\) + +This regular expression should be correct as it is needed by +non-fontification functions.") + +(defvar mh-scan-valid-regexp "^ *[0-9]" + "This regular expression describes a valid scan line. + +This is used to eliminate error messages that are occasionally +produced by \"inc\".") + + + +;;; Widths, Offsets and Columns + +(defvar mh-cmd-note 4 + "Column for notations. + +This variable should be set with the function `mh-set-cmd-note'. +This variable may be updated dynamically if +`mh-adaptive-cmd-note-flag' is on. + +Note that columns in Emacs start with 0.") +(make-variable-buffer-local 'mh-cmd-note) + +(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. + + \" \" blank space is the default character. + \"%\" indicates that the message in in a named MH sequence. + \"-\" indicates that the message has been annotated with a replied field. + \"t\" indicates that the message contains mymbox in the To: field. + \"c\" indicates that the message contains mymbox in the Cc: field. + \"b\" indicates that the message contains mymbox in the Bcc: field. + \"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-destination-offset + (+ mh-scan-cmd-note-width) + "The offset from the `mh-cmd-note' for the destination column.") + +(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.") + + + +;;; Notation + +;; Alphabetical. + +(defvar mh-note-cur ?+ + "The current message (in MH, not in MH-E) is marked by this character. +See also `mh-scan-cur-msg-number-regexp'.") + +(defvar mh-note-copied "C" + "Messages that have been copied are marked by this character.") + +(defvar mh-note-deleted ?D + "Messages that have been deleted are marked by this character. +See also `mh-scan-deleted-msg-regexp'.") + +(defvar mh-note-dist ?R + "Messages that have been redistributed are marked by this character.") + +(defvar mh-note-forw ?F + "Messages that have been forwarded are marked by this character.") + +(defvar mh-note-printed "P" + "Messages that have been printed are marked by this character.") + +(defvar mh-note-refiled ?^ + "Messages that have been refiled are marked by this character. +See also `mh-scan-refiled-msg-regexp'.") + +(defvar mh-note-repl ?- + "Messages that have been replied to are marked by this character.") + +(defvar mh-note-seq ?% + "Messages in a user-defined sequence are marked by this character. + +Messages in the \"search\" sequence are marked by this character as +well.") + + + +;;; Utilities + +;;;###mh-autoload +(defun mh-scan-msg-number-regexp () + "Return value of variable `mh-scan-msg-number-regexp'." + mh-scan-msg-number-regexp) + +;;;###mh-autoload +(defun mh-scan-msg-search-regexp () + "Return value of variable `mh-scan-msg-search-regexp'." + mh-scan-msg-search-regexp) + +;;;###mh-autoload +(defun mh-set-cmd-note (column) + "Set `mh-cmd-note' to COLUMN. +Note that columns in Emacs start with 0." + (setq mh-cmd-note column)) + +;;;###mh-autoload +(defun mh-scan-format () + "Return the output format argument for the scan program." + (if (equal mh-scan-format-file t) + (list "-format" (if (mh-variant-p 'nmh 'mu-mh) + (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)))) + +(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)) + +;;;###mh-autoload +(defun mh-msg-num-width (folder) + "Return the width of the largest 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 mh-scan-prog 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)) + +;;;###mh-autoload +(defun mh-msg-num-width-to-column (width) + "Return the column for notations given message number WIDTH. +Note that columns in Emacs start with 0. + +If `mh-scan-format-file' is set to \"Use MH-E scan Format\" this +means that either `mh-scan-format-mh' or `mh-scan-format-nmh' are +in use. This function therefore assumes that the first column is +empty (to provide room for the cursor), the following WIDTH +columns contain the message number, and the column for notations +comes after that." + (if (eq mh-scan-format-file t) + (max (1+ width) 2) + (error "%s %s" "Can't call `mh-msg-num-width-to-column' when" + "`mh-scan-format-file' is not set to \"Use MH-E scan Format\""))) + +(provide 'mh-scan) + +;; Local Variables: +;; indent-tabs-mode: nil +;; sentence-end-double-space: nil +;; End: + +;;; mh-scan.el ends here diff --git a/lisp/mh-e/mh-search.el b/lisp/mh-e/mh-search.el index 55e6d7b076f..9fc9355a065 100644 --- a/lisp/mh-e/mh-search.el +++ b/lisp/mh-e/mh-search.el @@ -1,4 +1,4 @@ -;;; mh-search --- MH-E search +;;; mh-search --- MH-Search mode ;; Copyright (C) 1993, 1995, ;; 2001, 2002, 2003, 2004, 2005, 2006 Free Software Foundation, Inc. @@ -27,6 +27,8 @@ ;;; Commentary: +;; Mode used to compose search criteria. + ;; (1) The following search engines are supported: ;; swish++ ;; swish-e @@ -34,7 +36,7 @@ ;; namazu ;; pick ;; grep -;; + ;; (2) To use this package, you first have to build an index. Please ;; read the documentation for `mh-search' to get started. That ;; documentation will direct you to the specific instructions for @@ -44,14 +46,12 @@ ;;; Code: -;;(message "> mh-search") -(eval-when-compile (require 'mh-acros)) +(require 'mh-e) (mh-require-cl) (require 'gnus-util) -(require 'mh-buffers) -(require 'mh-e) -;;(message "< mh-search") +(require 'imenu) +(require 'which-func nil t) (defvar mh-searcher nil "Cached value of chosen search program.") @@ -79,7 +79,7 @@ message number, and optionally the match.") -;;; MH-Search mode +;;; MH-Folder Commands ;;;###mh-autoload (defun* mh-search (folder search-regexp @@ -322,6 +322,9 @@ folder containing the index search results." (loop for msg-hash being hash-values of mh-index-data count (> (hash-table-count msg-hash) 0)))))) +;; Shush compiler. +(eval-when-compile (mh-do-in-xemacs (defvar pick-folder))) + (defun mh-search-folder (folder window-config) "Search FOLDER for messages matching a pattern. @@ -363,11 +366,193 @@ configuration and is used when the search folder is dismissed." (add-text-properties (point) (1- (line-end-position)) '(read-only t)) (goto-char (point-max))) +;; Sequence Searches + ;;;###mh-autoload -(defvar mh-search-mode-map (make-sparse-keymap) - "Keymap for searching folder.") +(defun mh-index-new-messages (folders) + "Display unseen messages. + +If you use a program such as \"procmail\" to use \"rcvstore\" to file +your incoming mail automatically, you can display new, unseen, +messages using this command. All messages in the \"unseen\" +sequence from the folders in `mh-new-messages-folders' are +listed. + +With a prefix argument, enter a space-separated list of FOLDERS, +or nothing to search all folders." + (interactive + (list (if current-prefix-arg + (split-string (read-string "Search folder(s) (default all): ")) + mh-new-messages-folders))) + (mh-index-sequenced-messages folders mh-unseen-seq)) ;;;###mh-autoload +(defun mh-index-ticked-messages (folders) + "Display ticked messages. + +All messages in `mh-tick-seq' from the folders in +`mh-ticked-messages-folders' are listed. + +With a prefix argument, enter a space-separated list of FOLDERS, +or nothing to search all folders." + (interactive + (list (if current-prefix-arg + (split-string (read-string "Search folder(s) (default all): ")) + mh-ticked-messages-folders))) + (mh-index-sequenced-messages folders mh-tick-seq)) + +;; Shush compiler. +(eval-when-compile + (mh-do-in-xemacs + (defvar mh-mairix-folder) + (defvar mh-flists-search-folders))) + +;;;###mh-autoload +(defun mh-index-sequenced-messages (folders sequence) + "Display messages in any sequence. + +All messages from the FOLDERS in `mh-new-messages-folders' in the +SEQUENCE you provide are listed. With a prefix argument, enter a +space-separated list of folders at the prompt, or nothing to +search all folders." + (interactive + (list (if current-prefix-arg + (split-string (read-string "Search folder(s) (default all): ")) + mh-new-messages-folders) + (mh-read-seq-default "Search" nil))) + (unless sequence (setq sequence mh-unseen-seq)) + (let* ((mh-flists-search-folders folders) + (mh-flists-sequence sequence) + (mh-flists-called-flag t) + (mh-searcher 'flists) + (mh-search-function 'mh-flists-execute) + (mh-search-next-result-function 'mh-mairix-next-result) + (mh-mairix-folder mh-user-path) + (mh-search-regexp-builder nil) + (new-folder (format "%s/%s/%s" mh-index-folder + mh-flists-results-folder sequence)) + (window-config (if (equal new-folder mh-current-folder) + mh-previous-window-config + (current-window-configuration))) + (redo-flag nil) + message) + (cond ((buffer-live-p (get-buffer new-folder)) + ;; The destination folder is being visited. Trick `mh-search' + ;; into thinking that the folder resulted from a previous search. + (set-buffer new-folder) + (setq mh-index-previous-search (list folders mh-searcher sequence)) + (setq redo-flag t)) + ((mh-folder-exists-p new-folder) + ;; Folder exists but we don't have it open. That means they are + ;; stale results from a old flists search. Clear it out. + (mh-exec-cmd-quiet nil "rmf" new-folder))) + (setq message (mh-search "+" mh-flists-results-folder + redo-flag window-config) + mh-index-sequence-search-flag t + mh-index-previous-search (list folders mh-searcher sequence)) + (mh-index-write-data) + (when (stringp message) (message "%s" message)))) + +(defvar mh-flists-search-folders) + +(defun mh-flists-execute (&rest args) + "Execute flists. +Search for messages belonging to `mh-flists-sequence' in the +folders specified by `mh-flists-search-folders'. If +`mh-recursive-folders-flag' is t, then the folders are searched +recursively. All parameters ARGS are ignored." + (set-buffer (get-buffer-create mh-temp-index-buffer)) + (erase-buffer) + (unless (executable-find "sh") + (error "Didn't find sh")) + (with-temp-buffer + (let ((seq (symbol-name mh-flists-sequence))) + (insert "for folder in `" (expand-file-name "flists" mh-progs) " " + (cond ((eq mh-flists-search-folders t) + (mh-quote-for-shell mh-inbox)) + ((eq mh-flists-search-folders nil) "") + ((listp mh-flists-search-folders) + (loop for folder in mh-flists-search-folders + concat + (concat " " (mh-quote-for-shell folder))))) + (if mh-recursive-folders-flag " -recurse" "") + " -sequence " seq " -noshowzero -fast` ; do\n" + (expand-file-name "mhpath" mh-progs) " \"+$folder\" " seq "\n" + "done\n")) + (call-process-region + (point-min) (point-max) "sh" nil (get-buffer mh-temp-index-buffer)))) + +;; Navigation + +;;;###mh-autoload +(defun mh-index-next-folder (&optional backward-flag) + "Jump to the next folder marker. + +With non-nil optional argument BACKWARD-FLAG, jump to the previous +group of results." + (interactive "P") + (if (null mh-index-data) + (message "Only applicable in an MH-E index search buffer") + (let ((point (point))) + (forward-line (if backward-flag 0 1)) + (cond ((if backward-flag + (re-search-backward "^+" (point-min) t) + (re-search-forward "^+" (point-max) t)) + (beginning-of-line)) + ((and (if backward-flag + (goto-char (point-max)) + (goto-char (point-min))) + nil)) + ((if backward-flag + (re-search-backward "^+" (point-min) t) + (re-search-forward "^+" (point-max) t)) + (beginning-of-line)) + (t (goto-char point)))))) + +;;;###mh-autoload +(defun mh-index-previous-folder () + "Jump to the previous folder marker." + (interactive) + (mh-index-next-folder t)) + +;;;###mh-autoload +(defun mh-index-visit-folder () + "Visit original folder from where the message at point was found." + (interactive) + (unless mh-index-data + (error "Not in an index folder")) + (let (folder msg) + (save-excursion + (cond ((and (bolp) (eolp)) + (ignore-errors (forward-line -1)) + (setq msg (mh-get-msg-num t))) + ((equal (char-after (line-beginning-position)) ?+) + (setq folder (buffer-substring-no-properties + (line-beginning-position) (line-end-position)))) + (t (setq msg (mh-get-msg-num t))))) + (when (not folder) + (setq folder (car (gethash (gethash msg mh-index-msg-checksum-map) + mh-index-checksum-origin-map)))) + (when (or (not (get-buffer folder)) + (y-or-n-p (format "Reuse buffer displaying %s? " folder))) + (mh-visit-folder + folder (loop for x being the hash-keys of (gethash folder mh-index-data) + when (mh-msg-exists-p x folder) collect x))))) + + + +;;; Search Menu + +(easy-menu-define + mh-pick-menu mh-search-mode-map "Menu for MH-E Search" + '("Search" + ["Perform Search" mh-index-do-search t] + ["Search with pick" mh-pick-do-search t])) + + + +;;; MH-Search Keys + ;; If this changes, modify mh-search-mode-help-messages accordingly, below. (gnus-define-keys mh-search-mode-map "\C-c?" mh-help @@ -375,30 +560,24 @@ configuration and is used when the search folder is dismissed." "\C-c\C-p" mh-pick-do-search "\C-c\C-f\C-b" mh-to-field "\C-c\C-f\C-c" mh-to-field - "\C-c\C-f\C-d" mh-to-field - "\C-c\C-f\C-f" mh-to-field - "\C-c\C-f\C-r" mh-to-field + "\C-c\C-f\C-m" mh-to-field "\C-c\C-f\C-s" mh-to-field "\C-c\C-f\C-t" mh-to-field "\C-c\C-fb" mh-to-field "\C-c\C-fc" mh-to-field - "\C-c\C-fd" mh-to-field - "\C-c\C-ff" mh-to-field - "\C-c\C-fr" mh-to-field + "\C-c\C-fm" mh-to-field "\C-c\C-fs" mh-to-field "\C-c\C-ft" mh-to-field) -(easy-menu-define - mh-pick-menu mh-search-mode-map "Menu for MH-E Search" - '("Search" - ["Perform Search" mh-index-do-search t] - ["Search with pick" mh-pick-do-search t])) + + +;;; MH-Search Help Messages ;; Group messages logically, more or less. (defvar mh-search-mode-help-messages '((nil - "Perform search: \\[mh-index-do-search]\n" - "Search with pick: \\[mh-pick-do-search]\n" + "Perform search: \\[mh-index-do-search]\n" + "Search with pick: \\[mh-pick-do-search]\n\n" "Move to a field by typing C-c C-f C-<field>\n" "where <field> is the first letter of the desired field\n" "(except for From: which uses \"m\").")) @@ -413,6 +592,10 @@ display the non-prefixed commands. The substitutions described in `substitute-command-keys' are performed as well.") + + +;;; MH-Search Mode + (put 'mh-search-mode 'mode-class 'special) (define-derived-mode mh-search-mode fundamental-mode "MH-Search" @@ -435,11 +618,13 @@ The hook `mh-search-mode-hook' is called upon entry to this mode. \\{mh-search-mode-map}" - (make-local-variable 'mh-help-messages) (easy-menu-add mh-pick-menu) - (setq mh-help-messages mh-search-mode-help-messages)) + (mh-set-help mh-search-mode-help-messages)) + + + +;;; MH-Search Commands -;;;###mh-autoload (defun mh-index-do-search (&optional searcher) "Find messages using `mh-search-program'. If optional argument SEARCHER is present, use it instead of @@ -452,7 +637,6 @@ If optional argument SEARCHER is present, use it instead of (mh-search mh-current-folder pattern nil mh-previous-window-config) (error "No search terms")))) -;;;###mh-autoload (defun mh-pick-do-search () "Find messages using \"pick\". @@ -490,7 +674,6 @@ The cdr of the element is the pattern to search." (forward-line)) pattern-list))) -;;;###mh-autoload (defun mh-index-parse-search-regexp (input-string) "Construct parse tree for INPUT-STRING. All occurrences of &, |, ! and ~ in INPUT-STRING are replaced by @@ -594,296 +777,7 @@ parsed." -;;; Sequence browsing - -;;;###mh-autoload -(defun mh-index-new-messages (folders) - "Display unseen messages. - -If you use a program such as \"procmail\" to use \"rcvstore\" to file -your incoming mail automatically, you can display new, unseen, -messages using this command. All messages in the \"unseen\" -sequence from the folders in `mh-new-messages-folders' are -listed. - -With a prefix argument, enter a space-separated list of FOLDERS, -or nothing to search all folders." - (interactive - (list (if current-prefix-arg - (split-string (read-string "Search folder(s) (default all): ")) - mh-new-messages-folders))) - (mh-index-sequenced-messages folders mh-unseen-seq)) - -;;;###mh-autoload -(defun mh-index-ticked-messages (folders) - "Display ticked messages. - -All messages in `mh-tick-seq' from the folders in -`mh-ticked-messages-folders' are listed. - -With a prefix argument, enter a space-separated list of FOLDERS, -or nothing to search all folders." - (interactive - (list (if current-prefix-arg - (split-string (read-string "Search folder(s) (default all): ")) - mh-ticked-messages-folders))) - (mh-index-sequenced-messages folders mh-tick-seq)) - -;;;###mh-autoload -(defun mh-index-sequenced-messages (folders sequence) - "Display messages in any sequence. - -All messages from the FOLDERS in `mh-new-messages-folders' in the -SEQUENCE you provide are listed. With a prefix argument, enter a -space-separated list of folders at the prompt, or nothing to -search all folders." - (interactive - (list (if current-prefix-arg - (split-string (read-string "Search folder(s) (default all): ")) - mh-new-messages-folders) - (mh-read-seq-default "Search" nil))) - (unless sequence (setq sequence mh-unseen-seq)) - (let* ((mh-flists-search-folders folders) - (mh-flists-sequence sequence) - (mh-flists-called-flag t) - (mh-searcher 'flists) - (mh-search-function 'mh-flists-execute) - (mh-search-next-result-function 'mh-mairix-next-result) - (mh-mairix-folder mh-user-path) - (mh-search-regexp-builder nil) - (new-folder (format "%s/%s/%s" mh-index-folder - mh-flists-results-folder sequence)) - (window-config (if (equal new-folder mh-current-folder) - mh-previous-window-config - (current-window-configuration))) - (redo-flag nil) - message) - (cond ((buffer-live-p (get-buffer new-folder)) - ;; The destination folder is being visited. Trick `mh-search' - ;; into thinking that the folder resulted from a previous search. - (set-buffer new-folder) - (setq mh-index-previous-search (list folders mh-searcher sequence)) - (setq redo-flag t)) - ((mh-folder-exists-p new-folder) - ;; Folder exists but we don't have it open. That means they are - ;; stale results from a old flists search. Clear it out. - (mh-exec-cmd-quiet nil "rmf" new-folder))) - (setq message (mh-search "+" mh-flists-results-folder - redo-flag window-config) - mh-index-sequence-search-flag t - mh-index-previous-search (list folders mh-searcher sequence)) - (mh-index-write-data) - (when (stringp message) (message "%s" message)))) - -(defvar mh-flists-search-folders) - -(defun mh-flists-execute (&rest args) - "Execute flists. -Search for messages belonging to `mh-flists-sequence' in the -folders specified by `mh-flists-search-folders'. If -`mh-recursive-folders-flag' is t, then the folders are searched -recursively. All parameters ARGS are ignored." - (set-buffer (get-buffer-create mh-temp-index-buffer)) - (erase-buffer) - (unless (executable-find "sh") - (error "Didn't find sh")) - (with-temp-buffer - (let ((seq (symbol-name mh-flists-sequence))) - (insert "for folder in `" (expand-file-name "flists" mh-progs) " " - (cond ((eq mh-flists-search-folders t) - (mh-quote-for-shell mh-inbox)) - ((eq mh-flists-search-folders nil) "") - ((listp mh-flists-search-folders) - (loop for folder in mh-flists-search-folders - concat - (concat " " (mh-quote-for-shell folder))))) - (if mh-recursive-folders-flag " -recurse" "") - " -sequence " seq " -noshowzero -fast` ; do\n" - (expand-file-name "mhpath" mh-progs) " \"+$folder\" " seq "\n" - "done\n")) - (call-process-region - (point-min) (point-max) "sh" nil (get-buffer mh-temp-index-buffer)))) - - - -;;; Folder navigation and utilities - -;;;###mh-autoload -(defun mh-index-group-by-folder () - "Partition the messages based on source folder. -Returns an alist with the the folder names in the car and the cdr -being the list of messages originally from that folder." - (save-excursion - (goto-char (point-min)) - (let ((result-table (make-hash-table :test #'equal))) - (loop for msg being hash-keys of mh-index-msg-checksum-map - do (push msg (gethash (car (gethash - (gethash msg mh-index-msg-checksum-map) - mh-index-checksum-origin-map)) - result-table))) - (loop for x being the hash-keys of result-table - collect (cons x (nreverse (gethash x result-table))))))) - -;;;###mh-autoload -(defun mh-index-insert-folder-headers () - "Annotate the search results with original folder names." - (let ((cur-msg (mh-get-msg-num nil)) - (old-buffer-modified-flag (buffer-modified-p)) - (buffer-read-only nil) - current-folder last-folder) - (goto-char (point-min)) - (while (not (eobp)) - (setq current-folder (car (gethash (gethash (mh-get-msg-num nil) - mh-index-msg-checksum-map) - mh-index-checksum-origin-map))) - (when (and current-folder (not (equal current-folder last-folder))) - (insert (if last-folder "\n" "") current-folder "\n") - (setq last-folder current-folder)) - (forward-line)) - (when cur-msg - (mh-notate-cur) - (mh-goto-msg cur-msg t)) - (set-buffer-modified-p old-buffer-modified-flag)) - (mh-index-create-imenu-index)) - -;;;###mh-autoload -(defun mh-index-delete-folder-headers () - "Delete the folder headers." - (let ((cur-msg (mh-get-msg-num nil)) - (old-buffer-modified-flag (buffer-modified-p)) - (buffer-read-only nil)) - (while (and (not cur-msg) (not (eobp))) - (forward-line) - (setq cur-msg (mh-get-msg-num nil))) - (goto-char (point-min)) - (while (not (eobp)) - (if (or (char-equal (char-after) ?+) (char-equal (char-after) 10)) - (delete-region (point) (progn (forward-line) (point))) - (forward-line))) - (when cur-msg (mh-goto-msg cur-msg t t)) - (set-buffer-modified-p old-buffer-modified-flag))) - -;;;###mh-autoload -(defun mh-index-create-imenu-index () - "Create alist of folder names and positions in index folder buffers." - (save-excursion - (setq which-func-mode t) - (let ((alist ())) - (goto-char (point-min)) - (while (re-search-forward "^+" nil t) - (save-excursion - (beginning-of-line) - (push (cons (buffer-substring-no-properties - (point) (line-end-position)) - (set-marker (make-marker) (point))) - alist))) - (setq imenu--index-alist (nreverse alist))))) - -;;;###mh-autoload -(defun mh-index-next-folder (&optional backward-flag) - "Jump to the next folder marker. - -With non-nil optional argument BACKWARD-FLAG, jump to the previous -group of results." - (interactive "P") - (if (null mh-index-data) - (message "Only applicable in an MH-E index search buffer") - (let ((point (point))) - (forward-line (if backward-flag 0 1)) - (cond ((if backward-flag - (re-search-backward "^+" (point-min) t) - (re-search-forward "^+" (point-max) t)) - (beginning-of-line)) - ((and (if backward-flag - (goto-char (point-max)) - (goto-char (point-min))) - nil)) - ((if backward-flag - (re-search-backward "^+" (point-min) t) - (re-search-forward "^+" (point-max) t)) - (beginning-of-line)) - (t (goto-char point)))))) - -;;;###mh-autoload -(defun mh-index-previous-folder () - "Jump to the previous folder marker." - (interactive) - (mh-index-next-folder t)) - -;;;###mh-autoload -(defun mh-index-visit-folder () - "Visit original folder from where the message at point was found." - (interactive) - (unless mh-index-data - (error "Not in an index folder")) - (let (folder msg) - (save-excursion - (cond ((and (bolp) (eolp)) - (ignore-errors (forward-line -1)) - (setq msg (mh-get-msg-num t))) - ((equal (char-after (line-beginning-position)) ?+) - (setq folder (buffer-substring-no-properties - (line-beginning-position) (line-end-position)))) - (t (setq msg (mh-get-msg-num t))))) - (when (not folder) - (setq folder (car (gethash (gethash msg mh-index-msg-checksum-map) - mh-index-checksum-origin-map)))) - (when (or (not (get-buffer folder)) - (y-or-n-p (format "Reuse buffer displaying %s? " folder))) - (mh-visit-folder - folder (loop for x being the hash-keys of (gethash folder mh-index-data) - when (mh-msg-exists-p x folder) collect x))))) - -;;;###mh-autoload -(defun mh-search-p () - "Non-nil means that this folder was generated by searching." - mh-index-data) - -;;;###mh-autoload -(defun mh-index-execute-commands () - "Delete/refile the actual messages. -The copies in the searched folder are then deleted/refiled to get -the desired result. Before deleting the messages we make sure -that the message being deleted is identical to the one that the -user has marked in the index buffer." - (save-excursion - (let ((folders ()) - (mh-speed-flists-inhibit-flag t)) - (maphash - (lambda (folder msgs) - (push folder folders) - (if (not (get-buffer folder)) - ;; If source folder not open, just delete the messages... - (apply #'mh-exec-cmd "rmm" folder (mh-coalesce-msg-list msgs)) - ;; Otherwise delete the messages in the source buffer... - (save-excursion - (set-buffer folder) - (let ((old-refile-list mh-refile-list) - (old-delete-list mh-delete-list)) - (setq mh-refile-list nil - mh-delete-list msgs) - (unwind-protect (mh-execute-commands) - (setq mh-refile-list - (mapcar (lambda (x) - (cons (car x) - (loop for y in (cdr x) - unless (memq y msgs) collect y))) - old-refile-list) - mh-delete-list - (loop for x in old-delete-list - unless (memq x msgs) collect x)) - (mh-set-folder-modified-p (mh-outstanding-commands-p)) - (when (mh-outstanding-commands-p) - (mh-notate-deleted-and-refiled))))))) - (mh-index-matching-source-msgs (append (loop for x in mh-refile-list - append (cdr x)) - mh-delete-list) - t)) - folders))) - - - -;;; Indexing functions +;;; Indexing Functions ;; Support different search programs (defvar mh-search-choices @@ -930,14 +824,13 @@ optional argument SEARCHER is present, use it instead of (return mh-searcher)))) nil))) -;;; Swish++ interface +;;; Swish++ (defvar mh-swish++-binary (or (executable-find "search++") (executable-find "search"))) (defvar mh-swish++-directory ".swish++") (defvar mh-swish-folder nil) -;;;###mh-autoload (defun mh-swish++-execute-search (folder-path search-regexp) "Execute swish++. @@ -1012,12 +905,11 @@ REGEXP-LIST is an alist of fields and values." (symbol-name (car expr)) (mh-swish++-print-regexp (caddr expr)))))) -;;; Swish interface +;;; Swish (defvar mh-swish-binary (executable-find "swish-e")) (defvar mh-swish-directory ".swish") -;;;###mh-autoload (defun mh-swish-execute-search (folder-path search-regexp) "Execute swish-e. @@ -1110,13 +1002,12 @@ is used to search." nil))) (forward-line))) -;;; Mairix interface +;;; Mairix (defvar mh-mairix-binary (executable-find "mairix")) (defvar mh-mairix-directory ".mairix") (defvar mh-mairix-folder nil) -;;;###mh-autoload (defun mh-mairix-execute-search (folder-path search-regexp-list) "Execute mairix. @@ -1244,13 +1135,12 @@ REGEXP-LIST is an alist of fields and values." (cdadr expr))))) (t (error "Unreachable: %s" expr)))) -;;; Namazu interface +;;; Namazu (defvar mh-namazu-binary (executable-find "namazu")) (defvar mh-namazu-directory ".namazu") (defvar mh-namazu-folder nil) -;;;###mh-autoload (defun mh-namazu-execute-search (folder-path search-regexp) "Execute namazu. @@ -1317,14 +1207,13 @@ is used to search." nil)))) (forward-line))) -;;; Pick interface +;;; Pick (defvar mh-index-pick-folder) (defvar mh-pick-binary "pick") (defconst mh-pick-single-dash '(cc date from subject to) "Search components that are supported by single-dash option in pick.") -;;;###mh-autoload (defun mh-pick-execute-search (folder-path search-regexp) "Execute pick. @@ -1408,11 +1297,10 @@ COMPONENT is the component to search." "-rbrace")) (t (error "Unknown operator %s seen" (car expr))))) -;;; Grep interface +;;; Grep (defvar mh-grep-binary (executable-find "grep")) -;;;###mh-autoload (defun mh-grep-execute-search (folder-path search-regexp) "Execute grep. @@ -1463,7 +1351,132 @@ record is invalid return 'error." -;;; Folder support +;;; Folder Utilities + +;;;###mh-autoload +(defun mh-index-group-by-folder () + "Partition the messages based on source folder. +Returns an alist with the the folder names in the car and the cdr +being the list of messages originally from that folder." + (save-excursion + (goto-char (point-min)) + (let ((result-table (make-hash-table :test #'equal))) + (loop for msg being hash-keys of mh-index-msg-checksum-map + do (push msg (gethash (car (gethash + (gethash msg mh-index-msg-checksum-map) + mh-index-checksum-origin-map)) + result-table))) + (loop for x being the hash-keys of result-table + collect (cons x (nreverse (gethash x result-table))))))) + +;;;###mh-autoload +(defun mh-index-insert-folder-headers () + "Annotate the search results with original folder names." + (let ((cur-msg (mh-get-msg-num nil)) + (old-buffer-modified-flag (buffer-modified-p)) + (buffer-read-only nil) + current-folder last-folder) + (goto-char (point-min)) + (while (not (eobp)) + (setq current-folder (car (gethash (gethash (mh-get-msg-num nil) + mh-index-msg-checksum-map) + mh-index-checksum-origin-map))) + (when (and current-folder (not (equal current-folder last-folder))) + (insert (if last-folder "\n" "") current-folder "\n") + (setq last-folder current-folder)) + (forward-line)) + (when cur-msg + (mh-notate-cur) + (mh-goto-msg cur-msg t)) + (set-buffer-modified-p old-buffer-modified-flag)) + (mh-index-create-imenu-index)) + +;;;###mh-autoload +(defun mh-index-delete-folder-headers () + "Delete the folder headers." + (let ((cur-msg (mh-get-msg-num nil)) + (old-buffer-modified-flag (buffer-modified-p)) + (buffer-read-only nil)) + (while (and (not cur-msg) (not (eobp))) + (forward-line) + (setq cur-msg (mh-get-msg-num nil))) + (goto-char (point-min)) + (while (not (eobp)) + (if (or (char-equal (char-after) ?+) (char-equal (char-after) 10)) + (delete-region (point) (progn (forward-line) (point))) + (forward-line))) + (when cur-msg (mh-goto-msg cur-msg t t)) + (set-buffer-modified-p old-buffer-modified-flag))) + +;; Shush compiler. +(eval-when-compile (mh-do-in-xemacs (defvar which-func-mode))) + +;;;###mh-autoload +(defun mh-index-create-imenu-index () + "Create alist of folder names and positions in index folder buffers." + (save-excursion + (if (boundp 'which-func-mode) + (setq which-func-mode t)) + (let ((alist ())) + (goto-char (point-min)) + (while (re-search-forward "^+" nil t) + (save-excursion + (beginning-of-line) + (push (cons (buffer-substring-no-properties + (point) (line-end-position)) + (set-marker (make-marker) (point))) + alist))) + (setq imenu--index-alist (nreverse alist))))) + +;;;###mh-autoload +(defun mh-search-p () + "Non-nil means that this folder was generated by searching." + mh-index-data) + +;; Shush compiler +(eval-when-compile (if mh-xemacs-flag (defvar mh-speed-flists-inhibit-flag))) + +;;;###mh-autoload +(defun mh-index-execute-commands () + "Delete/refile the actual messages. +The copies in the searched folder are then deleted/refiled to get +the desired result. Before deleting the messages we make sure +that the message being deleted is identical to the one that the +user has marked in the index buffer." + (save-excursion + (let ((folders ()) + (mh-speed-flists-inhibit-flag t)) + (maphash + (lambda (folder msgs) + (push folder folders) + (if (not (get-buffer folder)) + ;; If source folder not open, just delete the messages... + (apply #'mh-exec-cmd "rmm" folder (mh-coalesce-msg-list msgs)) + ;; Otherwise delete the messages in the source buffer... + (save-excursion + (set-buffer folder) + (let ((old-refile-list mh-refile-list) + (old-delete-list mh-delete-list)) + (setq mh-refile-list nil + mh-delete-list msgs) + (unwind-protect (mh-execute-commands) + (setq mh-refile-list + (mapcar (lambda (x) + (cons (car x) + (loop for y in (cdr x) + unless (memq y msgs) collect y))) + old-refile-list) + mh-delete-list + (loop for x in old-delete-list + unless (memq x msgs) collect x)) + (mh-set-folder-modified-p (mh-outstanding-commands-p)) + (when (mh-outstanding-commands-p) + (mh-notate-deleted-and-refiled))))))) + (mh-index-matching-source-msgs (append (loop for x in mh-refile-list + append (cdr x)) + mh-delete-list) + t)) + folders))) (defun mh-index-generate-pretty-name (string) "Given STRING generate a name which is suitable for use as a folder name. @@ -1559,7 +1572,7 @@ garbled." -;;; Sequence support +;;; Sequence Support ;;;###mh-autoload (defun mh-index-create-sequences () @@ -1688,7 +1701,7 @@ folder, is removed from `mh-index-data'." -;;; Serialization of index data +;;; Serialization of Index Data (defun mh-index-write-data () "Write index data to file." @@ -1756,20 +1769,21 @@ PROC is used to convert the value to actual data." -;;; Checksum routines +;;; Checksum Routines + +;; A few different checksum programs are supported. The supported +;; programs are: -;; A few different checksum programs are supported. The supported programs -;; are: -;; ;; 1. md5sum ;; 2. md5 ;; 3. openssl -;; -;; To add support for your favorite checksum program add a clause to the cond -;; statement in mh-checksum-choose. This should set the variable -;; mh-checksum-cmd to the command line needed to run the checsum program and -;; should set mh-checksum-parser to a function which returns a cons cell -;; containing the message number and checksum string. + +;; To add support for your favorite checksum program add a clause to +;; the cond statement in mh-checksum-choose. This should set the +;; variable mh-checksum-cmd to the command line needed to run the +;; checsum program and should set mh-checksum-parser to a function +;; which returns a cons cell containing the message number and +;; checksum string. (defvar mh-checksum-cmd) (defvar mh-checksum-parser) diff --git a/lisp/mh-e/mh-seq.el b/lisp/mh-e/mh-seq.el index 842289ae635..cf2027392bd 100644 --- a/lisp/mh-e/mh-seq.el +++ b/lisp/mh-e/mh-seq.el @@ -26,128 +26,89 @@ ;; Boston, MA 02110-1301, 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 identifiers in -;; In-Reply-To: header. Right now it just assumes that the last text -;; between angles (< and >) is the message identifier. There is the -;; chance that this will incorrectly use an email address like a -;; message identifier. -;; -;; (3) Error checking of found message identifiers 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 identifier and subject strings. -;; - -;; Internal support for MH-E package. + +;; Sequences are stored in the alist `mh-seq-list' in the form: +;; ((seq-name msgs ...) (seq-name msgs ...) ...) ;;; Change Log: ;;; Code: -;;(message "> mh-seq") -(eval-when-compile (require 'mh-acros)) +(require 'mh-e) (mh-require-cl) +(require 'mh-scan) -(require 'mh-buffers) -(require 'mh-e) -;;(message "< mh-seq") +(require 'font-lock) - +;;; Variables + +(defvar mh-last-seq-used nil + "Name of seq to which a msg was last added.") -;;; Data structures (used in message threading)... +(defvar mh-non-seq-mode-line-annotation nil + "Saved value of `mh-mode-line-annotation' when narrowed to a seq.") +(make-variable-buffer-local 'mh-non-seq-mode-line-annotation) + +(defvar mh-internal-seqs '(answered cur deleted forwarded printed)) -(mh-defstruct (mh-thread-message (:conc-name mh-message-) - (:constructor mh-thread-make-message)) - (id nil) - (references ()) - (subject "") - (subject-re-p nil)) +;;; Macros -(mh-defstruct (mh-thread-container (:conc-name mh-container-) - (:constructor mh-thread-make-container)) - message parent children - (real-child-p t)) +(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)) -;;; Internal variables: +;;; MH-Folder Commands -(defvar mh-last-seq-used nil - "Name of seq to which a msg was last added.") +;; Alphabetical. -(defvar mh-non-seq-mode-line-annotation nil - "Saved value of `mh-mode-line-annotation' when narrowed to a seq.") +;;;###mh-autoload +(defun mh-catchup (range) + "Delete RANGE from the \"unseen\" sequence. - +Check the documentation of `mh-interactive-range' to see how +RANGE is read in interactive use." + (interactive (list (mh-interactive-range "Catchup" + (cons (point-min) (point-max))))) + (mh-delete-msg-from-seq range mh-unseen-seq)) + +;;;###mh-autoload +(defun mh-delete-msg-from-seq (range sequence &optional internal-flag) + "Delete RANGE from SEQUENCE. + +Check the documentation of `mh-interactive-range' to see how +RANGE is read in interactive use. -;;; Maps and hashes... - -(defvar mh-thread-id-hash nil - "Hashtable used to canonicalize message identifiers.") -(defvar mh-thread-subject-hash nil - "Hashtable used to canonicalize subject strings.") -(defvar mh-thread-id-table nil - "Thread ID table maps from message identifiers to message containers.") -(defvar mh-thread-id-index-map nil - "Table to look up message index number from message identifier.") -(defvar mh-thread-index-id-map nil - "Table to look up message identifier from message index.") -(defvar mh-thread-scan-line-map nil - "Map of message index to various parts of the scan line.") -(defvar mh-thread-scan-line-map-stack 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 associate messages with the same message identifier.") -(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-scan-line-map-stack) -(make-variable-buffer-local 'mh-thread-subject-container-hash) -(make-variable-buffer-local 'mh-thread-duplicates) -(make-variable-buffer-local 'mh-thread-history) +In a program, non-nil INTERNAL-FLAG means do not inform MH of the +change." + (interactive (list (mh-interactive-range "Delete") + (mh-read-seq-default "Delete from" t) + nil)) + (let ((entry (mh-find-seq sequence)) + (user-sequence-flag (not (mh-internal-seq sequence))) + (folders-changed (list mh-current-folder)) + (msg-list ())) + (when entry + (mh-iterate-on-range msg range + (push msg msg-list) + ;; Calling "mark" repeatedly takes too long. So we will pretend here + ;; that we are just modifying an internal sequence... + (when (memq msg (cdr entry)) + (mh-remove-sequence-notation msg (not user-sequence-flag))) + (mh-delete-a-msg-from-seq msg sequence t)) + ;; ... and here we will "mark" all the messages at one go. + (unless internal-flag (mh-undefine-sequence sequence msg-list)) + (when (and mh-index-data (not internal-flag)) + (setq folders-changed + (append folders-changed + (mh-index-delete-from-sequence sequence msg-list)))) + (when (and (eq sequence mh-unseen-seq) (mh-speed-flists-active-p)) + (apply #'mh-speed-flists t folders-changed))))) ;;;###mh-autoload (defun mh-delete-seq (sequence) @@ -240,12 +201,8 @@ MESSAGE appears." (mh-list-to-string (mh-seq-containing-msg message t)) " ")))) -;; Shush compiler -(eval-when-compile - (defvar tool-bar-map) - (defvar tool-bar-mode)) - -(make-variable-buffer-local 'mh-non-seq-mode-line-annotation) +;; Shush compiler. +(eval-when-compile (mh-do-in-xemacs (defvar tool-bar-mode))) ;;;###mh-autoload (defun mh-narrow-to-seq (sequence) @@ -290,6 +247,23 @@ When you want to widen the view to all your messages again, use (error "No messages in sequence %s" (symbol-name sequence)))))) ;;;###mh-autoload +(defun mh-narrow-to-tick () + "Limit to ticked messages. + +What this command does is show only those messages that are in +the \"tick\" sequence (which you can customize via the +`mh-tick-seq' option) in the MH-Folder buffer. In addition, it +limits further MH-E searches to just those messages. When you +want to widen the view to all your messages again, use +\\[mh-widen]." + (interactive) + (cond ((not mh-tick-seq) + (error "Enable ticking by customizing `mh-tick-seq'")) + ((null (mh-seq-msgs (mh-find-seq mh-tick-seq))) + (message "No messages in %s sequence" mh-tick-seq)) + (t (mh-narrow-to-seq mh-tick-seq)))) + +;;;###mh-autoload (defun mh-put-msg-in-seq (range sequence) "Add RANGE to SEQUENCE\\<mh-folder-mode-map>. @@ -319,12 +293,39 @@ use." (when (and (eq sequence mh-unseen-seq) (mh-speed-flists-active-p)) (apply #'mh-speed-flists t folders)))) -(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))) +;;;###mh-autoload +(defun mh-toggle-tick (range) + "Toggle tick mark of RANGE. + +This command adds messages to the \"tick\" sequence (which you can customize +via the option `mh-tick-seq'). This sequence can be viewed later with the +\\[mh-index-ticked-messages] command. + +Check the documentation of `mh-interactive-range' to see how RANGE is read in +interactive use." + (interactive (list (mh-interactive-range "Tick"))) + (unless mh-tick-seq + (error "Enable ticking by customizing `mh-tick-seq'")) + (let* ((tick-seq (mh-find-seq mh-tick-seq)) + (tick-seq-msgs (mh-seq-msgs tick-seq)) + (ticked ()) + (unticked ())) + (mh-iterate-on-range msg range + (cond ((member msg tick-seq-msgs) + (push msg unticked) + (setcdr tick-seq (delq msg (cdr tick-seq))) + (when (null (cdr tick-seq)) (setq mh-last-seq-used nil)) + (mh-remove-sequence-notation msg (mh-colors-in-use-p))) + (t + (push msg ticked) + (setq mh-last-seq-used mh-tick-seq) + (let ((mh-seq-list (cons `(,mh-tick-seq ,msg) mh-seq-list))) + (mh-add-sequence-notation msg (mh-colors-in-use-p)))))) + (mh-add-msgs-to-seq ticked mh-tick-seq nil t) + (mh-undefine-sequence mh-tick-seq unticked) + (when mh-index-data + (mh-index-add-to-sequence mh-tick-seq ticked) + (mh-index-delete-from-sequence mh-tick-seq unticked)))) ;;;###mh-autoload (defun mh-widen (&optional all-flag) @@ -374,32 +375,9 @@ remove all limits and sequence restrictions." (set-buffer (get-buffer mh-show-buffer)) (set (make-local-variable 'tool-bar-map) mh-show-tool-bar-map))))) -;; FIXME? We may want to clear all notations and add one for current-message -;; and process user sequences. -;;;###mh-autoload -(defun mh-notate-deleted-and-refiled () - "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'." - (let ((refiled-hash (make-hash-table)) - (deleted-hash (make-hash-table))) - (dolist (msg mh-delete-list) - (setf (gethash msg deleted-hash) t)) - (dolist (dest-msg-list mh-refile-list) - (dolist (msg (cdr dest-msg-list)) - (setf (gethash msg refiled-hash) t))) - (mh-iterate-on-messages-in-region msg (point-min) (point-max) - (cond ((gethash msg refiled-hash) - (mh-notate nil mh-note-refiled mh-cmd-note)) - ((gethash msg deleted-hash) - (mh-notate nil mh-note-deleted mh-cmd-note)))))) - -;;; Commands to manipulate sequences. - -;; Sequences are stored in an alist of the form: -;; ((seq-name msgs ...) (seq-name msgs ...) ...) +;;; Support Routines (defvar mh-sequence-history ()) @@ -433,38 +411,192 @@ containing the current message." (error "No messages in sequence %s" seq)) seq)) +(defun mh-internal-seq (name) + "Return non-nil if NAME is the name of an internal MH-E sequence." + (or (memq name mh-internal-seqs) + (eq name mh-unseen-seq) + (and (mh-colors-in-use-p) mh-tick-seq (eq name mh-tick-seq)) + (eq name mh-previous-seq) + (mh-folder-name-p name))) + +;;;###mh-autoload +(defun mh-valid-seq-p (name) + "Return non-nil if NAME is a valid MH sequence name." + (and (symbolp name) + (string-match "^[a-zA-Z][a-zA-Z0-9]*$" (symbol-name name)))) + +;;;###mh-autoload +(defun mh-find-seq (name) + "Return sequence NAME." + (assoc name mh-seq-list)) + +;;;###mh-autoload +(defun mh-seq-to-msgs (seq) + "Return a list of the messages in SEQ." + (mh-seq-msgs (mh-find-seq seq))) + +(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-flag + (not (mh-internal-seq (mh-seq-name (car l))))) + (setq seqs (cons (mh-seq-name (car l)) seqs))) + (setq l (cdr l))) + seqs)) + +;;;###mh-autoload +(defun mh-define-sequence (seq msgs) + "Define the SEQ to contain the list of MSGS. +Do not mark pseudo-sequences or empty sequences. +Signals an error if SEQ is an invalid name." + (if (and msgs + (mh-valid-seq-p seq) + (not (mh-folder-name-p seq))) + (save-excursion + (mh-exec-cmd-error nil "mark" mh-current-folder "-add" "-zero" + "-sequence" (symbol-name seq) + (mh-coalesce-msg-list msgs))))) + +;;;###mh-autoload +(defun mh-undefine-sequence (seq msgs) + "Remove from the SEQ the list of MSGS." + (when (and (mh-valid-seq-p seq) msgs) + (apply #'mh-exec-cmd "mark" mh-current-folder "-delete" + "-sequence" (symbol-name seq) (mh-coalesce-msg-list msgs)))) + +;;;###mh-autoload +(defun mh-add-msgs-to-seq (msgs seq &optional internal-flag dont-annotate-flag) + "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. + +If DONT-ANNOTATE-FLAG is non-nil then the annotations in the +folder buffer are not updated." + (let ((entry (mh-find-seq seq)) + (internal-seq-flag (mh-internal-seq seq))) + (if (and msgs (atom msgs)) (setq msgs (list msgs))) + (if (null 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)))))) + (unless internal-flag + (mh-add-to-sequence seq msgs) + (when (not dont-annotate-flag) + (mh-iterate-on-range msg msgs + (unless (memq msg (cdr entry)) + (mh-add-sequence-notation msg internal-seq-flag))))))) + +(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 (and (mh-valid-seq-p seq) (not (mh-folder-name-p seq))) + (if msgs + (apply 'mh-exec-cmd "mark" mh-current-folder "-add" + "-sequence" (symbol-name seq) + (mh-coalesce-msg-list msgs))))) + +(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-delete-a-msg-from-seq (msg sequence internal-flag) + "Delete MSG from SEQUENCE. +If INTERNAL-FLAG is non-nil, then do not inform MH of the +change." + (let ((entry (mh-find-seq sequence))) + (when (and entry (memq msg (mh-seq-msgs entry))) + (if (not internal-flag) + (mh-undefine-sequence sequence (list msg))) + (setcdr entry (delq msg (mh-seq-msgs entry)))))) + +(defun mh-delete-seq-locally (seq) + "Remove MH-E's record of SEQ." + (let ((entry (mh-find-seq seq))) + (setq mh-seq-list (delq entry mh-seq-list)))) + +(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) + (cond ((memq 'unthread mh-view-ops) + ;; Populate restricted scan-line map + (mh-remove-all-notation) + (mh-iterate-on-range msg (cons (point-min) (point-max)) + (setf (gethash msg mh-thread-scan-line-map) + (mh-thread-parse-scan-line))) + ;; Remove scan lines and read results from pre-computed tree + (delete-region (point-min) (point-max)) + (mh-thread-print-scan-lines + (mh-thread-generate mh-current-folder ())) + (mh-notate-user-sequences)) + (mh-index-data + (mh-index-insert-folder-headers))))))) + +;;;###mh-autoload +(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))) + -;;; Functions to read ranges with completion... +;;; Ranges (defvar mh-range-seq-names) (defvar mh-range-history ()) (defvar mh-range-completion-map (copy-keymap minibuffer-local-completion-map)) (define-key mh-range-completion-map " " 'self-insert-command) -(defun mh-range-completion-function (string predicate flag) - "Programmable completion of message ranges. -STRING is the user input that is to be completed. PREDICATE if non-nil is a -function used to filter the possible choices and FLAG determines whether the -completion is over." - (let* ((candidates mh-range-seq-names) - (last-char (and (not (equal string "")) - (aref string (1- (length string))))) - (last-word (cond ((null last-char) "") - ((memq last-char '(? ?- ?:)) "") - (t (car (last (split-string string "[ -:]+")))))) - (prefix (substring string 0 (- (length string) (length last-word))))) - (cond ((eq flag nil) - (let ((res (try-completion last-word candidates predicate))) - (cond ((null res) nil) - ((eq res t) t) - (t (concat prefix res))))) - ((eq flag t) - (all-completions last-word candidates predicate)) - ((eq flag 'lambda) - (loop for x in candidates - when (equal x last-word) return t - finally return nil))))) +;;;###mh-autoload +(defun mh-interactive-range (range-prompt &optional default) + "Return interactive specification for message, sequence, range or region. +By convention, the name of this argument is RANGE. + +If variable `transient-mark-mode' is non-nil and the mark is active, +then this function returns a cons-cell of the region. + +If optional prefix argument is provided, then prompt for message range +with RANGE-PROMPT. A list of messages in that range is returned. + +If a MH range is given, say something like last:20, then a list +containing the messages in that range is returned. + +If DEFAULT non-nil then it is returned. + +Otherwise, the message number at point is returned. + +This function is usually used with `mh-iterate-on-range' in order to +provide a uniform interface to MH-E functions." + (cond ((mh-mark-active-p t) (cons (region-beginning) (region-end))) + (current-prefix-arg (mh-read-range range-prompt nil nil t t)) + (default default) + (t (mh-get-msg-num t)))) ;;;###mh-autoload (defun mh-read-range (prompt &optional folder default @@ -550,6 +682,17 @@ should be replaced with: (t (error "No messages in range %s" input))))) ;;;###mh-autoload +(defun mh-range-to-msg-list (range) + "Return a list of messages for RANGE. + +Check the documentation of `mh-interactive-range' to see how +RANGE is read in interactive use." + (let (msg-list) + (mh-iterate-on-range msg range + (push msg msg-list)) + (nreverse msg-list))) + +;;;###mh-autoload (defun mh-translate-range (folder expr) "In FOLDER, translate the string EXPR to a list of messages numbers." (save-excursion @@ -563,23 +706,177 @@ should be replaced with: (push (string-to-number (match-string 1)) result)) (nreverse result))))) +(defun mh-range-completion-function (string predicate flag) + "Programmable completion of message ranges. +STRING is the user input that is to be completed. PREDICATE if non-nil is a +function used to filter the possible choices and FLAG determines whether the +completion is over." + (let* ((candidates mh-range-seq-names) + (last-char (and (not (equal string "")) + (aref string (1- (length string))))) + (last-word (cond ((null last-char) "") + ((memq last-char '(? ?- ?:)) "") + (t (car (last (split-string string "[ -:]+")))))) + (prefix (substring string 0 (- (length string) (length last-word))))) + (cond ((eq flag nil) + (let ((res (try-completion last-word candidates predicate))) + (cond ((null res) nil) + ((eq res t) t) + (t (concat prefix res))))) + ((eq flag t) + (all-completions last-word candidates predicate)) + ((eq flag 'lambda) + (loop for x in candidates + when (equal x last-word) return t + finally return nil))))) + (defun mh-seq-names (seq-list) "Return an alist containing the names of the SEQ-LIST." (mapcar (lambda (entry) (list (symbol-name (mh-seq-name entry)))) seq-list)) +(defun mh-folder-size (folder) + "Find size of FOLDER." + (if mh-flists-present-flag + (mh-folder-size-flist folder) + (mh-folder-size-folder folder))) + +(defun mh-folder-size-flist (folder) + "Find size of FOLDER using \"flist\"." + (with-temp-buffer + (call-process (expand-file-name "flist" mh-progs) nil t nil "-showzero" + "-norecurse" folder "-sequence" (symbol-name mh-unseen-seq)) + (goto-char (point-min)) + (multiple-value-bind (folder unseen total) + (mh-parse-flist-output-line + (buffer-substring (point) (line-end-position))) + (values total unseen folder)))) + +(defun mh-folder-size-folder (folder) + "Find size of FOLDER using \"folder\"." + (with-temp-buffer + (let ((u (length (cdr (assoc mh-unseen-seq + (mh-read-folder-sequences folder nil)))))) + (call-process (expand-file-name "folder" mh-progs) nil t nil + "-norecurse" folder) + (goto-char (point-min)) + (if (re-search-forward " has \\([0-9]+\\) " nil t) + (values (string-to-number (match-string 1)) u folder) + (values 0 u folder))))) + ;;;###mh-autoload -(defun mh-rename-seq (sequence new-name) - "Rename SEQUENCE to have NEW-NAME." - (interactive (list (mh-read-seq "Old" t) - (intern (read-string "New sequence name: ")))) - (let ((old-seq (mh-find-seq sequence))) - (or old-seq - (error "Sequence %s does not exist" sequence)) - ;; create new sequence first, since it might raise an error. - (mh-define-sequence new-name (mh-seq-msgs old-seq)) - (mh-undefine-sequence sequence (mh-seq-msgs old-seq)) - (rplaca old-seq new-name))) +(defun mh-parse-flist-output-line (line &optional current-folder) + "Parse LINE to generate folder name, unseen messages and total messages. +If CURRENT-FOLDER is non-nil then it contains the current folder +name and it is used to avoid problems in corner cases involving +folders whose names end with a '+' character." + (with-temp-buffer + (insert line) + (goto-char (point-max)) + (let (folder unseen total p) + (when (search-backward " out of " (point-min) t) + (setq total (string-to-number + (buffer-substring-no-properties + (match-end 0) (line-end-position)))) + (when (search-backward " in sequence " (point-min) t) + (setq p (point)) + (when (search-backward " has " (point-min) t) + (setq unseen (string-to-number (buffer-substring-no-properties + (match-end 0) p))) + (while (eq (char-after) ? ) + (backward-char)) + (setq folder (buffer-substring-no-properties + (point-min) (1+ (point)))) + (when (and (equal (aref folder (1- (length folder))) ?+) + (equal current-folder folder)) + (setq folder (substring folder 0 (1- (length folder))))) + (values (format "+%s" folder) unseen total))))))) + +;;;###mh-autoload +(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." + (let ((seqs ())) + (cond (save-refiles + (mh-mapc (function (lambda (seq) ; Save the refiling sequences + (if (mh-folder-name-p (mh-seq-name seq)) + (setq seqs (cons seq seqs))))) + mh-seq-list))) + (save-excursion + (if (eq 0 (mh-exec-cmd-quiet nil "mark" folder "-list")) + (progn + ;; look for name in line of form "cur: 4" or "myseq (private): 23" + (while (re-search-forward "^[^: ]+" nil t) + (setq seqs (cons (mh-make-seq (intern (buffer-substring + (match-beginning 0) + (match-end 0))) + (mh-read-msg-list)) + seqs))) + (delete-region (point-min) (point))))) ; avoid race with + ; mh-process-daemon + seqs)) + +(defun mh-read-msg-list () + "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) + (while (re-search-forward "[0-9]+" end-of-line t) + (setq num (string-to-number (buffer-substring (match-beginning 0) + (match-end 0)))) + (cond ((looking-at "-") ; Message range + (forward-char 1) + (re-search-forward "[0-9]+" end-of-line t) + (let ((num2 (string-to-number + (buffer-substring (match-beginning 0) + (match-end 0))))) + (if (< num2 num) + (error "Bad message range: %d-%d" num num2)) + (while (<= num num2) + (setq msgs (cons num msgs)) + (setq num (1+ num))))) + ((not (zerop num)) ;"pick" outputs "0" to mean no match + (setq msgs (cons num msgs))))) + msgs)) + + + +;;; Notation + +;;;###mh-autoload +(defun mh-notate (msg notation offset) + "Mark MSG with the character NOTATION at position OFFSET. +Null MSG means the message at cursor. +If NOTATION is nil then no change in the buffer occurs." + (save-excursion + (if (or (null msg) + (mh-goto-msg msg t t)) + (with-mh-folder-updating (t) + (beginning-of-line) + (forward-char offset) + (let* ((change-stack-flag + (and (equal offset + (+ mh-cmd-note mh-scan-field-destination-offset)) + (not (eq notation mh-note-seq)))) + (msg (and change-stack-flag (or msg (mh-get-msg-num nil)))) + (stack (and msg (gethash msg mh-sequence-notation-history))) + (notation (or notation (char-after)))) + (if stack + ;; The presence of the stack tells us that we don't need to + ;; notate the message, since the notation would be replaced + ;; by a sequence notation. So we will just put the notation + ;; at the bottom of the stack. If the sequence is deleted, + ;; the correct notation will be shown. + (setf (gethash msg mh-sequence-notation-history) + (reverse (cons notation (cdr (reverse stack))))) + ;; Since we don't have any sequence notations in the way, just + ;; notate the scan line. + (delete-char 1) + (insert notation)) + (when change-stack-flag + (mh-thread-update-scan-line-map msg notation offset))))))) ;;;###mh-autoload (defun mh-notate-cur () @@ -596,1207 +893,124 @@ fringe." (setq overlay-arrow-position mh-arrow-marker)))) ;;;###mh-autoload -(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 (and (mh-valid-seq-p seq) (not (mh-folder-name-p seq))) - (if msgs - (apply 'mh-exec-cmd "mark" mh-current-folder "-add" - "-sequence" (symbol-name seq) - (mh-coalesce-msg-list msgs))))) - -(defvar mh-thread-last-ancestor) - -(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) - (cond ((memq 'unthread mh-view-ops) - ;; Populate restricted scan-line map - (mh-remove-all-notation) - (mh-iterate-on-range msg (cons (point-min) (point-max)) - (setf (gethash msg mh-thread-scan-line-map) - (mh-thread-parse-scan-line))) - ;; Remove scan lines and read results from pre-computed tree - (delete-region (point-min) (point-max)) - (mh-thread-print-scan-lines - (mh-thread-generate mh-current-folder ())) - (mh-notate-user-sequences)) - (mh-index-data - (mh-index-insert-folder-headers))))))) - -;;;###mh-autoload -(defmacro mh-iterate-on-messages-in-region (var begin end &rest body) - "Iterate over region. - -VAR is bound to the message on the current line as we loop -starting from BEGIN till END. In each step BODY is executed. - -If VAR is nil then the loop is executed without any binding." - (unless (symbolp var) - (error "Can not bind the non-symbol %s" var)) - (let ((binding-needed-flag var)) - `(save-excursion - (goto-char ,begin) - (beginning-of-line) - (while (and (<= (point) ,end) (not (eobp))) - (when (looking-at mh-scan-valid-regexp) - (let ,(if binding-needed-flag `((,var (mh-get-msg-num t))) ()) - ,@body)) - (forward-line 1))))) - -(put 'mh-iterate-on-messages-in-region 'lisp-indent-hook 'defun) +(defun mh-remove-cur-notation () + "Remove old cur notation." + (let ((cur-msg (car (mh-seq-to-msgs 'cur)))) + (save-excursion + (when (and cur-msg + (mh-goto-msg cur-msg t t) + (looking-at mh-scan-cur-msg-number-regexp)) + (mh-notate nil ? mh-cmd-note) + (setq overlay-arrow-position nil))))) +;; FIXME? We may want to clear all notations and add one for current-message +;; and process user sequences. ;;;###mh-autoload -(defmacro mh-iterate-on-range (var range &rest body) - "Iterate an operation over a region or sequence. - -VAR is bound to each message in turn in a loop over RANGE, which -can be a message number, a list of message numbers, a sequence, a -region in a cons cell, or a MH range (something like last:20) in -a string. In each iteration, BODY is executed. - -The parameter RANGE is usually created with -`mh-interactive-range' in order to provide a uniform interface to -MH-E functions." - (unless (symbolp var) - (error "Can not bind the non-symbol %s" var)) - (let ((binding-needed-flag var) - (msgs (make-symbol "msgs")) - (seq-hash-table (make-symbol "seq-hash-table"))) - `(cond ((numberp ,range) - (when (mh-goto-msg ,range t t) - (let ,(if binding-needed-flag `((,var ,range)) ()) - ,@body))) - ((and (consp ,range) - (numberp (car ,range)) (numberp (cdr ,range))) - (mh-iterate-on-messages-in-region ,var - (car ,range) (cdr ,range) - ,@body)) - (t (let ((,msgs (cond ((and ,range (symbolp ,range)) - (mh-seq-to-msgs ,range)) - ((stringp ,range) - (mh-translate-range mh-current-folder - ,range)) - (t ,range))) - (,seq-hash-table (make-hash-table))) - (dolist (msg ,msgs) - (setf (gethash msg ,seq-hash-table) t)) - (mh-iterate-on-messages-in-region v (point-min) (point-max) - (when (gethash v ,seq-hash-table) - (let ,(if binding-needed-flag `((,var v)) ()) - ,@body)))))))) - -(put 'mh-iterate-on-range 'lisp-indent-hook 'defun) +(defun mh-notate-deleted-and-refiled () + "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'." + (let ((refiled-hash (make-hash-table)) + (deleted-hash (make-hash-table))) + (dolist (msg mh-delete-list) + (setf (gethash msg deleted-hash) t)) + (dolist (dest-msg-list mh-refile-list) + (dolist (msg (cdr dest-msg-list)) + (setf (gethash msg refiled-hash) t))) + (mh-iterate-on-messages-in-region msg (point-min) (point-max) + (cond ((gethash msg refiled-hash) + (mh-notate nil mh-note-refiled mh-cmd-note)) + ((gethash msg deleted-hash) + (mh-notate nil mh-note-deleted mh-cmd-note)))))) ;;;###mh-autoload -(defun mh-range-to-msg-list (range) - "Return a list of messages for RANGE. +(defun mh-notate-user-sequences (&optional range) + "Mark user-defined sequences in RANGE. Check the documentation of `mh-interactive-range' to see how -RANGE is read in interactive use." - (let (msg-list) +RANGE is read in interactive use; if nil all messages are +notated." + (unless range + (setq range (cons (point-min) (point-max)))) + (let ((seqs mh-seq-list) + (msg-hash (make-hash-table))) + (dolist (seq seqs) + (dolist (msg (mh-seq-msgs seq)) + (push (car seq) (gethash msg msg-hash)))) (mh-iterate-on-range msg range - (push msg msg-list)) - (nreverse msg-list))) - -;;;###mh-autoload -(defun mh-interactive-range (range-prompt &optional default) - "Return interactive specification for message, sequence, range or region. -By convention, the name of this argument is RANGE. - -If variable `transient-mark-mode' is non-nil and the mark is active, -then this function returns a cons-cell of the region. - -If optional prefix argument is provided, then prompt for message range -with RANGE-PROMPT. A list of messages in that range is returned. - -If a MH range is given, say something like last:20, then a list -containing the messages in that range is returned. - -If DEFAULT non-nil then it is returned. - -Otherwise, the message number at point is returned. - -This function is usually used with `mh-iterate-on-range' in order to -provide a uniform interface to MH-E functions." - (cond ((mh-mark-active-p t) (cons (region-beginning) (region-end))) - (current-prefix-arg (mh-read-range range-prompt nil nil t t)) - (default default) - (t (mh-get-msg-num t)))) - - - -;;; Commands to handle new 'subject sequence ("Poor man's threading" by psg) - -;; XXX: The function mh-subject-to-sequence-unthreaded uses the magic number -;; 41 for the max size of the subject part. Avoiding this would be desirable. -(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." - (if (memq 'unthread mh-view-ops) - (mh-subject-to-sequence-threaded all) - (mh-subject-to-sequence-unthreaded all))) - -(defun mh-subject-to-sequence-unthreaded (all) - "Put all following messages with same subject in sequence 'subject. - -This function only works with an unthreaded folder. 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." - (if (not (eq major-mode 'mh-folder-mode)) - (error "Not in a folder buffer")) - (save-excursion - (beginning-of-line) - (if (or (not (looking-at mh-scan-subject-regexp)) - (not (match-string 3)) - (string-equal "" (match-string 3))) - (progn (message "No subject line") - nil) - (let ((subject (match-string-no-properties 3)) - (list)) - (if (> (length subject) 41) - (setq subject (substring subject 0 41))) - (save-excursion - (if all - (goto-char (point-min))) - (while (re-search-forward mh-scan-subject-regexp nil t) - (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) - (setq list (cons (mh-get-msg-num t) list)))))) - (cond - (list - ;; 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))) - (if (assoc 'subject mh-seq-list) (mh-delete-seq 'subject)) - ;; sort the result into a sequence - (let ((sorted-list (sort (copy-sequence list) 'mh-lessp))) - (while sorted-list - (mh-add-msgs-to-seq (car sorted-list) 'subject nil) - (setq sorted-list (cdr sorted-list))) - (safe-length list))) - (t - 0)))))) - -(defun mh-subject-to-sequence-threaded (all) - "Put all messages with the same subject in the 'subject sequence. - -This function works when the folder is threaded. In this -situation the subject could get truncated and so the normal -matching doesn't work. - -The parameter ALL is non-nil then all the messages in the buffer -are considered, otherwise only the messages after the current one -are taken into account." - (let* ((cur (mh-get-msg-num nil)) - (subject (mh-thread-find-msg-subject cur)) - region msgs) - (if (null subject) - (and (message "No subject line") nil) - (setq region (cons (if all (point-min) (point)) (point-max))) - (mh-iterate-on-range msg region - (when (eq (mh-thread-find-msg-subject msg) subject) - (push msg msgs))) - (setq msgs (sort msgs #'mh-lessp)) - (if (null msgs) - 0 - (when (assoc 'subject mh-seq-list) - (mh-delete-seq 'subject)) - (mh-add-msgs-to-seq msgs 'subject) - (length msgs))))) - -(defun mh-thread-find-msg-subject (msg) - "Find canonicalized subject of MSG. -This function can only be used the folder is threaded." - (ignore-errors - (mh-message-subject - (mh-container-message (gethash (gethash msg mh-thread-index-id-map) - mh-thread-id-table))))) - -(defun mh-edit-pick-expr (default) - "With prefix arg edit a pick expression. -If no prefix arg is given, then return DEFAULT." - (let ((default-string (loop for x in default concat (format " %s" x)))) - (if (or current-prefix-arg (equal default-string "")) - (mh-pick-args-list (read-string "Pick expression: " - default-string)) - default))) - -(defun mh-pick-args-list (s) - "Form list by grouping elements in string S suitable for pick arguments. -For example, the string \"-subject a b c -from Joe User -<user@domain.com>\" is converted to (\"-subject\" \"a b c\" -\"-from\" \"Joe User <user@domain.com>\"" - (let ((full-list (split-string s)) - current-arg collection arg-list) - (while full-list - (setq current-arg (car full-list)) - (if (null (string-match "^-" current-arg)) - (setq collection - (if (null collection) - current-arg - (format "%s %s" collection current-arg))) - (when collection - (setq arg-list (append arg-list (list collection))) - (setq collection nil)) - (setq arg-list (append arg-list (list current-arg)))) - (setq full-list (cdr full-list))) - (when collection - (setq arg-list (append arg-list (list collection)))) - arg-list)) - -;;;###mh-autoload -(defun mh-narrow-to-subject (&optional pick-expr) - "Limit to messages with same subject. -With a prefix argument, edit PICK-EXPR. - -Use \\<mh-folder-mode-map>\\[mh-widen] to undo this command." - (interactive - (list (mh-edit-pick-expr (mh-current-message-header-field 'subject)))) - (mh-narrow-to-header-field 'subject pick-expr)) - -;;;###mh-autoload -(defun mh-narrow-to-from (&optional pick-expr) - "Limit to messages with the same \"From:\" field. -With a prefix argument, edit PICK-EXPR. - -Use \\<mh-folder-mode-map>\\[mh-widen] to undo this command." - (interactive - (list (mh-edit-pick-expr (mh-current-message-header-field 'from)))) - (mh-narrow-to-header-field 'from pick-expr)) - -;;;###mh-autoload -(defun mh-narrow-to-cc (&optional pick-expr) - "Limit to messages with the same \"Cc:\" field. -With a prefix argument, edit PICK-EXPR. - -Use \\<mh-folder-mode-map>\\[mh-widen] to undo this command." - (interactive - (list (mh-edit-pick-expr (mh-current-message-header-field 'cc)))) - (mh-narrow-to-header-field 'cc pick-expr)) - -;;;###mh-autoload -(defun mh-narrow-to-to (&optional pick-expr) - "Limit to messages with the same \"To:\" field. -With a prefix argument, edit PICK-EXPR. - -Use \\<mh-folder-mode-map>\\[mh-widen] to undo this command." - (interactive - (list (mh-edit-pick-expr (mh-current-message-header-field 'to)))) - (mh-narrow-to-header-field 'to pick-expr)) - -(defun mh-narrow-to-header-field (header-field pick-expr) - "Limit to messages whose HEADER-FIELD match PICK-EXPR. -The MH command pick is used to do the match." - (let ((folder mh-current-folder) - (original (mh-coalesce-msg-list - (mh-range-to-msg-list (cons (point-min) (point-max))))) - (msg-list ())) - (with-temp-buffer - (apply #'mh-exec-cmd-output "pick" nil folder - (append original (list "-list") pick-expr)) - (goto-char (point-min)) - (while (not (eobp)) - (let ((num (ignore-errors - (string-to-number - (buffer-substring (point) (line-end-position)))))) - (when num (push num msg-list)) - (forward-line)))) - (if (null msg-list) - (message "No matches") - (when (assoc 'header mh-seq-list) (mh-delete-seq 'header)) - (mh-add-msgs-to-seq msg-list 'header) - (mh-narrow-to-seq 'header)))) - -(defun mh-current-message-header-field (header-field) - "Return a pick regexp to match HEADER-FIELD of the message at point." - (let ((num (mh-get-msg-num nil))) - (when num - (let ((folder mh-current-folder)) - (with-temp-buffer - (insert-file-contents-literally (mh-msg-filename num folder)) - (goto-char (point-min)) - (when (search-forward "\n\n" nil t) - (narrow-to-region (point-min) (point))) - (let* ((field (or (message-fetch-field (format "%s" header-field)) - "")) - (field-option (format "-%s" header-field)) - (patterns (loop for x in (split-string field "[ ]*,[ ]*") - unless (equal x "") - collect (if (string-match "<\\(.*@.*\\)>" x) - (match-string 1 x) - x)))) - (when patterns - (loop with accum = `(,field-option ,(car patterns)) - for e in (cdr patterns) - do (setq accum `(,field-option ,e "-or" ,@accum)) - finally return accum)))))))) - -;;;###mh-autoload -(defun mh-narrow-to-range (range) - "Limit to RANGE. - -Check the documentation of `mh-interactive-range' to see how -RANGE is read in interactive use. - -Use \\<mh-folder-mode-map>\\[mh-widen] to undo this command." - (interactive (list (mh-interactive-range "Narrow to"))) - (when (assoc 'range mh-seq-list) (mh-delete-seq 'range)) - (mh-add-msgs-to-seq (mh-range-to-msg-list range) 'range) - (mh-narrow-to-seq 'range)) - - -;;;###mh-autoload -(defun mh-delete-subject () - "Delete messages with same subject\\<mh-folder-mode-map>. - -To delete messages faster, you can use this command to delete all -the messages with the same subject as the current message. This -command puts these messages in a sequence named \"subject\". You -can undo this action by using \\[mh-undo] with a prefix argument -and then specifying the \"subject\" sequence." - (interactive) - (let ((count (mh-subject-to-sequence nil))) - (cond - ((not count) ; No subject line, delete msg anyway - (mh-delete-msg (mh-get-msg-num t))) - ((= 0 count) ; No other msgs, delete msg anyway. - (message "No other messages with same Subject following this one") - (mh-delete-msg (mh-get-msg-num t))) - (t ; We have a subject sequence. - (message "Marked %d messages for deletion" count) - (mh-delete-msg 'subject))))) - -;;;###mh-autoload -(defun mh-delete-subject-or-thread () - "Delete messages with same subject or thread\\<mh-folder-mode-map>. - -To delete messages faster, you can use this command to delete all -the messages with the same subject as the current message. This -command puts these messages in a sequence named \"subject\". You -can undo this action by using \\[mh-undo] with a prefix argument -and then specifying the \"subject\" sequence. - -However, if the buffer is displaying a threaded view of the -folder then this command behaves like \\[mh-thread-delete]." - (interactive) - (if (memq 'unthread mh-view-ops) - (mh-thread-delete) - (mh-delete-subject))) - - - -;;; Message threading: - -(defmacro mh-thread-initialize-hash (var test) - "Initialize the hash table in VAR. -TEST is the test to use when creating a new hash table." - (unless (symbolp var) (error "Expected a symbol: %s" var)) - `(if ,var (clrhash ,var) (setq ,var (make-hash-table :test ,test)))) - -(defun mh-thread-initialize () - "Make new hash tables, or clear them if already present." - (mh-thread-initialize-hash mh-thread-id-hash #'equal) - (mh-thread-initialize-hash mh-thread-subject-hash #'equal) - (mh-thread-initialize-hash mh-thread-id-table #'eq) - (mh-thread-initialize-hash mh-thread-id-index-map #'eq) - (mh-thread-initialize-hash mh-thread-index-id-map #'eql) - (mh-thread-initialize-hash mh-thread-scan-line-map #'eql) - (mh-thread-initialize-hash mh-thread-subject-container-hash #'eq) - (mh-thread-initialize-hash mh-thread-duplicates #'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) - (loop for elem in (mh-container-children parent-container) - unless (eq child-container elem) collect elem)) - (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 :id id :references refs - :subject subject - :subject-re-p subject-re-p))) - (t (let ((message (mh-thread-make-message :id id :references refs - :subject-re-p subject-re-p - :subject subject))) - (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))) - -(defun 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 (mh-search-from-end ?> reply-to-header))) - (when (numberp end) - (let ((begin (mh-search-from-end ?< (substring reply-to-header 0 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... - -(defvar mh-message-id-regexp "^<.*@.*>$" - "Regexp to recognize whether a string is a message identifier.") - -(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." - (with-temp-buffer - (mh-thread-set-tables folder) - (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" - folder (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 (string-to-number 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 (loop for x in (append (split-string refs) in-reply-to) - when (string-match mh-message-id-regexp x) - collect x)) - (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)))))) - -;;;###mh-autoload -(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) - (mh-remove-all-notation) - (goto-char start-point) - (let ((msg-list ())) - (while (not (eobp)) - (let ((index (mh-get-msg-num nil))) - (when (numberp index) - (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)) - (mh-thread-print-scan-lines thread-tree) - (mh-notate-user-sequences) - (mh-notate-deleted-and-refiled) - (mh-notate-cur) - (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) - (force-angle-flag nil) - (increment-level-flag nil)) - (dolist (scan-line (mapcar (lambda (x) - (gethash x mh-thread-scan-line-map)) - (reverse (cons index duplicates)))) - (when scan-line - (when (and dupl-flag (equal level 0) - (mh-thread-ancestor-p mh-thread-last-ancestor tree)) - (setq level (+ level 2) - new-level (+ new-level 2) - force-angle-flag t)) - (when (equal level 0) - (setq mh-thread-last-ancestor tree) - (while (mh-container-parent mh-thread-last-ancestor) - (setq mh-thread-last-ancestor - (mh-container-parent mh-thread-last-ancestor)))) - (let* ((lev (if dupl-flag level new-level)) - (square-flag (or (and (mh-container-real-child-p tree) - (not force-angle-flag) - dupl-flag) - (equal lev 0)))) - (insert (car scan-line) - (format (format "%%%ss" lev) "") - (if square-flag "[" "<") - (cadr scan-line) - (if square-flag "]" ">") - (truncate-string-to-width - (caddr scan-line) (- mh-thread-body-width lev)) - "\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)))) - (address-start (+ mh-cmd-note mh-scan-field-from-start-offset)) - (body-start (+ mh-cmd-note mh-scan-field-from-end-offset)) - (first-string (substring string 0 address-start))) - (list first-string - (substring string address-start (- body-start 2)) - (substring string body-start) - string))) - -;;;###mh-autoload -(defun mh-thread-update-scan-line-map (msg notation offset) - "In threaded view update `mh-thread-scan-line-map'. -MSG is the message being notated with NOTATION at OFFSET." - (let* ((msg (or msg (mh-get-msg-num nil))) - (cur-scan-line (and mh-thread-scan-line-map - (gethash msg mh-thread-scan-line-map))) - (old-scan-lines (loop for map in mh-thread-scan-line-map-stack - collect (and map (gethash msg map))))) - (when cur-scan-line - (setf (aref (car cur-scan-line) offset) notation)) - (dolist (line old-scan-lines) - (when line (setf (aref (car line) offset) notation))))) + (loop for seq in (gethash msg msg-hash) + do (mh-add-sequence-notation msg (mh-internal-seq seq)))))) -;;;###mh-autoload -(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)))) - (when (numberp msg-num) - (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-print-scan-lines (thread-tree) - "Print scan lines in THREAD-TREE in threaded mode." - (let ((mh-thread-body-width (- (window-width) mh-cmd-note - (1- mh-scan-field-subject-start-offset))) - (mh-thread-last-ancestor nil)) - (if (null mh-index-data) - (mh-thread-generate-scan-lines thread-tree -2) - (loop for x in (mh-index-group-by-folder) - do (let* ((old-map mh-thread-scan-line-map) - (mh-thread-scan-line-map (make-hash-table))) - (setq mh-thread-last-ancestor nil) - (loop for msg in (cdr x) - do (let ((v (gethash msg old-map))) - (when v - (setf (gethash msg mh-thread-scan-line-map) v)))) - (when (> (hash-table-count mh-thread-scan-line-map) 0) - (insert (if (bobp) "" "\n") (car x) "\n") - (mh-thread-generate-scan-lines thread-tree -2)))) - (mh-index-create-imenu-index)))) - -(defun mh-thread-folder () - "Generate thread view of folder." - (message "Threading %s..." (buffer-name)) - (mh-thread-initialize) - (goto-char (point-min)) - (mh-remove-all-notation) - (let ((msg-list ())) - (mh-iterate-on-range msg (cons (point-min) (point-max)) - (setf (gethash msg mh-thread-scan-line-map) (mh-thread-parse-scan-line)) - (push msg msg-list)) - (let* ((range (mh-coalesce-msg-list msg-list)) - (thread-tree (mh-thread-generate (buffer-name) range))) - (delete-region (point-min) (point-max)) - (mh-thread-print-scan-lines thread-tree) - (mh-notate-user-sequences) - (mh-notate-deleted-and-refiled) - (mh-notate-cur) - (message "Threading %s...done" (buffer-name))))) - -;;;###mh-autoload -(defun mh-toggle-threads () - "Toggle threaded view of folder." - (interactive) - (let ((msg-at-point (mh-get-msg-num nil)) - (old-buffer-modified-flag (buffer-modified-p)) - (buffer-read-only nil)) - (cond ((memq 'unthread mh-view-ops) - (unless (mh-valid-view-change-operation-p 'unthread) - (error "Can't unthread folder")) - (let ((msg-list ())) - (goto-char (point-min)) - (while (not (eobp)) - (let ((index (mh-get-msg-num nil))) - (when index - (push index msg-list))) - (forward-line)) - (mh-scan-folder mh-current-folder - (mapcar #'(lambda (x) (format "%s" x)) - (mh-coalesce-msg-list msg-list)) - t)) - (when mh-index-data - (mh-index-insert-folder-headers) - (mh-notate-cur))) - (t (mh-thread-folder) - (push 'unthread mh-view-ops))) - (when msg-at-point (mh-goto-msg msg-at-point t t)) - (set-buffer-modified-p old-buffer-modified-flag) - (mh-recenter nil))) - -;;;###mh-autoload -(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) - (remhash index mh-thread-scan-line-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)))))) - - - -;;; Operations on threads - -(defun mh-thread-current-indentation-level () - "Find the number of spaces by which current message is indented." - (save-excursion - (let ((address-start-offset (+ mh-cmd-note mh-scan-date-flag-width - mh-scan-date-width 1)) - (level 0)) +(defun mh-add-sequence-notation (msg internal-seq-flag) + "Add sequence notation to the MSG on the current line. +If INTERNAL-SEQ-FLAG is non-nil, then refontify the scan line if +font-lock is turned on." + (with-mh-folder-updating (t) + (save-excursion (beginning-of-line) - (forward-char address-start-offset) - (while (char-equal (char-after) ? ) - (incf level) - (forward-char)) - level))) - -;;;###mh-autoload -(defun mh-thread-next-sibling (&optional previous-flag) - "Display next sibling. - -With non-nil optional argument PREVIOUS-FLAG jump to the previous -sibling." - (interactive) - (cond ((not (memq 'unthread mh-view-ops)) - (error "Folder isn't threaded")) - ((eobp) - (error "No message at point"))) - (beginning-of-line) - (let ((point (point)) - (done nil) - (my-level (mh-thread-current-indentation-level))) - (while (and (not done) - (equal (forward-line (if previous-flag -1 1)) 0) - (not (eobp))) - (let ((level (mh-thread-current-indentation-level))) - (cond ((equal level my-level) - (setq done 'success)) - ((< level my-level) - (message "No %s sibling" (if previous-flag "previous" "next")) - (setq done 'failure))))) - (cond ((eq done 'success) (mh-maybe-show)) - ((eq done 'failure) (goto-char point)) - (t (message "No %s sibling" (if previous-flag "previous" "next")) - (goto-char point))))) - -;;;###mh-autoload -(defun mh-thread-previous-sibling () - "Display previous sibling." - (interactive) - (mh-thread-next-sibling t)) - -(defun mh-thread-immediate-ancestor () - "Jump to immediate ancestor in thread tree." - (beginning-of-line) - (let ((point (point)) - (ancestor-level (- (mh-thread-current-indentation-level) 2)) - (done nil)) - (if (< ancestor-level 0) - nil - (while (and (not done) (equal (forward-line -1) 0)) - (when (equal ancestor-level (mh-thread-current-indentation-level)) - (setq done t))) - (unless done - (goto-char point)) - done))) - -;;;###mh-autoload -(defun mh-thread-ancestor (&optional thread-root-flag) - "Display ancestor of current message. - -If you do not care for the way a particular thread has turned, -you can move up the chain of messages with this command. This -command can also take a prefix argument THREAD-ROOT-FLAG to jump -to the message that started everything." - (interactive "P") - (beginning-of-line) - (cond ((not (memq 'unthread mh-view-ops)) - (error "Folder isn't threaded")) - ((eobp) - (error "No message at point"))) - (let ((current-level (mh-thread-current-indentation-level))) - (cond (thread-root-flag - (while (mh-thread-immediate-ancestor)) - (mh-maybe-show)) - ((equal current-level 1) - (message "Message has no ancestor")) - (t (mh-thread-immediate-ancestor) - (mh-maybe-show))))) - -(defun mh-thread-find-children () - "Return a region containing the current message and its children. -The result is returned as a list of two elements. The first is -the point at the start of the region and the second is the point -at the end." - (beginning-of-line) - (if (eobp) - nil - (let ((address-start-offset (+ mh-cmd-note mh-scan-date-flag-width - mh-scan-date-width 1)) - (level (mh-thread-current-indentation-level)) - spaces begin) - (setq begin (point)) - (setq spaces (format (format "%%%ss" (1+ level)) "")) - (forward-line) - (block nil - (while (not (eobp)) - (forward-char address-start-offset) - (unless (equal (string-match spaces (buffer-substring-no-properties - (point) (line-end-position))) - 0) + (if internal-seq-flag + (progn + ;; Change the buffer so that if transient-mark-mode is active + ;; and there is an active region it will get deactivated as in + ;; the case of user sequences. + (mh-notate nil nil mh-cmd-note) + (when font-lock-mode + (font-lock-fontify-region (point) (line-end-position)))) + (forward-char (+ mh-cmd-note mh-scan-field-destination-offset)) + (let ((stack (gethash msg mh-sequence-notation-history))) + (setf (gethash msg mh-sequence-notation-history) + (cons (char-after) stack))) + (mh-notate nil mh-note-seq + (+ mh-cmd-note mh-scan-field-destination-offset)))))) + +(defun mh-remove-sequence-notation (msg internal-seq-flag &optional all) + "Remove sequence notation from the MSG on the current line. +If INTERNAL-SEQ-FLAG is non-nil, then `font-lock' was used to +highlight the sequence. In that case, no notation needs to be removed. +Otherwise the effect of inserting `mh-note-seq' needs to be reversed. +If ALL is non-nil, then all sequence marks on the scan line are +removed." + (with-mh-folder-updating (t) + ;; This takes care of internal sequences... + (mh-notate nil nil mh-cmd-note) + (unless internal-seq-flag + ;; ... and this takes care of user sequences. + (let ((stack (gethash msg mh-sequence-notation-history))) + (while (and all (cdr stack)) + (setq stack (cdr stack))) + (when stack + (save-excursion (beginning-of-line) - (backward-char) - (return)) - (forward-line))) - (list begin (point))))) + (forward-char (+ mh-cmd-note mh-scan-field-destination-offset)) + (delete-char 1) + (insert (car stack)))) + (setf (gethash msg mh-sequence-notation-history) (cdr stack)))))) ;;;###mh-autoload -(defun mh-thread-delete () - "Delete thread." - (interactive) - (cond ((not (memq 'unthread mh-view-ops)) - (error "Folder isn't threaded")) - ((eobp) - (error "No message at point")) - (t (let ((region (mh-thread-find-children))) - (mh-iterate-on-messages-in-region () (car region) (cadr region) - (mh-delete-a-msg nil)) - (mh-next-msg))))) - -;;;###mh-autoload -(defun mh-thread-refile (folder) - "Refile (output) thread into FOLDER." - (interactive (list (intern (mh-prompt-for-refile-folder)))) - (cond ((not (memq 'unthread mh-view-ops)) - (error "Folder isn't threaded")) - ((eobp) - (error "No message at point")) - (t (let ((region (mh-thread-find-children))) - (mh-iterate-on-messages-in-region () (car region) (cadr region) - (mh-refile-a-msg nil folder)) - (mh-next-msg))))) +(defun mh-remove-all-notation () + "Remove all notations on all scan lines that MH-E introduces." + (save-excursion + (setq overlay-arrow-position nil) + (goto-char (point-min)) + (mh-iterate-on-range msg (cons (point-min) (point-max)) + (mh-notate nil ? mh-cmd-note) + (mh-remove-sequence-notation msg nil t)) + (clrhash mh-sequence-notation-history))) -;; Tick mark handling - -;;;###mh-autoload -(defun mh-toggle-tick (range) - "Toggle tick mark of RANGE. - -This command adds messages to the \"tick\" sequence (which you can customize -via the option `mh-tick-seq'). This sequence can be viewed later with the -\\[mh-index-ticked-messages] command. - -Check the documentation of `mh-interactive-range' to see how RANGE is read in -interactive use." - (interactive (list (mh-interactive-range "Tick"))) - (unless mh-tick-seq - (error "Enable ticking by customizing `mh-tick-seq'")) - (let* ((tick-seq (mh-find-seq mh-tick-seq)) - (tick-seq-msgs (mh-seq-msgs tick-seq)) - (ticked ()) - (unticked ())) - (mh-iterate-on-range msg range - (cond ((member msg tick-seq-msgs) - (push msg unticked) - (setcdr tick-seq (delq msg (cdr tick-seq))) - (when (null (cdr tick-seq)) (setq mh-last-seq-used nil)) - (mh-remove-sequence-notation msg (mh-colors-in-use-p))) - (t - (push msg ticked) - (setq mh-last-seq-used mh-tick-seq) - (let ((mh-seq-list (cons `(,mh-tick-seq ,msg) mh-seq-list))) - (mh-add-sequence-notation msg (mh-colors-in-use-p)))))) - (mh-add-msgs-to-seq ticked mh-tick-seq nil t) - (mh-undefine-sequence mh-tick-seq unticked) - (when mh-index-data - (mh-index-add-to-sequence mh-tick-seq ticked) - (mh-index-delete-from-sequence mh-tick-seq unticked)))) - -;;;###mh-autoload -(defun mh-narrow-to-tick () - "Limit to ticked messages. - -What this command does is show only those messages that are in -the \"tick\" sequence (which you can customize via the -`mh-tick-seq' option) in the MH-Folder buffer. In addition, it -limits further MH-E searches to just those messages. When you -want to widen the view to all your messages again, use -\\[mh-widen]." - (interactive) - (cond ((not mh-tick-seq) - (error "Enable ticking by customizing `mh-tick-seq'")) - ((null (mh-seq-msgs (mh-find-seq mh-tick-seq))) - (message "No messages in %s sequence" mh-tick-seq)) - (t (mh-narrow-to-seq mh-tick-seq)))) +;; XXX Unused, delete, or create bind key? +(defun mh-rename-seq (sequence new-name) + "Rename SEQUENCE to have NEW-NAME." + (interactive (list (mh-read-seq "Old" t) + (intern (read-string "New sequence name: ")))) + (let ((old-seq (mh-find-seq sequence))) + (or old-seq + (error "Sequence %s does not exist" sequence)) + ;; Create new sequence first, since it might raise an error. + (mh-define-sequence new-name (mh-seq-msgs old-seq)) + (mh-undefine-sequence sequence (mh-seq-msgs old-seq)) + (rplaca old-seq new-name))) (provide 'mh-seq) diff --git a/lisp/mh-e/mh-show.el b/lisp/mh-e/mh-show.el new file mode 100644 index 00000000000..9e16af2bff9 --- /dev/null +++ b/lisp/mh-e/mh-show.el @@ -0,0 +1,906 @@ +;;; mh-show.el --- MH-Show mode + +;; Copyright (C) 1993, 1995, 1997, +;; 2000, 2001, 2002, 2003, 2004, 2005, 2006 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., 51 Franklin Street, Fifth Floor, +;; Boston, MA 02110-1301, USA. + +;;; Commentary: + +;; Mode for showing messages. + +;;; Change Log: + +;;; Code: + +(require 'mh-e) +(require 'mh-scan) + +(require 'gnus-cite) +(require 'gnus-util) + +(autoload 'mh-make-buffer-data "mh-mime") ;can't be automatically generated + +(require 'font-lock) + + + +;;; MH-Folder Commands + +(defvar mh-showing-with-headers nil + "If non-nil, MH-Show buffer contains message with all header fields. +If nil, MH-Show buffer contains message processed normally.") + +;;;###mh-autoload +(defun mh-show (&optional message redisplay-flag) + "Display message\\<mh-folder-mode-map>. + +If the message under the cursor is already displayed, this command +scrolls to the beginning of the message. MH-E normally hides a lot of +the superfluous header fields that mailers add to a message, but if +you wish to see all of them, use the command \\[mh-header-display]. + +Two hooks can be used to control how messages are displayed. The +first hook, `mh-show-mode-hook', is called early on in the +process of the message display. It is usually used to perform +some action on the message's content. The second hook, +`mh-show-hook', is the last thing called after messages are +displayed. It's used to affect the behavior of MH-E in general or +when `mh-show-mode-hook' is too early. + +From a program, optional argument MESSAGE can be used to display an +alternative message. The optional argument REDISPLAY-FLAG forces the +redisplay of the message even if the show buffer was already +displaying the correct message. + +See the \"mh-show\" customization group for a litany of options that +control what displayed messages look like." + (interactive (list nil t)) + (when (or redisplay-flag + (and mh-showing-with-headers + (or mh-mhl-format-file mh-clean-message-header-flag))) + (mh-invalidate-show-buffer)) + (mh-show-msg message)) + +;;;###mh-autoload +(defun mh-header-display () + "Display message with all header fields\\<mh-folder-mode-map>. + +Use the command \\[mh-show] to show the message normally again." + (interactive) + (and (not mh-showing-with-headers) + (or mh-mhl-format-file mh-clean-message-header-flag) + (mh-invalidate-show-buffer)) + (let ((mh-decode-mime-flag nil) + (mh-mhl-format-file 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))) + + + +;;; Support Routines for MH-Folder Commands + +;;;###mh-autoload +(defun mh-maybe-show (&optional msg) + "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-msg (msg) + "Show MSG. + +The hook `mh-show-hook' is called 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-flag nil) + (let ((folder mh-current-folder) + (folders (list mh-current-folder)) + (clean-message-header mh-clean-message-header-flag) + (show-window (get-buffer-window mh-show-buffer)) + (display-mime-buttons-flag mh-display-buttons-for-inline-parts-flag)) + (if (not (eq (next-window (minibuffer-window)) (selected-window))) + (delete-other-windows)) ; force ourself to the top window + (mh-in-show-buffer (mh-show-buffer) + (setq mh-display-buttons-for-inline-parts-flag display-mime-buttons-flag) + (if (and show-window + (equal (mh-msg-filename msg folder) buffer-file-name)) + (progn ;just back up to start + (goto-char (point-min)) + (if (not clean-message-header) + (mh-start-of-uncleaned-message))) + (mh-display-msg msg folder))) + (if (not (= (1+ (window-height)) (frame-height))) ;not horizontally split + (shrink-window (- (window-height) (or mh-summary-height + (mh-summary-height))))) + (mh-recenter nil) + ;; The following line is a nop which forces update of the scan line so + ;; that font-lock will update it (if needed)... + (mh-notate nil nil mh-cmd-note) + (if (not (memq msg mh-seen-list)) + (setq mh-seen-list (cons msg mh-seen-list))) + (when mh-update-sequences-after-mh-show-flag + (mh-update-sequences) + (when mh-index-data + (setq folders + (append (mh-index-delete-from-sequence mh-unseen-seq (list msg)) + folders))) + (when (mh-speed-flists-active-p) + (apply #'mh-speed-flists t folders))) + (run-hooks 'mh-show-hook))) + +;;;###mh-autoload +(defun mh-showing-mode (&optional arg) + "Change whether messages should be displayed. + +With ARG, display messages iff ARG is positive." + (setq mh-showing-mode + (if (null arg) + (not mh-showing-mode) + (> (prefix-numeric-value arg) 0)))) + +;;;###mh-autoload +(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))) + +(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.") + +;;;###mh-autoload +(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 mh-mhl-format-file) + (clean-message-header mh-clean-message-header-flag) + (invisible-headers mh-invisible-header-fields-compiled) + (visible-headers nil) + (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) + ;; Cleanup old mime handles + (mh-mime-cleanup) + (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-literally msg-filename)) + ;; 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)) + (mh-show-mode) + ;; 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))) + (mh-decode-message-header) + ;; 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) + (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))) + (mh-logo-display) + (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) + +;;;###mh-autoload +(defun mh-clean-msg-header (start invisible-headers visible-headers) + "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." + ;; XXX Note that MH-E no longer supports the `mh-visible-headers' + ;; variable, so this function could be trimmed of this feature too." + (let ((case-fold-search t) + (buffer-read-only nil)) + (save-restriction + (goto-char start) + (if (search-forward "\n\n" nil 'move) + (backward-char 1)) + (narrow-to-region start (point)) + (goto-char (point-min)) + (if visible-headers + (while (< (point) (point-max)) + (cond ((looking-at visible-headers) + (forward-line 1) + (while (looking-at "[ \t]") (forward-line 1))) + (t + (mh-delete-line 1) + (while (looking-at "[ \t]") + (mh-delete-line 1))))) + (while (re-search-forward invisible-headers nil t) + (beginning-of-line) + (mh-delete-line 1) + (while (looking-at "[ \t]") + (mh-delete-line 1))))) + (let ((mh-compose-skipped-header-fields ())) + (mh-letter-hide-all-skipped-fields)) + (unlock-buffer))) + +;;;###mh-autoload +(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-summary-height () + "Return ideal value for the variable `mh-summary-height'. +The current frame height is taken into consideration." + (or (and (fboundp 'frame-height) + (> (frame-height) 24) + (min 10 (/ (frame-height) 6))) + 4)) + + + +;; 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) + (mh-funcall-if-exists deactivate-mark) + (unwind-protect + (prog1 (call-interactively (function ,original-function)) + (setq normal-exit t)) + (mh-funcall-if-exists deactivate-mark) + (when (eq major-mode 'mh-folder-mode) + (mh-funcall-if-exists hl-line-highlight)) + (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-or-thread + mh-delete-subject-or-thread) +(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-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-narrow-to-from mh-narrow-to-from) +(mh-defun-show-buffer mh-show-narrow-to-cc mh-narrow-to-cc) +(mh-defun-show-buffer mh-show-narrow-to-range mh-narrow-to-range) +(mh-defun-show-buffer mh-show-narrow-to-to mh-narrow-to-to) +(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-thread-delete mh-thread-delete) +(mh-defun-show-buffer mh-show-thread-refile mh-thread-refile) +(mh-defun-show-buffer mh-show-update-sequences mh-update-sequences) +(mh-defun-show-buffer mh-show-next-unread-msg mh-next-unread-msg) +(mh-defun-show-buffer mh-show-previous-unread-msg mh-previous-unread-msg) +(mh-defun-show-buffer mh-show-thread-ancestor mh-thread-ancestor) +(mh-defun-show-buffer mh-show-thread-next-sibling mh-thread-next-sibling) +(mh-defun-show-buffer mh-show-thread-previous-sibling + mh-thread-previous-sibling) +(mh-defun-show-buffer mh-show-index-visit-folder mh-index-visit-folder t) +(mh-defun-show-buffer mh-show-toggle-tick mh-toggle-tick) +(mh-defun-show-buffer mh-show-narrow-to-tick mh-narrow-to-tick) +(mh-defun-show-buffer mh-show-junk-blacklist mh-junk-blacklist) +(mh-defun-show-buffer mh-show-junk-whitelist mh-junk-whitelist) +(mh-defun-show-buffer mh-show-index-new-messages mh-index-new-messages) +(mh-defun-show-buffer mh-show-index-ticked-messages mh-index-ticked-messages) +(mh-defun-show-buffer mh-show-index-sequenced-messages + mh-index-sequenced-messages) +(mh-defun-show-buffer mh-show-catchup mh-catchup) +(mh-defun-show-buffer mh-show-ps-print-toggle-color mh-ps-print-toggle-color) +(mh-defun-show-buffer mh-show-ps-print-toggle-faces mh-ps-print-toggle-faces) +(mh-defun-show-buffer mh-show-ps-print-msg-file mh-ps-print-msg-file) +(mh-defun-show-buffer mh-show-ps-print-msg mh-ps-print-msg) +(mh-defun-show-buffer mh-show-toggle-mime-buttons mh-toggle-mime-buttons) +(mh-defun-show-buffer mh-show-display-with-external-viewer + mh-display-with-external-viewer) + + + +;;; Sequence Menu + +(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] + ["Narrow to Tick Sequence" mh-show-narrow-to-tick + (save-excursion + (set-buffer mh-show-folder-buffer) + (and mh-tick-seq (mh-seq-msgs (mh-find-seq mh-tick-seq))))] + ["Delete Rest of Same Subject" mh-show-delete-subject t] + ["Toggle Tick Mark" mh-show-toggle-tick t] + "--" + ["Push State Out to MH" mh-show-update-sequences t])) + +;;; Message Menu + +(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])) + +;;; Folder Menu + +(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] + ["View New Messages" mh-show-index-new-messages t] + ["Search..." mh-search t] + "--" + ["Quit MH-E" mh-quit t])) + + + +;;; MH-Show Keys + +(gnus-define-keys mh-show-mode-map + " " mh-show-page-msg + "!" mh-show-refile-or-write-again + "'" mh-show-toggle-tick + "," 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-or-thread + "m" mh-show-send + "n" mh-show-next-undeleted-msg + "\M-n" mh-show-next-unread-msg + "o" mh-show-refile-msg + "p" mh-show-previous-undeleted-msg + "\M-p" mh-show-previous-unread-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 + "v" mh-show-index-visit-folder + "|" mh-show-pipe-msg) + +(gnus-define-keys (mh-show-folder-map "F" mh-show-mode-map) + "?" mh-prefix-help + "'" mh-index-ticked-messages + "S" mh-show-sort-folder + "c" mh-show-catchup + "f" mh-show-visit-folder + "k" mh-show-kill-folder + "l" mh-show-list-folders + "n" mh-index-new-messages + "o" mh-show-visit-folder + "q" mh-show-index-sequenced-messages + "r" mh-show-rescan-folder + "s" mh-search + "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-show-narrow-to-tick + "?" 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) + +(define-key mh-show-mode-map "I" mh-inc-spool-map) + +(gnus-define-keys (mh-show-junk-map "J" mh-show-mode-map) + "?" mh-prefix-help + "b" mh-show-junk-blacklist + "w" mh-show-junk-whitelist) + +(gnus-define-keys (mh-show-ps-print-map "P" mh-show-mode-map) + "?" mh-prefix-help + "C" mh-show-ps-print-toggle-color + "F" mh-show-ps-print-toggle-faces + "f" mh-show-ps-print-msg-file + "l" mh-show-print-msg + "p" mh-show-ps-print-msg) + +(gnus-define-keys (mh-show-thread-map "T" mh-show-mode-map) + "?" mh-prefix-help + "u" mh-show-thread-ancestor + "p" mh-show-thread-previous-sibling + "n" mh-show-thread-next-sibling + "t" mh-show-toggle-threads + "d" mh-show-thread-delete + "o" mh-show-thread-refile) + +(gnus-define-keys (mh-show-limit-map "/" mh-show-mode-map) + "'" mh-show-narrow-to-tick + "?" mh-prefix-help + "c" mh-show-narrow-to-cc + "g" mh-show-narrow-to-range + "m" mh-show-narrow-to-from + "s" mh-show-narrow-to-subject + "t" mh-show-narrow-to-to + "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) + +(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 + "e" mh-show-display-with-external-viewer + "v" mh-show-toggle-mime-part + "o" mh-show-save-mime-part + "i" mh-show-inline-mime-part + "t" mh-show-toggle-mime-buttons + "\t" mh-show-next-button + [backtab] mh-show-prev-button + "\M-\t" mh-show-prev-button) + + + +;;; MH-Show Font Lock + +(defun mh-header-field-font-lock (field limit) + "Return the value of a header field FIELD to font-lock. +Argument LIMIT limits search." + (if (= (point) limit) + nil + (let* ((mail-header-end (mh-mail-header-end)) + (lesser-limit (if (< mail-header-end limit) mail-header-end limit)) + (case-fold-search t)) + (when (and (< (point) mail-header-end) ;Only within header + (re-search-forward (format "^%s" field) lesser-limit t)) + (let ((match-one-b (match-beginning 0)) + (match-one-e (match-end 0))) + (mh-header-field-end) + (if (> (point) limit) ;Don't search for end beyond limit + (goto-char limit)) + (set-match-data (list match-one-b match-one-e + (1+ match-one-e) (point))) + 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)) + +(defun mh-letter-header-font-lock (limit) + "Return the entire mail header to font-lock. +Argument LIMIT limits search." + (if (= (point) limit) + nil + (let* ((mail-header-end (save-match-data (mh-mail-header-end))) + (lesser-limit (if (< mail-header-end limit) mail-header-end limit))) + (when (mh-in-header-p) + (set-match-data (list 1 lesser-limit)) + (goto-char lesser-limit) + t)))) + +(defun mh-show-font-lock-fontify-region (beg end loudly) + "Limit font-lock in `mh-show-mode' to the header. + +Used when the option `mh-highlight-citation-style' 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 (mh-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)))) + +(defvar mh-show-font-lock-keywords + '(("^\\(From:\\|Sender:\\)\\(.*\\)" + (1 'default) + (2 'mh-show-from)) + (mh-header-to-font-lock + (0 'default) + (1 'mh-show-to)) + (mh-header-cc-font-lock + (0 'default) + (1 'mh-show-cc)) + ("^\\(Reply-To:\\|Return-Path:\\)\\(.*\\)$" + (1 'default) + (2 'mh-show-from)) + (mh-header-subject-font-lock + (0 'default) + (1 'mh-show-subject)) + ("^\\(Apparently-To:\\|Newsgroups:\\)\\(.*\\)" + (1 'default) + (2 'mh-show-cc)) + ("^\\(In-reply-to\\|Date\\):\\(.*\\)$" + (1 'default) + (2 'mh-show-date)) + (mh-letter-header-font-lock + (0 'mh-show-header append t))) + "Additional expressions to highlight in MH-Show buffers.") + +;;;###mh-autoload +(defun mh-show-font-lock-keywords () + "Return variable `mh-show-font-lock-keywords'." + mh-show-font-lock-keywords) + +(defvar mh-show-font-lock-keywords-with-cite + (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 buffers.") + +;;;###mh-autoload +(defun mh-show-font-lock-keywords-with-cite () + "Return variable `mh-show-font-lock-keywords-with-cite'." + mh-show-font-lock-keywords-with-cite) + + + +;;; MH-Show Mode + +;; Ensure new buffers won't get this mode if default-major-mode is nil. +(put 'mh-show-mode 'mode-class 'special) + +;; Shush compiler. +(eval-when-compile (defvar font-lock-auto-fontify)) + +;;;###mh-autoload +(define-derived-mode mh-show-mode text-mode "MH-Show" + "Major mode for showing messages in MH-E.\\<mh-show-mode-map> + +The hook `mh-show-mode-hook' is called upon entry to this mode. + +See also `mh-folder-mode'. + +\\{mh-show-mode-map}" + (set (make-local-variable 'mail-header-separator) mh-mail-header-separator) + (setq paragraph-start (default-value 'paragraph-start)) + (mh-show-unquote-From) + (mh-show-xface) + (mh-show-addr) + (setq buffer-invisibility-spec '((vanish . t) t)) + (set (make-local-variable 'line-move-ignore-invisible) t) + (make-local-variable 'font-lock-defaults) + ;;(set (make-local-variable 'font-lock-support-mode) nil) + (cond + ((equal mh-highlight-citation-style 'font-lock) + (setq font-lock-defaults '(mh-show-font-lock-keywords-with-cite t))) + ((equal mh-highlight-citation-style 'gnus) + (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)))) + (if (and mh-xemacs-flag + font-lock-auto-fontify) + (turn-on-font-lock)) + (set (make-local-variable 'tool-bar-map) mh-show-tool-bar-map) + (mh-funcall-if-exists mh-tool-bar-init :show) + (when mh-decode-mime-flag + (mh-make-local-hook 'kill-buffer-hook) + (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)) + + + +;;; Support Routines + +(defun mh-show-unquote-From () + "Decode >From at beginning of lines for `mh-show-mode'." + (save-excursion + (let ((modified (buffer-modified-p)) + (case-fold-search nil) + (buffer-read-only nil)) + (goto-char (mh-mail-header-end)) + (while (re-search-forward "^>From" nil t) + (replace-match "From")) + (set-buffer-modified-p modified)))) + +;;;###mh-autoload +(defun mh-show-addr () + "Use `goto-address'." + (when mh-show-use-goto-addr-flag + (require 'goto-addr nil t) + (if (fboundp 'goto-address) + (goto-address)))) + +;;;###mh-autoload +(defun mh-gnus-article-highlight-citation () + "Highlight cited text in current buffer using Gnus." + (interactive) + ;; 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)))) + +(provide 'mh-show) + +;; Local Variables: +;; indent-tabs-mode: nil +;; sentence-end-double-space: nil +;; End: + +;;; mh-show.el ends here diff --git a/lisp/mh-e/mh-speed.el b/lisp/mh-e/mh-speed.el index 5019381ac3c..00cfd5ef961 100644 --- a/lisp/mh-e/mh-speed.el +++ b/lisp/mh-e/mh-speed.el @@ -1,6 +1,6 @@ -;;; mh-speed.el --- Speedbar interface for MH-E. +;;; mh-speed.el --- MH-E speedbar support -;; Copyright (C) 2002, 2003, 2004, 2005 Free Software Foundation, Inc. +;; Copyright (C) 2002, 2003, 2004, 2005, 2006 Free Software Foundation, Inc. ;; Author: Satyaki Das <satyaki@theforce.stanford.edu> ;; Maintainer: Bill Wohler <wohler@newt.com> @@ -25,23 +25,21 @@ ;; Boston, MA 02110-1301, USA. ;;; Commentary: -;; Future versions should only use flists. -;; Speedbar support for MH-E package. +;; Future versions should only use flists. ;;; Change Log: ;;; Code: -;;(message "> mh-speed") -(eval-when-compile (require 'mh-acros)) -(mh-require-cl) (require 'mh-e) +(mh-require-cl) + +(require 'gnus-util) (require 'speedbar) (require 'timer) -;;(message "< mh-speed") -;; Global variables +;; 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)) @@ -50,7 +48,10 @@ (defvar mh-speed-flists-timer nil) (defvar mh-speed-partial-line "") -;; Add our stealth update function + + +;;; Speedbar Hook + (unless (member 'mh-speed-stealth-update (cdr (assoc "files" speedbar-stealthy-function-list))) ;; Is changing constant lists in elisp safe? @@ -59,7 +60,132 @@ (push 'mh-speed-stealth-update (cdr (assoc "files" speedbar-stealthy-function-list)))) -;; Functions called by speedbar to initialize display... + + +;;; Speedbar Menus + +(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))] + ["Refresh Speedbar" mh-speed-refresh t]) + "Extra menu items for speedbar.") + +(defvar mh-show-speedbar-menu-items mh-folder-speedbar-menu-items) +(defvar mh-letter-speedbar-menu-items mh-folder-speedbar-menu-items) + + + +;;; Speedbar Keys + +(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 + "r" mh-speed-refresh) + +(defvar mh-show-speedbar-key-map mh-folder-speedbar-key-map) +(defvar mh-letter-speedbar-key-map mh-folder-speedbar-key-map) + + + +;;; Speedbar Commands + +;; Alphabetical. + +(defalias 'mh-speed-contract-folder 'mh-speed-toggle) + +(defalias 'mh-speed-expand-folder 'mh-speed-toggle) + +(defun mh-speed-refresh () + "Regenerates the list of folders in the speedbar. + +Run this command if you've added or deleted a folder, or want to +update the unseen message count before the next automatic +update." + (interactive) + (mh-speed-flists t) + (mh-speed-invalidate-map "")) + +(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-toggle (&rest args) + "Toggle the display of child folders in the speedbar. +The optional ARGS from speedbar are ignored." + (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)) + (let ((folder (get-text-property (point) 'mh-folder))) + (when (gethash folder mh-speed-folder-map) + (set-marker (gethash folder mh-speed-folder-map) nil) + (remhash 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))))))) + +(defun mh-speed-view (&rest args) + "Visits the selected folder just as if you had used \\<mh-folder-mode-map>\\[mh-visit-folder]. +The optional ARGS from speedbar are ignored." + (interactive) + (declare (ignore args)) + (let* ((folder (get-text-property (line-beginning-position) 'mh-folder)) + (range (and (stringp folder) + (mh-read-range "Scan" folder t nil nil + mh-interpret-number-as-range-flag)))) + (when (stringp folder) + (speedbar-with-attached-buffer + (mh-visit-folder folder range) + (delete-other-windows))))) + + + +;;; Support Routines + ;;;###mh-autoload (defun mh-folder-speedbar-buttons (buffer) "Interface function to create MH-E speedbar buffer. @@ -86,37 +212,6 @@ created." ;;;###mh-autoload (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 - "r" mh-speed-refresh) - -(defvar mh-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))] - ["Refresh Speedbar" mh-speed-refresh t]) - "Extra menu items for speedbar.") - -(defvar mh-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) @@ -167,6 +262,19 @@ The update is always carried out if FORCE is non-nil." (when (eq lastf speedbar-frame) (setq mh-speed-refresh-flag t)))) +(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-normal-face (face) "Return normal face for given FACE." (cond ((eq face 'mh-speedbar-folder-with-unseen-messages) @@ -183,30 +291,6 @@ The update is always carried out if FORCE is non-nil." 'mh-speedbar-selected-folder-with-unseen-messages) (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." @@ -295,64 +379,6 @@ uses." mh-level ,level)))))) folder-list))) -;;;###mh-autoload -(defun mh-speed-toggle (&rest args) - "Toggle the display of child folders in the speedbar. -The optional ARGS from speedbar are ignored." - (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)) - (let ((folder (get-text-property (point) 'mh-folder))) - (when (gethash folder mh-speed-folder-map) - (set-marker (gethash folder mh-speed-folder-map) nil) - (remhash 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) - -;;;###mh-autoload -(defun mh-speed-view (&rest args) - "Visits the selected folder just as if you had used \\<mh-folder-mode-map>\\[mh-visit-folder]. -The optional ARGS from speedbar are ignored." - (interactive) - (declare (ignore args)) - (let* ((folder (get-text-property (line-beginning-position) 'mh-folder)) - (range (and (stringp folder) - (mh-read-range "Scan" folder t nil nil - mh-interpret-number-as-range-flag)))) - (when (stringp folder) - (speedbar-with-attached-buffer - (mh-visit-folder folder range) - (delete-other-windows))))) - (defvar mh-speed-current-folder nil) (defvar mh-speed-flists-folder nil) @@ -415,6 +441,7 @@ flists is run only for that one folder." 'mh-speed-parse-flists-output))))))) ;; Copied from mh-make-folder-list-filter... +;; XXX Refactor to use mh-make-folder-list-filer? (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 @@ -506,17 +533,23 @@ be handled next." (setq mh-speed-last-selected-folder nil) (setq mh-speed-refresh-flag t))) (when (equal folder "") - (clrhash mh-sub-folders-cache))))) - -(defun mh-speed-refresh () - "Regenerates the list of folders in the speedbar. + (mh-clear-sub-folders-cache))))) -Run this command if you've added or deleted a folder, or want to -update the unseen message count before the next automatic -update." - (interactive) - (mh-speed-flists t) - (mh-speed-invalidate-map "")) +;; 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. + (mh-funcall-if-exists + speedbar-insert-image-button-maybe (- (point) 2) 3))))) ;;;###mh-autoload (defun mh-speed-add-folder (folder) @@ -546,22 +579,6 @@ The function invalidates the latest ancestor that is present." (mh-speed-toggle)) (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. - (mh-funcall-if-exists - speedbar-insert-image-button-maybe (- (point) 2) 3))))) - (provide 'mh-speed) ;; Local Variables: diff --git a/lisp/mh-e/mh-thread.el b/lisp/mh-e/mh-thread.el new file mode 100644 index 00000000000..3b477177e05 --- /dev/null +++ b/lisp/mh-e/mh-thread.el @@ -0,0 +1,883 @@ +;;; mh-thread.el --- MH-E threading support + +;; Copyright (C) 2002, 2003, 2004, 2006 Free Software Foundation, Inc. + +;; Author: Satyaki Das <satyaki@theforce.stanford.edu> +;; 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., 51 Franklin Street, Fifth Floor, +;; Boston, MA 02110-1301, USA. + +;;; Commentary: + +;; The threading portion of this files tries to implement the +;; algorithm described at: +;; http://www.jwz.org/doc/threading.html +;; It also begins to implement 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. + +;; If threading is slow on your machine, compile this file. Of all the +;; files in MH-E, this one really benefits from compilation. + +;; 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 identifiers in +;; In-Reply-To: header. Right now it just assumes that the last +;; text between angles (< and >) is the message identifier. +;; There is the chance that this will incorrectly use an email +;; address like a message identifier. + +;; (3) Error checking of found message identifiers 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 identifier and subject +;; strings. + +;;; Change Log: + +;;; Code: + +(require 'mh-e) +(require 'mh-scan) + +(mh-defstruct (mh-thread-message (:conc-name mh-message-) + (:constructor mh-thread-make-message)) + (id nil) + (references ()) + (subject "") + (subject-re-p nil)) + +(mh-defstruct (mh-thread-container (:conc-name mh-container-) + (:constructor mh-thread-make-container)) + message parent children + (real-child-p t)) + +(defvar mh-thread-id-hash nil + "Hashtable used to canonicalize message identifiers.") +(make-variable-buffer-local 'mh-thread-id-hash) + +(defvar mh-thread-subject-hash nil + "Hashtable used to canonicalize subject strings.") +(make-variable-buffer-local 'mh-thread-subject-hash) + +(defvar mh-thread-id-table nil + "Thread ID table maps from message identifiers to message containers.") +(make-variable-buffer-local 'mh-thread-id-table) + +(defvar mh-thread-index-id-map nil + "Table to look up message identifier from message index.") +(make-variable-buffer-local 'mh-thread-index-id-map) + +(defvar mh-thread-id-index-map nil + "Table to look up message index number from message identifier.") +(make-variable-buffer-local 'mh-thread-id-index-map) + +(defvar mh-thread-subject-container-hash nil + "Hashtable used to group messages by subject.") +(make-variable-buffer-local 'mh-thread-subject-container-hash) + +(defvar mh-thread-duplicates nil + "Hashtable used to associate messages with the same message identifier.") +(make-variable-buffer-local 'mh-thread-duplicates) + +(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.") +(make-variable-buffer-local 'mh-thread-history) + +(defvar mh-thread-body-width nil + "Width of scan substring that contains subject and body of message.") + + + +;;; MH-Folder Commands + +;;;###mh-autoload +(defun mh-thread-ancestor (&optional thread-root-flag) + "Display ancestor of current message. + +If you do not care for the way a particular thread has turned, +you can move up the chain of messages with this command. This +command can also take a prefix argument THREAD-ROOT-FLAG to jump +to the message that started everything." + (interactive "P") + (beginning-of-line) + (cond ((not (memq 'unthread mh-view-ops)) + (error "Folder isn't threaded")) + ((eobp) + (error "No message at point"))) + (let ((current-level (mh-thread-current-indentation-level))) + (cond (thread-root-flag + (while (mh-thread-immediate-ancestor)) + (mh-maybe-show)) + ((equal current-level 1) + (message "Message has no ancestor")) + (t (mh-thread-immediate-ancestor) + (mh-maybe-show))))) + +;;;###mh-autoload +(defun mh-thread-delete () + "Delete thread." + (interactive) + (cond ((not (memq 'unthread mh-view-ops)) + (error "Folder isn't threaded")) + ((eobp) + (error "No message at point")) + (t (let ((region (mh-thread-find-children))) + (mh-iterate-on-messages-in-region () (car region) (cadr region) + (mh-delete-a-msg nil)) + (mh-next-msg))))) + +;;;###mh-autoload +(defun mh-thread-next-sibling (&optional previous-flag) + "Display next sibling. + +With non-nil optional argument PREVIOUS-FLAG jump to the previous +sibling." + (interactive) + (cond ((not (memq 'unthread mh-view-ops)) + (error "Folder isn't threaded")) + ((eobp) + (error "No message at point"))) + (beginning-of-line) + (let ((point (point)) + (done nil) + (my-level (mh-thread-current-indentation-level))) + (while (and (not done) + (equal (forward-line (if previous-flag -1 1)) 0) + (not (eobp))) + (let ((level (mh-thread-current-indentation-level))) + (cond ((equal level my-level) + (setq done 'success)) + ((< level my-level) + (message "No %s sibling" (if previous-flag "previous" "next")) + (setq done 'failure))))) + (cond ((eq done 'success) (mh-maybe-show)) + ((eq done 'failure) (goto-char point)) + (t (message "No %s sibling" (if previous-flag "previous" "next")) + (goto-char point))))) + +;;;###mh-autoload +(defun mh-thread-previous-sibling () + "Display previous sibling." + (interactive) + (mh-thread-next-sibling t)) + +;;;###mh-autoload +(defun mh-thread-refile (folder) + "Refile (output) thread into FOLDER." + (interactive (list (intern (mh-prompt-for-refile-folder)))) + (cond ((not (memq 'unthread mh-view-ops)) + (error "Folder isn't threaded")) + ((eobp) + (error "No message at point")) + (t (let ((region (mh-thread-find-children))) + (mh-iterate-on-messages-in-region () (car region) (cadr region) + (mh-refile-a-msg nil folder)) + (mh-next-msg))))) + +;;;###mh-autoload +(defun mh-toggle-threads () + "Toggle threaded view of folder." + (interactive) + (let ((msg-at-point (mh-get-msg-num nil)) + (old-buffer-modified-flag (buffer-modified-p)) + (buffer-read-only nil)) + (cond ((memq 'unthread mh-view-ops) + (unless (mh-valid-view-change-operation-p 'unthread) + (error "Can't unthread folder")) + (let ((msg-list ())) + (goto-char (point-min)) + (while (not (eobp)) + (let ((index (mh-get-msg-num nil))) + (when index + (push index msg-list))) + (forward-line)) + (mh-scan-folder mh-current-folder + (mapcar #'(lambda (x) (format "%s" x)) + (mh-coalesce-msg-list msg-list)) + t)) + (when mh-index-data + (mh-index-insert-folder-headers) + (mh-notate-cur))) + (t (mh-thread-folder) + (push 'unthread mh-view-ops))) + (when msg-at-point (mh-goto-msg msg-at-point t t)) + (set-buffer-modified-p old-buffer-modified-flag) + (mh-recenter nil))) + + + +;;; Support Routines + +(defun mh-thread-current-indentation-level () + "Find the number of spaces by which current message is indented." + (save-excursion + (let ((address-start-offset (+ mh-cmd-note mh-scan-date-flag-width + mh-scan-date-width 1)) + (level 0)) + (beginning-of-line) + (forward-char address-start-offset) + (while (char-equal (char-after) ? ) + (incf level) + (forward-char)) + level))) + +(defun mh-thread-immediate-ancestor () + "Jump to immediate ancestor in thread tree." + (beginning-of-line) + (let ((point (point)) + (ancestor-level (- (mh-thread-current-indentation-level) 2)) + (done nil)) + (if (< ancestor-level 0) + nil + (while (and (not done) (equal (forward-line -1) 0)) + (when (equal ancestor-level (mh-thread-current-indentation-level)) + (setq done t))) + (unless done + (goto-char point)) + done))) + +(defun mh-thread-find-children () + "Return a region containing the current message and its children. +The result is returned as a list of two elements. The first is +the point at the start of the region and the second is the point +at the end." + (beginning-of-line) + (if (eobp) + nil + (let ((address-start-offset (+ mh-cmd-note mh-scan-date-flag-width + mh-scan-date-width 1)) + (level (mh-thread-current-indentation-level)) + spaces begin) + (setq begin (point)) + (setq spaces (format (format "%%%ss" (1+ level)) "")) + (forward-line) + (block nil + (while (not (eobp)) + (forward-char address-start-offset) + (unless (equal (string-match spaces (buffer-substring-no-properties + (point) (line-end-position))) + 0) + (beginning-of-line) + (backward-char) + (return)) + (forward-line))) + (list begin (point))))) + + + +;;; Thread Creation + +(defun mh-thread-folder () + "Generate thread view of folder." + (message "Threading %s..." (buffer-name)) + (mh-thread-initialize) + (goto-char (point-min)) + (mh-remove-all-notation) + (let ((msg-list ())) + (mh-iterate-on-range msg (cons (point-min) (point-max)) + (setf (gethash msg mh-thread-scan-line-map) (mh-thread-parse-scan-line)) + (push msg msg-list)) + (let* ((range (mh-coalesce-msg-list msg-list)) + (thread-tree (mh-thread-generate (buffer-name) range))) + (delete-region (point-min) (point-max)) + (mh-thread-print-scan-lines thread-tree) + (mh-notate-user-sequences) + (mh-notate-deleted-and-refiled) + (mh-notate-cur) + (message "Threading %s...done" (buffer-name))))) + +;;;###mh-autoload +(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) + (mh-remove-all-notation) + (goto-char start-point) + (let ((msg-list ())) + (while (not (eobp)) + (let ((index (mh-get-msg-num nil))) + (when (numberp index) + (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)) + (mh-thread-print-scan-lines thread-tree) + (mh-notate-user-sequences) + (mh-notate-deleted-and-refiled) + (mh-notate-cur) + (set-buffer-modified-p old-buffer-modified-flag)))) + +(defmacro mh-thread-initialize-hash (var test) + "Initialize the hash table in VAR. +TEST is the test to use when creating a new hash table." + (unless (symbolp var) (error "Expected a symbol: %s" var)) + `(if ,var (clrhash ,var) (setq ,var (make-hash-table :test ,test)))) + +(defun mh-thread-initialize () + "Make new hash tables, or clear them if already present." + (mh-thread-initialize-hash mh-thread-id-hash #'equal) + (mh-thread-initialize-hash mh-thread-subject-hash #'equal) + (mh-thread-initialize-hash mh-thread-id-table #'eq) + (mh-thread-initialize-hash mh-thread-id-index-map #'eq) + (mh-thread-initialize-hash mh-thread-index-id-map #'eql) + (mh-thread-initialize-hash mh-thread-scan-line-map #'eql) + (mh-thread-initialize-hash mh-thread-subject-container-hash #'eq) + (mh-thread-initialize-hash mh-thread-duplicates #'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) + (loop for elem in (mh-container-children parent-container) + unless (eq child-container elem) collect elem)) + (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-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-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)) + +;; 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. +;;;###mh-autoload +(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)))) + (address-start (+ mh-cmd-note mh-scan-field-from-start-offset)) + (body-start (+ mh-cmd-note mh-scan-field-from-end-offset)) + (first-string (substring string 0 address-start))) + (list first-string + (substring string address-start (- body-start 2)) + (substring string body-start) + string))) + +(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))))) + +(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))) + +(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"))))) + +(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))) + +(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 :id id :references refs + :subject subject + :subject-re-p subject-re-p))) + (t (let ((message (mh-thread-make-message :id id :references refs + :subject-re-p subject-re-p + :subject subject))) + (prog1 message + (mh-thread-get-message-container message))))))) + +(defvar mh-message-id-regexp "^<.*@.*>$" + "Regexp to recognize whether a string is a message identifier.") + +;;;###mh-autoload +(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." + (with-temp-buffer + (mh-thread-set-tables folder) + (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" + folder (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 (string-to-number 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 (loop for x in (append (split-string refs) in-reply-to) + when (string-match mh-message-id-regexp x) + collect x)) + (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-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)))) + +(defun 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 (mh-search-from-end ?> reply-to-header))) + (when (numberp end) + (let ((begin (mh-search-from-end ?< (substring reply-to-header 0 end)))) + (when (numberp begin) + (list (substring reply-to-header begin (1+ end)))))))) + +(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))))))) + +(defvar mh-thread-last-ancestor) + +;;;###mh-autoload +(defun mh-thread-print-scan-lines (thread-tree) + "Print scan lines in THREAD-TREE in threaded mode." + (let ((mh-thread-body-width (- (window-width) mh-cmd-note + (1- mh-scan-field-subject-start-offset))) + (mh-thread-last-ancestor nil)) + (if (null mh-index-data) + (mh-thread-generate-scan-lines thread-tree -2) + (loop for x in (mh-index-group-by-folder) + do (let* ((old-map mh-thread-scan-line-map) + (mh-thread-scan-line-map (make-hash-table))) + (setq mh-thread-last-ancestor nil) + (loop for msg in (cdr x) + do (let ((v (gethash msg old-map))) + (when v + (setf (gethash msg mh-thread-scan-line-map) v)))) + (when (> (hash-table-count mh-thread-scan-line-map) 0) + (insert (if (bobp) "" "\n") (car x) "\n") + (mh-thread-generate-scan-lines thread-tree -2)))) + (mh-index-create-imenu-index)))) + +(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) + (force-angle-flag nil) + (increment-level-flag nil)) + (dolist (scan-line (mapcar (lambda (x) + (gethash x mh-thread-scan-line-map)) + (reverse (cons index duplicates)))) + (when scan-line + (when (and dupl-flag (equal level 0) + (mh-thread-ancestor-p mh-thread-last-ancestor tree)) + (setq level (+ level 2) + new-level (+ new-level 2) + force-angle-flag t)) + (when (equal level 0) + (setq mh-thread-last-ancestor tree) + (while (mh-container-parent mh-thread-last-ancestor) + (setq mh-thread-last-ancestor + (mh-container-parent mh-thread-last-ancestor)))) + (let* ((lev (if dupl-flag level new-level)) + (square-flag (or (and (mh-container-real-child-p tree) + (not force-angle-flag) + dupl-flag) + (equal lev 0)))) + (insert (car scan-line) + (format (format "%%%ss" lev) "") + (if square-flag "[" "<") + (cadr scan-line) + (if square-flag "]" ">") + (truncate-string-to-width + (caddr scan-line) (- mh-thread-body-width lev)) + "\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)))))) + + + +;;; Additional Utilities + +;;;###mh-autoload +(defun mh-thread-update-scan-line-map (msg notation offset) + "In threaded view update `mh-thread-scan-line-map'. +MSG is the message being notated with NOTATION at OFFSET." + (let* ((msg (or msg (mh-get-msg-num nil))) + (cur-scan-line (and mh-thread-scan-line-map + (gethash msg mh-thread-scan-line-map))) + (old-scan-lines (loop for map in mh-thread-scan-line-map-stack + collect (and map (gethash msg map))))) + (when cur-scan-line + (setf (aref (car cur-scan-line) offset) notation)) + (dolist (line old-scan-lines) + (when line (setf (aref (car line) offset) notation))))) + +;;;###mh-autoload +(defun mh-thread-find-msg-subject (msg) + "Find canonicalized subject of MSG. +This function can only be used the folder is threaded." + (ignore-errors + (mh-message-subject + (mh-container-message (gethash (gethash msg mh-thread-index-id-map) + mh-thread-id-table))))) + +;;;###mh-autoload +(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)))) + (when (numberp msg-num) + (setf (gethash msg-num mh-thread-scan-line-map) + (mh-thread-parse-scan-line (format "%s%s" spaces old-line))))) + (forward-line 1)))) + +;;;###mh-autoload +(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) + (remhash index mh-thread-scan-line-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-thread) + +;; Local Variables: +;; indent-tabs-mode: nil +;; sentence-end-double-space: nil +;; End: + +;;; mh-thread.el ends here diff --git a/lisp/mh-e/mh-tool-bar.el b/lisp/mh-e/mh-tool-bar.el new file mode 100644 index 00000000000..d251abc41fd --- /dev/null +++ b/lisp/mh-e/mh-tool-bar.el @@ -0,0 +1,419 @@ +;;; mh-tool-bar.el --- MH-E tool bar support + +;; Copyright (C) 2002, 2003, 2005, 2006 Free Software Foundation, Inc. + +;; Author: Satyaki Das <satyaki@theforce.stanford.edu> +;; 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., 51 Franklin Street, Fifth Floor, +;; Boston, MA 02110-1301, USA. + +;;; Commentary: + +;;; Change Log: + +;;; Code: + +(require 'mh-e) + +;;; Tool Bar Commands + +(defun mh-tool-bar-search (&optional arg) + "Interactively call `mh-tool-bar-search-function'. +Optional argument ARG is not used." + (interactive "P") + (call-interactively mh-tool-bar-search-function)) + +(defun mh-tool-bar-customize () + "Call `mh-customize' from the tool bar." + (interactive) + (mh-customize t)) + +(defun mh-tool-bar-folder-help () + "Visit \"(mh-e)Top\"." + (interactive) + (info "(mh-e)Top") + (delete-other-windows)) + +(defun mh-tool-bar-letter-help () + "Visit \"(mh-e)Editing Drafts\"." + (interactive) + (info "(mh-e)Editing Drafts") + (delete-other-windows)) + +(defmacro mh-tool-bar-reply-generator (function recipient folder-buffer-flag) + "Generate FUNCTION that replies to RECIPIENT. +If FOLDER-BUFFER-FLAG is nil then the function generated... +When INCLUDE-FLAG is non-nil, include message body being replied to." + `(defun ,function (&optional arg) + ,(format "Reply to \"%s\".\nWhen ARG is non-nil include message in reply." + recipient) + (interactive "P") + ,(if folder-buffer-flag nil '(set-buffer mh-show-folder-buffer)) + (mh-reply (mh-get-msg-num nil) ,recipient arg))) + +(mh-tool-bar-reply-generator mh-tool-bar-reply-from "from" t) +(mh-tool-bar-reply-generator mh-show-tool-bar-reply-from "from" nil) +(mh-tool-bar-reply-generator mh-tool-bar-reply-to "to" t) +(mh-tool-bar-reply-generator mh-show-tool-bar-reply-to "to" nil) +(mh-tool-bar-reply-generator mh-tool-bar-reply-all "all" t) +(mh-tool-bar-reply-generator mh-show-tool-bar-reply-all "all" nil) + + + +;;; Tool Bar Creation + +(defmacro mh-tool-bar-define (defaults &rest buttons) + "Define a tool bar for MH-E. +DEFAULTS is the list of buttons that are present by default. It +is a list of lists where the sublists are of the following form: + + (:KEYWORD FUNC1 FUNC2 FUNC3 ...) + +Here :KEYWORD is one of :folder or :letter. If it is :folder then +the default buttons in the folder and show mode buffers are being +specified. If it is :letter then the default buttons in the +letter mode are listed. FUNC1, FUNC2, FUNC3, ... are the names of +the functions that the buttons would execute. + +Each element of BUTTONS is a list consisting of four mandatory +items and one optional item as follows: + + (FUNCTION MODES ICON DOC &optional ENABLE-EXPR) + +where, + + FUNCTION is the name of the function that will be executed when + the button is clicked. + + MODES is a list of symbols. List elements must be from \"folder\", + \"letter\" and \"sequence\". If \"folder\" is present then the button is + available in the folder and show buffer. If the name of FUNCTION is + of the form \"mh-foo\", where foo is some arbitrary string, then we + check if the function `mh-show-foo' exists. If it exists then that + function is used in the show buffer. Otherwise the original function + `mh-foo' is used in the show buffer as well. Presence of \"sequence\" + is handled similar to the above. The only difference is that the + button is shown only when the folder is narrowed to a sequence. If + \"letter\" is present in MODES, then the button is available during + draft editing and runs FUNCTION when clicked. + + ICON is the icon that is drawn in the button. + + DOC is the documentation for the button. It is used in tool-tips and + in providing other help to the user. GNU Emacs uses only the first + line of the string. So the DOC should be formatted such that the + first line is useful and complete without the rest of the string. + + Optional item ENABLE-EXPR is an arbitrary lisp expression. If it + evaluates to nil, then the button is deactivated, otherwise it is + active. If it isn't present then the button is always active." + ;; The following variable names have been carefully chosen to make code + ;; generation easier. Modifying the names should be done carefully. + (let (folder-buttons folder-docs folder-button-setter sequence-button-setter + show-buttons show-button-setter show-seq-button-setter + letter-buttons letter-docs letter-button-setter + folder-defaults letter-defaults + folder-vectors show-vectors letter-vectors) + (dolist (x defaults) + (cond ((eq (car x) :folder) (setq folder-defaults (cdr x))) + ((eq (car x) :letter) (setq letter-defaults (cdr x))))) + (dolist (button buttons) + (unless (and (listp button) + (or (equal (length button) 4) (equal (length button) 5))) + (error "Incorrect MH-E tool-bar button specification: %s" button)) + (let* ((name (nth 0 button)) + (name-str (symbol-name name)) + (icon (nth 2 button)) + (xemacs-icon (mh-do-in-xemacs + (cdr (assoc (intern icon) mh-xemacs-icon-map)))) + (full-doc (nth 3 button)) + (doc (if (string-match "\\(.*\\)\n" full-doc) + (match-string 1 full-doc) + full-doc)) + (enable-expr (or (nth 4 button) t)) + (modes (nth 1 button)) + functions show-sym) + (when (memq 'letter modes) (setq functions `(:letter ,name))) + (when (or (memq 'folder modes) (memq 'sequence modes)) + (setq functions + (append `(,(if (memq 'folder modes) :folder :sequence) ,name) + functions)) + (setq show-sym + (if (string-match "^mh-\\(.*\\)$" name-str) + (intern (concat "mh-show-" (match-string 1 name-str))) + name)) + (setq functions + (append `(,(if (memq 'folder modes) :show :show-seq) + ,(if (fboundp show-sym) show-sym name)) + functions))) + (do ((functions functions (cddr functions))) + ((null functions)) + (let* ((type (car functions)) + (function (cadr functions)) + (type1 (substring (symbol-name type) 1)) + (vector-list (cond ((eq type :show) 'show-vectors) + ((eq type :show-seq) 'show-vectors) + ((eq type :letter) 'letter-vectors) + (t 'folder-vectors))) + (list (cond ((eq type :letter) 'mh-tool-bar-letter-buttons) + (t 'mh-tool-bar-folder-buttons))) + (key (intern (concat "mh-" type1 "tool-bar-" name-str))) + (setter (intern (concat type1 "-button-setter"))) + (mbuttons (cond ((eq type :letter) 'letter-buttons) + ((eq type :show) 'show-buttons) + ((eq type :show-seq) 'show-buttons) + (t 'folder-buttons))) + (docs (cond ((eq mbuttons 'letter-buttons) 'letter-docs) + ((eq mbuttons 'folder-buttons) 'folder-docs)))) + (add-to-list vector-list `[,xemacs-icon ,function t ,full-doc]) + (add-to-list + setter `(when (member ',name ,list) + (mh-funcall-if-exists + tool-bar-add-item ,icon ',function ',key + :help ,doc :enable ',enable-expr))) + (add-to-list mbuttons name) + (if docs (add-to-list docs doc)))))) + (setq folder-buttons (nreverse folder-buttons) + letter-buttons (nreverse letter-buttons) + show-buttons (nreverse show-buttons) + letter-docs (nreverse letter-docs) + folder-docs (nreverse folder-docs) + folder-vectors (nreverse folder-vectors) + show-vectors (nreverse show-vectors) + letter-vectors (nreverse letter-vectors)) + (dolist (x folder-defaults) + (unless (memq x folder-buttons) + (error "Folder defaults contains unknown button '%s'" x))) + (dolist (x letter-defaults) + (unless (memq x letter-buttons) + (error "Letter defaults contains unknown button '%s'" x))) + `(eval-when (compile load eval) + (defun mh-buffer-exists-p (mode) + "Test whether a buffer with major mode MODE is present." + (loop for buf in (buffer-list) + when (save-excursion + (set-buffer buf) + (eq major-mode mode)) + return t)) + + ;; GNU Emacs tool bar specific code + (mh-do-in-gnu-emacs + ;; Tool bar initialization functions + (defun mh-tool-bar-folder-buttons-init () + (when (mh-buffer-exists-p 'mh-folder-mode) + (mh-image-load-path) + (setq mh-folder-tool-bar-map + (let ((tool-bar-map (make-sparse-keymap))) + ,@(nreverse folder-button-setter) + tool-bar-map)) + (setq mh-show-tool-bar-map + (let ((tool-bar-map (make-sparse-keymap))) + ,@(nreverse show-button-setter) + tool-bar-map)) + (setq mh-show-seq-tool-bar-map + (let ((tool-bar-map (copy-keymap mh-show-tool-bar-map))) + ,@(nreverse show-seq-button-setter) + tool-bar-map)) + (setq mh-folder-seq-tool-bar-map + (let ((tool-bar-map (copy-keymap mh-folder-tool-bar-map))) + ,@(nreverse sequence-button-setter) + tool-bar-map)))) + (defun mh-tool-bar-letter-buttons-init () + (when (mh-buffer-exists-p 'mh-letter-mode) + (mh-image-load-path) + (setq mh-letter-tool-bar-map + (let ((tool-bar-map (make-sparse-keymap))) + ,@(nreverse letter-button-setter) + tool-bar-map)))) + ;; Custom setter functions + (defun mh-tool-bar-folder-buttons-set (symbol value) + "Construct tool bar for `mh-folder-mode' and `mh-show-mode'." + (set-default symbol value) + (mh-tool-bar-folder-buttons-init)) + (defun mh-tool-bar-letter-buttons-set (symbol value) + "Construct tool bar for `mh-letter-mode'." + (set-default symbol value) + (mh-tool-bar-letter-buttons-init))) + ;; XEmacs specific code + (mh-do-in-xemacs + (defvar mh-tool-bar-folder-vector-map + ',(loop for button in folder-buttons + for vector in folder-vectors + collect (cons button vector))) + (defvar mh-tool-bar-show-vector-map + ',(loop for button in show-buttons + for vector in show-vectors + collect (cons button vector))) + (defvar mh-tool-bar-letter-vector-map + ',(loop for button in letter-buttons + for vector in letter-vectors + collect (cons button vector))) + (defvar mh-tool-bar-folder-buttons nil) + (defvar mh-tool-bar-show-buttons nil) + (defvar mh-tool-bar-letter-buttons nil) + ;; Custom setter functions + (defun mh-tool-bar-letter-buttons-set (symbol value) + (set-default symbol value) + (when mh-xemacs-has-tool-bar-flag + (setq mh-tool-bar-letter-buttons + (loop for b in value + collect (cdr (assoc b mh-tool-bar-letter-vector-map)))))) + (defun mh-tool-bar-folder-buttons-set (symbol value) + (set-default symbol value) + (when mh-xemacs-has-tool-bar-flag + (setq mh-tool-bar-folder-buttons + (loop for b in value + collect (cdr (assoc b mh-tool-bar-folder-vector-map)))) + (setq mh-tool-bar-show-buttons + (loop for b in value + collect (cdr (assoc b mh-tool-bar-show-vector-map)))))) + (defun mh-tool-bar-init (mode) + "Install tool bar in MODE." + (let ((tool-bar (cond ((eq mode :folder) mh-tool-bar-folder-buttons) + ((eq mode :letter) mh-tool-bar-letter-buttons) + ((eq mode :show) mh-tool-bar-show-buttons))) + (height 37) + (width 40) + (buffer (current-buffer))) + (when mh-xemacs-use-tool-bar-flag + (cond + ((eq mh-xemacs-tool-bar-position 'top) + (set-specifier top-toolbar tool-bar buffer) + (set-specifier top-toolbar-visible-p t) + (set-specifier top-toolbar-height height)) + ((eq mh-xemacs-tool-bar-position 'bottom) + (set-specifier bottom-toolbar tool-bar buffer) + (set-specifier bottom-toolbar-visible-p t) + (set-specifier bottom-toolbar-height height)) + ((eq mh-xemacs-tool-bar-position 'left) + (set-specifier left-toolbar tool-bar buffer) + (set-specifier left-toolbar-visible-p t) + (set-specifier left-toolbar-width width)) + ((eq mh-xemacs-tool-bar-position 'right) + (set-specifier right-toolbar tool-bar buffer) + (set-specifier right-toolbar-visible-p t) + (set-specifier right-toolbar-width width)) + (t (set-specifier default-toolbar tool-bar buffer))))))) + ;; Declare customizable tool bars + (custom-declare-variable + 'mh-tool-bar-folder-buttons + '(list ,@(mapcar (lambda (x) `(quote ,x)) folder-defaults)) + "List of buttons to include in MH-Folder tool bar." + :group 'mh-tool-bar :set 'mh-tool-bar-folder-buttons-set + :type '(set ,@(loop for x in folder-buttons + for y in folder-docs + collect `(const :tag ,y ,x)))) + (custom-declare-variable + 'mh-tool-bar-letter-buttons + '(list ,@(mapcar (lambda (x) `(quote ,x)) letter-defaults)) + "List of buttons to include in MH-Letter tool bar." + :group 'mh-tool-bar :set 'mh-tool-bar-letter-buttons-set + :type '(set ,@(loop for x in letter-buttons + for y in letter-docs + collect `(const :tag ,y ,x))))))) + +(mh-tool-bar-define + ((:folder mh-inc-folder mh-mime-save-parts mh-previous-undeleted-msg + mh-page-msg mh-next-undeleted-msg mh-delete-msg mh-refile-msg + mh-undo mh-execute-commands mh-toggle-tick mh-reply + mh-alias-grab-from-field mh-send mh-rescan-folder + mh-tool-bar-search mh-visit-folder + mh-tool-bar-customize mh-tool-bar-folder-help mh-widen) + (:letter mh-send-letter mh-compose-insertion ispell-message save-buffer + undo kill-region menu-bar-kill-ring-save yank mh-fully-kill-draft + mh-tool-bar-customize mh-tool-bar-letter-help)) + ;; Folder/Show buffer buttons + (mh-inc-folder (folder) "mail" + "Incorporate new mail in Inbox +This button runs `mh-inc-folder' which drags any +new mail into your Inbox folder.") + (mh-mime-save-parts (folder) "attach" + "Save MIME parts from this message +This button runs `mh-mime-save-parts' which saves a message's +different parts into separate files.") + (mh-previous-undeleted-msg (folder) "left-arrow" + "Go to the previous undeleted message +This button runs `mh-previous-undeleted-msg'") + (mh-page-msg (folder) "page-down" + "Page the current message forwards\nThis button runs `mh-page-msg'") + (mh-next-undeleted-msg (folder) "right-arrow" + "Go to the next undeleted message\nThe button runs `mh-next-undeleted-msg'") + (mh-delete-msg (folder) "close" + "Mark this message for deletion\nThis button runs `mh-delete-msg'") + (mh-refile-msg (folder) "mail/refile" + "Refile this message\nThis button runs `mh-refile-msg'") + (mh-undo (folder) "undo" "Undo last operation\nThis button runs `undo'" + (mh-outstanding-commands-p)) + (mh-execute-commands (folder) "execute" + "Perform moves and deletes\nThis button runs `mh-execute-commands'" + (mh-outstanding-commands-p)) + (mh-toggle-tick (folder) "highlight" + "Toggle tick mark\nThis button runs `mh-toggle-tick'") + (mh-toggle-showing (folder) "show" + "Toggle showing message\nThis button runs `mh-toggle-showing'") + (mh-tool-bar-reply-from (folder) "mail/reply-from" "Reply to \"from\"") + (mh-tool-bar-reply-to (folder) "mail/reply-to" "Reply to \"to\"") + (mh-tool-bar-reply-all (folder) "mail/reply-all" "Reply to \"all\"") + (mh-reply (folder) "mail/reply" + "Reply to this message\nThis button runs `mh-reply'") + (mh-alias-grab-from-field (folder) "mail/alias" + "Grab From alias\nThis button runs `mh-alias-grab-from-field'" + (and (mh-extract-from-header-value) (not (mh-alias-for-from-p)))) + (mh-send (folder) "mail/compose" + "Compose new message\nThis button runs `mh-send'") + (mh-rescan-folder (folder) "refresh" + "Rescan this folder\nThis button runs `mh-rescan-folder'") + (mh-pack-folder (folder) "mail/repack" + "Repack this folder\nThis button runs `mh-pack-folder'") + (mh-tool-bar-search (folder) "search" + "Search\nThis button runs `mh-tool-bar-search-function'") + (mh-visit-folder (folder) "fld-open" + "Visit other folder\nThis button runs `mh-visit-folder'") + ;; Letter buffer buttons + (mh-send-letter (letter) "mail/send" "Send this letter") + (mh-compose-insertion (letter) "attach" "Insert attachment") + (ispell-message (letter) "spell" "Check spelling") + (save-buffer (letter) "save" "Save current buffer to its file" + (buffer-modified-p)) + (undo (letter) "undo" "Undo last operation") + (kill-region (letter) "cut" + "Cut (kill) text in region between mark and current position") + (menu-bar-kill-ring-save (letter) "copy" + "Copy text in region between mark and current position") + (yank (letter) "paste" "Paste (yank) text cut or copied earlier") + (mh-fully-kill-draft (letter) "close" "Kill this draft") + ;; Common buttons + (mh-tool-bar-customize (folder letter) "preferences" "MH-E Preferences") + (mh-tool-bar-folder-help (folder) "help" + "Help! (general help)\nThis button runs `info'") + (mh-tool-bar-letter-help (letter) "help" + "Help! (general help)\nThis button runs `info'") + ;; Folder narrowed to sequence buttons + (mh-widen (sequence) "widen" + "Widen from the sequence\nThis button runs `mh-widen'")) + +(provide 'mh-tool-bar) + +;; Local Variables: +;; indent-tabs-mode: nil +;; sentence-end-double-space: nil +;; End: + +;;; mh-tool-bar.el ends here diff --git a/lisp/mh-e/mh-utils.el b/lisp/mh-e/mh-utils.el index 111dfd2e6cd..a777cbfa68a 100644 --- a/lisp/mh-e/mh-utils.el +++ b/lisp/mh-e/mh-utils.el @@ -1,4 +1,4 @@ -;;; mh-utils.el --- MH-E code needed for both sending and reading +;;; mh-utils.el --- MH-E general utilities ;; Copyright (C) 1993, 1995, 1997, ;; 2000, 2001, 2002, 2003, 2004, 2005, 2006 Free Software Foundation, Inc. @@ -27,53 +27,18 @@ ;;; Commentary: -;; Internal support for MH-E package. - ;;; Change Log: ;;; Code: -;;(message "> mh-utils") -(eval-and-compile - (defvar recursive-load-depth-limit) - (if (and (boundp 'recursive-load-depth-limit) - (integerp recursive-load-depth-limit) - (< recursive-load-depth-limit 50)) - (setq recursive-load-depth-limit 50))) - -(eval-when-compile (require 'mh-acros)) +(require 'mh-e) (mh-require-cl) (require 'font-lock) -(require 'gnus-util) -(require 'mh-buffers) -(require 'mh-customize) -(require 'mh-inc) -(require 'mouse) -(require 'sendmail) -;;(message "< mh-utils") - -;; Non-fatal dependencies -(load "hl-line" t t) -(load "mm-decode" t t) -(load "mm-view" t t) -(load "tool-bar" t t) -(load "vcard" t t) - - - -;;; Autoloads - -(autoload 'gnus-article-highlight-citation "gnus-cite") -(autoload 'message-fetch-field "message") -(autoload 'message-tokenize-header "message") -(unless (fboundp 'make-hash-table) - (autoload 'make-hash-table "cl")) - - ;;; CL Replacements +;;;###mh-autoload (defun mh-search-from-end (char string) "Return the position of last occurrence of CHAR in STRING. If CHAR is not present in STRING then return nil. The function is @@ -82,476 +47,104 @@ used in lieu of `search' in the CL package." when (equal (aref string index) char) return index finally return nil)) -;; Additional header fields that might someday be added: -;; "Sender: " "Reply-to: " - - - -;;; Scan Line Formats - -(defvar mh-scan-msg-number-regexp "^ *\\([0-9]+\\)" - "This regular expression extracts the message number. - -It must match from the beginning of the line. Note that the -message number must be placed in a parenthesized expression as in -the default of \"^ *\\\\([0-9]+\\\\)\".") - -(defvar mh-scan-msg-overflow-regexp "^[?0-9][0-9]" - "This regular expression matches overflowed message numbers.") - -(defvar mh-scan-msg-format-regexp "%\\([0-9]*\\)(msg)" - "This regular expression finds the message number width in a scan format. - -Note that the message number must be placed in a parenthesized -expression as in the default of \"%\\\\([0-9]*\\\\)(msg)\". This -variable is only consulted if `mh-scan-format-file' is set to -\"Use MH-E scan Format\".") - -(defvar mh-scan-msg-format-string "%d" - "This is a format string for width of the message number in a scan format. - -Use \"0%d\" for zero-filled message numbers. This variable is only -consulted if `mh-scan-format-file' is set to \"Use MH-E scan -Format\".") - -(defvar mh-scan-msg-search-regexp "^[^0-9]*%d[^0-9]" - "This regular expression matches a particular message. - -It is a format string; use \"%d\" to represent the location of the -message number within the expression as in the default of -\"^[^0-9]*%d[^0-9]\".") - -(defvar mh-cmd-note 4 - "Column for notations. - -This variable should be set with the function `mh-set-cmd-note'. -This variable may be updated dynamically if -`mh-adaptive-cmd-note-flag' is on. - -Note that columns in Emacs start with 0.") -(make-variable-buffer-local 'mh-cmd-note) - -(defvar mh-note-seq ?% - "Messages in a user-defined sequence are marked by this character. - -Messages in the \"search\" sequence are marked by this character as -well.") - - - -(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-mail-header-separator "--------" - "*Line used by MH to separate headers from text in messages being composed. - -This variable should not be used directly in programs. Programs -should use `mail-header-separator' instead. -`mail-header-separator' is initialized to -`mh-mail-header-separator' in `mh-letter-mode'; in other -contexts, you may have to perform this initialization yourself. - -Do not make this a regular expression as it may be the argument -to `insert' and it is passed through `regexp-quote' before being -used by functions like `re-search-forward'.") - -(defvar mh-signature-separator-regexp "^-- $" - "This regular expression matches the signature separator. -See `mh-signature-separator'.") - -(defvar mh-signature-separator "-- \n" - "Text of a signature separator. - -A signature separator is used to separate the body of a message -from the signature. This can be used by user agents such as MH-E -to render the signature differently or to suppress the inclusion -of the signature in a reply. Use `mh-signature-separator-regexp' -when searching for a separator.") - -(defun mh-signature-separator-p () - "Return non-nil if buffer includes \"^-- $\"." - (save-excursion - (goto-char (point-min)) - (re-search-forward mh-signature-separator-regexp nil t))) - -;; Variables for MIME display - -;; Structure to keep track of MIME handles on a per buffer basis. -(mh-defstruct (mh-buffer-data (:conc-name mh-mime-) - (:constructor mh-make-buffer-data)) - (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)) - -(defvar mh-globals-hash (make-hash-table) - "Keeps track of MIME data on a per buffer basis.") - -(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.") - -;; Copy of `goto-address-mail-regexp' -(defvar mh-address-mail-regexp - "[-a-zA-Z0-9._]+@\\([-a-zA-z0-9_]+\\.\\)+[a-zA-Z0-9]+" - "A regular expression probably matching an e-mail address.") - -;; From goto-addr.el, which we don't want to force-load on users. - -(defun mh-goto-address-find-address-at-point () - "Find e-mail address around or before point. - -Then search backwards to beginning of line for the start of an -e-mail address. If no e-mail address found, return nil." - (re-search-backward "[^-_A-z0-9.@]" (line-beginning-position) 'lim) - (if (or (looking-at mh-address-mail-regexp) ; already at start - (and (re-search-forward mh-address-mail-regexp - (line-end-position) 'lim) - (goto-char (match-beginning 0)))) - (match-string-no-properties 0))) - -(defun mh-mail-header-end () - "Substitute for `mail-header-end' that doesn't widen the buffer. - -In MH-E we frequently need to find the end of headers in nested -messages, where the buffer has been narrowed. This function works -in this situation." - (save-excursion - ;; XXX: The following replaces a call to rfc822-goto-eoh. Occasionally, - ;; mail headers that MH-E has to read contains lines of the form: - ;; From xxx@yyy Mon May 10 11:48:07 2004 - ;; In this situation, rfc822-goto-eoh doesn't go to the end of the - ;; header. The replacement allows From_ lines in the mail header. - (goto-char (point-min)) - (loop for p = (re-search-forward - "^\\([:\n]\\|[^: \t\n]+[ \t\n]\\)" nil 'move) - do (cond ((null p) (return)) - (t (goto-char (match-beginning 0)) - (unless (looking-at "From ") (return)) - (goto-char p)))) - (point))) - -(defun mh-in-header-p () - "Return non-nil if the point is in the header of a draft message." - (< (point) (mh-mail-header-end))) - -(defun mh-header-field-beginning () - "Move to the beginning of the current header field. -Handles RFC 822 continuation lines." - (beginning-of-line) - (while (looking-at "^[ \t]") - (forward-line -1))) - -(defun mh-header-field-end () - "Move to the end of the current header field. -Handles RFC 822 continuation lines." - (forward-line 1) - (while (looking-at "^[ \t]") - (forward-line 1)) - (backward-char 1)) ;to end of previous line - -(defun mh-letter-header-font-lock (limit) - "Return the entire mail header to font-lock. -Argument LIMIT limits search." - (if (= (point) limit) - nil - (let* ((mail-header-end (save-match-data (mh-mail-header-end))) - (lesser-limit (if (< mail-header-end limit) mail-header-end limit))) - (when (mh-in-header-p) - (set-match-data (list 1 lesser-limit)) - (goto-char lesser-limit) - t)))) - -(defun mh-header-field-font-lock (field limit) - "Return the value of a header field FIELD to font-lock. -Argument LIMIT limits search." - (if (= (point) limit) - nil - (let* ((mail-header-end (mh-mail-header-end)) - (lesser-limit (if (< mail-header-end limit) mail-header-end limit)) - (case-fold-search t)) - (when (and (< (point) mail-header-end) ;Only within header - (re-search-forward (format "^%s" field) lesser-limit t)) - (let ((match-one-b (match-beginning 0)) - (match-one-e (match-end 0))) - (mh-header-field-end) - (if (> (point) limit) ;Don't search for end beyond limit - (goto-char limit)) - (set-match-data (list match-one-b match-one-e - (1+ match-one-e) (point))) - 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)) - -(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)) - (mh-header-to-font-lock - (0 'default) - (1 'mh-show-to)) - (mh-header-cc-font-lock - (0 'default) - (1 'mh-show-cc)) - ("^\\(Reply-To:\\|Return-Path:\\)\\(.*\\)$" - (1 'default) - (2 'mh-show-from)) - (mh-header-subject-font-lock - (0 'default) - (1 'mh-show-subject)) - ("^\\(Apparently-To:\\|Newsgroups:\\)\\(.*\\)" - (1 'default) - (2 'mh-show-cc)) - ("^\\(In-reply-to\\|Date\\):\\(.*\\)$" - (1 'default) - (2 'mh-show-date)) - (mh-letter-header-font-lock - (0 'mh-show-header append t))) - "Additional expressions to highlight in MH-Show buffers.")) - -(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 buffers.") - -(defvar mh-letter-font-lock-keywords - `(,@mh-show-font-lock-keywords-with-cite - (mh-font-lock-field-data - (1 'mh-letter-header-field prepend t))) - "Additional expressions to highlight in MH-Letter buffers.") - -(defun mh-show-font-lock-fontify-region (beg end loudly) - "Limit font-lock in `mh-show-mode' to the header. - -Used when the option `mh-highlight-citation-style' 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 (mh-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)))) - -;; Shush compiler. -(if mh-xemacs-flag - (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) - ;; 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: - -(defvar mh-user-path nil - "Cached value of the \"Path:\" MH profile component. -User's mail folder directory.") - -(defvar mh-draft-folder nil - "Cached value of the \"Draft-Folder:\" MH profile component. -Name of folder containing draft messages. -Nil means do not use a draft folder.") - -(defvar mh-unseen-seq nil - "Cached value of the \"Unseen-Sequence:\" MH profile component. -Name of the Unseen sequence.") +;;; General Utilities -(defvar mh-previous-seq nil - "Cached value of the \"Previous-Sequence:\" MH profile component. -Name of the Previous sequence.") +(require 'mailabbrev nil t) +(mh-defun-compat mail-abbrev-make-syntax-table () + "Emacs 21 and XEmacs don't have this function." + nil) -(defvar mh-inbox nil - "Cached value of the \"Inbox:\" MH profile component. -Set to \"+inbox\" if no such component. -Name of the Inbox folder.") - -(defvar mh-previous-window-config nil - "Window configuration before MH-E command.") +;;;###mh-autoload +(defun mh-beginning-of-word (&optional n) + "Return position of the N th word backwards." + (unless n (setq n 1)) + (let ((syntax-table (syntax-table))) + (unwind-protect + (save-excursion + (mail-abbrev-make-syntax-table) + (set-syntax-table mail-abbrev-syntax-table) + (backward-word n) + (point)) + (set-syntax-table syntax-table)))) + +;;;###mh-autoload +(defun mh-colors-available-p () + "Check if colors are available in the Emacs being used." + (or mh-xemacs-flag + (let ((color-cells (display-color-cells))) + (and (numberp color-cells) (>= color-cells 8))))) + +;;;###mh-autoload +(defun mh-colors-in-use-p () + "Check if colors are being used in the folder buffer." + (and mh-colors-available-flag font-lock-mode)) + +;;;###mh-autoload +(defun mh-delete-line (lines) + "Delete the next LINES lines." + (delete-region (point) (progn (forward-line lines) (point)))) -(defvar mh-page-to-next-msg-flag nil - "Non-nil means next SPC or whatever goes to next undeleted message.") +(defvar mh-image-load-path-called-flag nil) + +;;;###mh-autoload +(defun mh-image-load-path () + "Ensure that the MH-E images are accessible by `find-image'. +Images for MH-E are found in ../../etc/images relative to the +files in \"lisp/mh-e\". If `image-load-path' exists (since Emacs +22), then the images directory is added to it if isn't already +there. Otherwise, the images directory is added to the +`load-path' if it isn't already there." + (unless mh-image-load-path-called-flag + (let (mh-library-name mh-image-load-path) + ;; First, find mh-e in the load-path. + (setq mh-library-name (locate-library "mh-e")) + (if (not mh-library-name) + (error "Can not find MH-E in load-path")) + (setq mh-image-load-path + (expand-file-name (concat (file-name-directory mh-library-name) + "../../etc/images"))) + (if (not (file-exists-p mh-image-load-path)) + (error "Can not find image directory %s" mh-image-load-path)) + (if (boundp 'image-load-path) + (add-to-list 'image-load-path mh-image-load-path) + (add-to-list 'load-path mh-image-load-path))) + (setq mh-image-load-path-called-flag t))) + +;;;###mh-autoload +(defun mh-make-local-vars (&rest pairs) + "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))))) + +;;;###mh-autoload +(defun mh-mapc (function list) + "Apply FUNCTION to each element of LIST for side effects only." + (while list + (funcall function (car list)) + (setq list (cdr list)))) + +;;;###mh-autoload +(defun mh-replace-string (old new) + "Replace all occurrences of OLD with NEW in the current buffer. +Ignores case when searching for OLD." + (goto-char (point-min)) + (let ((case-fold-search t)) + (while (search-forward old nil t) + (replace-match new t t)))) -;;; Internal variables local to a folder. - -(defvar mh-current-folder nil - "Name of current folder, a string.") - -(defvar mh-show-buffer nil - "Buffer that displays message for this folder.") - -(defvar mh-folder-filename nil - "Full path of directory for this folder.") - -(defvar mh-msg-count nil - "Number of msgs in buffer.") - -(defvar mh-showing-mode nil - "If non-nil, show the message in a separate window.") - -(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.") +;;; Logo Display (defvar mh-logo-cache nil) +;;;###mh-autoload (defun mh-logo-display () "Modify mode line to display MH-E logo." + (mh-image-load-path) (mh-do-in-gnu-emacs (add-text-properties 0 2 @@ -569,1474 +162,223 @@ Name of the Inbox folder.") (cons modeline-buffer-id-left-extent "XEmacs%N:")) (cons modeline-buffer-id-right-extent " %17b"))))) -(defun mh-showing-mode (&optional arg) - "Change whether messages should be displayed. + -With ARG, display messages iff ARG is positive." - (setq mh-showing-mode - (if (null arg) - (not mh-showing-mode) - (> (prefix-numeric-value arg) 0)))) +;;; Read MH Profile + +(defvar mh-find-path-run nil + "Non-nil if `mh-find-path' has been run already. +Do not access this variable; `mh-find-path' already uses it to +avoid running more than once.") + +;;;###mh-autoload +(defun mh-find-path () + "Set variables from user's MH profile. + +This function sets `mh-user-path' from your \"Path:\" MH profile +component (but defaults to \"Mail\" if one isn't present), +`mh-draft-folder' from \"Draft-Folder:\", `mh-unseen-seq' from +\"Unseen-Sequence:\", `mh-previous-seq' from +\"Previous-Sequence:\", and `mh-inbox' from \"Inbox:\" (defaults +to \"+inbox\"). + +The hook `mh-find-path-hook' is run after these variables have +been set. This hook can be used the change the value of these +variables if you need to run with different values between MH and +MH-E." + (unless mh-find-path-run + ;; Sanity checks. + (if (and (getenv "MH") + (not (file-readable-p (getenv "MH")))) + (error "MH environment variable contains unreadable file %s" + (getenv "MH"))) + (if (null (mh-variants)) + (error "Install MH and run install-mh before running MH-E")) + (let ((profile "~/.mh_profile")) + (if (not (file-readable-p profile)) + (error "Run install-mh before running MH-E"))) + ;; Read MH profile. + (setq mh-user-path (mh-profile-component "Path")) + (if (not mh-user-path) + (setq mh-user-path "Mail")) + (setq mh-user-path + (file-name-as-directory + (expand-file-name mh-user-path (expand-file-name "~")))) + (mh-set-x-image-cache-directory (expand-file-name ".mhe-x-image-cache" + mh-user-path)) + (setq mh-draft-folder (mh-profile-component "Draft-Folder")) + (if mh-draft-folder + (progn + (if (not (mh-folder-name-p mh-draft-folder)) + (setq mh-draft-folder (format "+%s" mh-draft-folder))) + (if (not (file-exists-p (mh-expand-file-name mh-draft-folder))) + (error + "Draft folder \"%s\" not found; create it and try again" + (mh-expand-file-name mh-draft-folder))))) + (setq mh-inbox (mh-profile-component "Inbox")) + (cond ((not mh-inbox) + (setq mh-inbox "+inbox")) + ((not (mh-folder-name-p mh-inbox)) + (setq mh-inbox (format "+%s" mh-inbox)))) + (setq mh-unseen-seq (mh-profile-component "Unseen-Sequence")) + (if mh-unseen-seq + (setq mh-unseen-seq (intern mh-unseen-seq)) + (setq mh-unseen-seq 'unseen)) ;old MH default? + (setq mh-previous-seq (mh-profile-component "Previous-Sequence")) + (if mh-previous-seq + (setq mh-previous-seq (intern mh-previous-seq))) + (run-hooks 'mh-find-path-hook) + (mh-collect-folder-names) + (setq mh-find-path-run t))) -(defvar mh-seq-list nil - "Alist of this folder's sequences. -Elements have the form (SEQUENCE . MESSAGES).") + -(defvar mh-seen-list nil - "List of displayed messages to be removed from the \"Unseen\" sequence.") +;;; Help Functions -(defvar mh-showing-with-headers nil - "If non-nil, MH-Show buffer contains message with all header fields. -If nil, MH-Show buffer contains message processed normally.") +;;;###mh-autoload +(defun mh-ephem-message (string) + "Display STRING in the minibuffer momentarily." + (message "%s" string) + (sit-for 5) + (message "")) - +(defvar mh-help-default nil + "Mode to use if messages are not present for the current mode.") -;;; MH-E macros - -(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) - (buffer-file-name nil)) ;don't let the buffer get locked - (prog1 - (progn - ,@body) - (mh-set-folder-modified-p mh-folder-updating-mod-flag))) - ,@(if (not save-modification-flag) - '((mh-set-folder-modified-p nil))))) - -(put 'with-mh-folder-updating 'lisp-indent-hook 'defun) - -(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'." - (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-flag (bury-buffer (current-buffer))) - (unwind-protect - (progn - ,@body) - (select-window mh-in-show-buffer-saved-window)))) - -(put 'mh-in-show-buffer 'lisp-indent-hook 'defun) - -(defmacro mh-do-at-event-location (event &rest body) - "Switch to the location of EVENT and execute BODY. -After BODY has been executed return to original window. The -modification flag of the buffer in the event window is -preserved." - (let ((event-window (make-symbol "event-window")) - (event-position (make-symbol "event-position")) - (original-window (make-symbol "original-window")) - (original-position (make-symbol "original-position")) - (modified-flag (make-symbol "modified-flag"))) - `(save-excursion - (let* ((,event-window - (or (mh-funcall-if-exists posn-window (event-start ,event)) - (mh-funcall-if-exists event-window ,event))) - (,event-position - (or (mh-funcall-if-exists posn-point (event-start ,event)) - (mh-funcall-if-exists event-closest-point ,event))) - (,original-window (selected-window)) - (,original-position (progn - (set-buffer (window-buffer ,event-window)) - (set-marker (make-marker) (point)))) - (,modified-flag (buffer-modified-p)) - (buffer-read-only nil)) - (unwind-protect (progn - (select-window ,event-window) - (goto-char ,event-position) - ,@body) - (set-buffer-modified-p ,modified-flag) - (goto-char ,original-position) - (set-marker ,original-position nil) - (select-window ,original-window)))))) - -(put 'mh-do-at-event-location 'lisp-indent-hook 'defun) - -(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)) +(defvar mh-help-messages nil + "Help messages for all modes. +This is an alist of alists. The primary key is a symbol +representing the mode; the value is described in `mh-set-help'.") + +;;;###mh-autoload +(defun mh-set-help (messages &optional default) + "Set help messages. + +The MESSAGES are assumed to be an associative array. It is used +to show help for the most common commands in the current mode. +The key is a prefix char. The value is one or more strings which +are concatenated together and displayed in a help buffer 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. + +If optional argument DEFAULT is non-nil, then these messages will +be used if help is asked for an unknown mode." + (add-to-list 'mh-help-messages (cons major-mode messages)) + (if default + (setq mh-help-default major-mode))) + +;;;###mh-autoload +(defun mh-help (&optional help-messages) + "Display cheat sheet for the MH-E commands. +See `mh-set-help' for setting the help messages. +HELP-MESSAGES are used instead if given. +This is a list of one or more strings which are concatenated together +and displayed in a help buffer." + (interactive) + (let* ((help (or help-messages + (cdr (assoc nil (assoc major-mode mh-help-messages))))) + (text (substitute-command-keys (mapconcat 'identity help "")))) + (with-electric-help + (function + (lambda () + (insert text))) + mh-help-buffer))) + +;;;###mh-autoload +(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))) + (help (cdr (assoc prefix-char (assoc major-mode mh-help-messages))))) + (mh-help help))) + + +;;; Message Number Utilities + +;;;###mh-autoload +(defun mh-coalesce-msg-list (messages) + "Given a list of MESSAGES, return a list of message number ranges. +This is the inverse of `mh-read-msg-list', which expands ranges. +Message lists passed to MH programs should be processed by this +function to avoid exceeding system command line argument limits." + (let ((msgs (sort (copy-sequence messages) 'mh-greaterp)) + (range-high nil) + (prev -1) + (ranges nil)) + (while prev + (if range-high + (if (or (not (numberp prev)) + (not (equal (car msgs) (1- prev)))) + (progn ;non-sequential, flush old range + (if (eq prev range-high) + (setq ranges (cons range-high ranges)) + (setq ranges (cons (format "%s-%s" prev range-high) ranges))) + (setq range-high nil)))) + (or range-high + (setq range-high (car msgs))) ;start new or first range + (setq prev (car msgs)) + (setq msgs (cdr msgs))) + ranges)) + +(defun mh-greaterp (msg1 msg2) + "Return the greater of two message indicators MSG1 and MSG2. +Strings are \"smaller\" than numbers. +Valid values are things like \"cur\", \"last\", 1, and 1820." + (if (numberp msg1) + (if (numberp msg2) + (> msg1 msg2) + t) + (if (numberp msg2) + nil + (string-lessp msg2 msg1)))) + +;;;###mh-autoload +(defun mh-lessp (msg1 msg2) + "Return the lesser of two message indicators MSG1 and MSG2. +Strings are \"smaller\" than numbers. +Valid values are things like \"cur\", \"last\", 1, and 1820." + (not (mh-greaterp msg1 msg2))) + +;;;###mh-autoload (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) + (cond ((looking-at (mh-scan-msg-number-regexp)) (string-to-number (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) - (mh-funcall-if-exists deactivate-mark) - (unwind-protect - (prog1 (call-interactively (function ,original-function)) - (setq normal-exit t)) - (mh-funcall-if-exists deactivate-mark) - (when (eq major-mode 'mh-folder-mode) - (mh-funcall-if-exists hl-line-highlight)) - (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-or-thread - mh-delete-subject-or-thread) -(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-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-narrow-to-from mh-narrow-to-from) -(mh-defun-show-buffer mh-show-narrow-to-cc mh-narrow-to-cc) -(mh-defun-show-buffer mh-show-narrow-to-range mh-narrow-to-range) -(mh-defun-show-buffer mh-show-narrow-to-to mh-narrow-to-to) -(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-thread-delete mh-thread-delete) -(mh-defun-show-buffer mh-show-thread-refile mh-thread-refile) -(mh-defun-show-buffer mh-show-update-sequences mh-update-sequences) -(mh-defun-show-buffer mh-show-next-unread-msg mh-next-unread-msg) -(mh-defun-show-buffer mh-show-previous-unread-msg mh-previous-unread-msg) -(mh-defun-show-buffer mh-show-thread-ancestor mh-thread-ancestor) -(mh-defun-show-buffer mh-show-thread-next-sibling mh-thread-next-sibling) -(mh-defun-show-buffer mh-show-thread-previous-sibling - mh-thread-previous-sibling) -(mh-defun-show-buffer mh-show-index-visit-folder mh-index-visit-folder t) -(mh-defun-show-buffer mh-show-toggle-tick mh-toggle-tick) -(mh-defun-show-buffer mh-show-narrow-to-tick mh-narrow-to-tick) -(mh-defun-show-buffer mh-show-junk-blacklist mh-junk-blacklist) -(mh-defun-show-buffer mh-show-junk-whitelist mh-junk-whitelist) -(mh-defun-show-buffer mh-show-index-new-messages mh-index-new-messages) -(mh-defun-show-buffer mh-show-index-ticked-messages mh-index-ticked-messages) -(mh-defun-show-buffer mh-show-index-sequenced-messages - mh-index-sequenced-messages) -(mh-defun-show-buffer mh-show-catchup mh-catchup) -(mh-defun-show-buffer mh-show-ps-print-toggle-color mh-ps-print-toggle-color) -(mh-defun-show-buffer mh-show-ps-print-toggle-faces mh-ps-print-toggle-faces) -(mh-defun-show-buffer mh-show-ps-print-msg-file mh-ps-print-msg-file) -(mh-defun-show-buffer mh-show-ps-print-msg mh-ps-print-msg) -(mh-defun-show-buffer mh-show-toggle-mime-buttons mh-toggle-mime-buttons) -(mh-defun-show-buffer mh-show-display-with-external-viewer - mh-display-with-external-viewer) - - - -;;; Build mh-show-mode keymaps - -(gnus-define-keys mh-show-mode-map - " " mh-show-page-msg - "!" mh-show-refile-or-write-again - "'" mh-show-toggle-tick - "," 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-or-thread - "m" mh-show-send - "n" mh-show-next-undeleted-msg - "\M-n" mh-show-next-unread-msg - "o" mh-show-refile-msg - "p" mh-show-previous-undeleted-msg - "\M-p" mh-show-previous-unread-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 - "v" mh-show-index-visit-folder - "|" mh-show-pipe-msg) - -(gnus-define-keys (mh-show-folder-map "F" mh-show-mode-map) - "?" mh-prefix-help - "'" mh-index-ticked-messages - "S" mh-show-sort-folder - "c" mh-show-catchup - "f" mh-show-visit-folder - "k" mh-show-kill-folder - "l" mh-show-list-folders - "n" mh-index-new-messages - "o" mh-show-visit-folder - "q" mh-show-index-sequenced-messages - "r" mh-show-rescan-folder - "s" mh-search - "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-show-narrow-to-tick - "?" 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) - -(define-key mh-show-mode-map "I" mh-inc-spool-map) - -(gnus-define-keys (mh-show-junk-map "J" mh-show-mode-map) - "?" mh-prefix-help - "b" mh-show-junk-blacklist - "w" mh-show-junk-whitelist) - -(gnus-define-keys (mh-show-ps-print-map "P" mh-show-mode-map) - "?" mh-prefix-help - "C" mh-show-ps-print-toggle-color - "F" mh-show-ps-print-toggle-faces - "f" mh-show-ps-print-msg-file - "l" mh-show-print-msg - "p" mh-show-ps-print-msg) - -(gnus-define-keys (mh-show-thread-map "T" mh-show-mode-map) - "?" mh-prefix-help - "u" mh-show-thread-ancestor - "p" mh-show-thread-previous-sibling - "n" mh-show-thread-next-sibling - "t" mh-show-toggle-threads - "d" mh-show-thread-delete - "o" mh-show-thread-refile) - -(gnus-define-keys (mh-show-limit-map "/" mh-show-mode-map) - "'" mh-show-narrow-to-tick - "?" mh-prefix-help - "c" mh-show-narrow-to-cc - "g" mh-show-narrow-to-range - "m" mh-show-narrow-to-from - "s" mh-show-narrow-to-subject - "t" mh-show-narrow-to-to - "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 - "e" mh-show-display-with-external-viewer - "v" mh-show-toggle-mime-part - "o" mh-show-save-mime-part - "i" mh-show-inline-mime-part - "t" mh-show-toggle-mime-buttons - "\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] - ["Narrow to Tick Sequence" mh-show-narrow-to-tick - (save-excursion - (set-buffer mh-show-folder-buffer) - (and mh-tick-seq (mh-seq-msgs (mh-find-seq mh-tick-seq))))] - ["Delete Rest of Same Subject" mh-show-delete-subject t] - ["Toggle Tick Mark" mh-show-toggle-tick t] - "--" - ["Push State Out to MH" mh-show-update-sequences t])) - -(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] - ["View New Messages" mh-show-index-new-messages t] - ["Search..." mh-search t] - "--" - ["Quit MH-E" mh-quit t])) - -;; Ensure new buffers won't get this mode if default-major-mode is nil. -(put 'mh-show-mode 'mode-class 'special) - -;; Shush compiler. -(eval-when-compile (defvar font-lock-auto-fontify)) - -(define-derived-mode mh-show-mode text-mode "MH-Show" - "Major mode for showing messages in MH-E.\\<mh-show-mode-map> - -The hook `mh-show-mode-hook' is called upon entry to this mode. - -See also `mh-folder-mode'. - -\\{mh-show-mode-map}" - (set (make-local-variable 'mail-header-separator) mh-mail-header-separator) - (setq paragraph-start (default-value 'paragraph-start)) - (mh-show-unquote-From) - (mh-show-xface) - (mh-show-addr) - (setq buffer-invisibility-spec '((vanish . t) t)) - (set (make-local-variable 'line-move-ignore-invisible) t) - (make-local-variable 'font-lock-defaults) - ;;(set (make-local-variable 'font-lock-support-mode) nil) - (cond - ((equal mh-highlight-citation-style 'font-lock) - (setq font-lock-defaults '(mh-show-font-lock-keywords-with-cite t))) - ((equal mh-highlight-citation-style 'gnus) - (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)))) - (if (and mh-xemacs-flag - font-lock-auto-fontify) - (turn-on-font-lock)) - (set (make-local-variable 'tool-bar-map) mh-show-tool-bar-map) - (mh-funcall-if-exists mh-tool-bar-init :show) - (when mh-decode-mime-flag - (mh-make-local-hook 'kill-buffer-hook) - (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)) - -(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)))) - - - -;; X-Face and Face display -(defvar mh-show-xface-function - (cond ((and mh-xemacs-flag (locate-library "x-face") (not (featurep 'xface))) - (load "x-face" t t) - #'mh-face-display-function) - ((>= emacs-major-version 21) - #'mh-face-display-function) - (t #'ignore)) - "Determine at run time what function should be called to display X-Face.") - -(defvar mh-uncompface-executable - (and (fboundp 'executable-find) (executable-find "uncompface"))) - -(defun mh-face-to-png (data) - "Convert base64 encoded DATA to png image." - (with-temp-buffer - (insert data) - (ignore-errors (base64-decode-region (point-min) (point-max))) - (buffer-string))) - -(defun mh-uncompface (data) - "Run DATA through `uncompface' to generate bitmap." - (with-temp-buffer - (insert data) - (when (and mh-uncompface-executable - (equal (call-process-region (point-min) (point-max) - mh-uncompface-executable t '(t nil)) - 0)) - (mh-icontopbm) - (buffer-string)))) - -(defun mh-icontopbm () - "Elisp substitute for `icontopbm'." - (goto-char (point-min)) - (let ((end (point-max))) - (while (re-search-forward "0x\\(..\\)\\(..\\)," nil t) - (save-excursion - (goto-char (point-max)) - (insert (string-to-number (match-string 1) 16)) - (insert (string-to-number (match-string 2) 16)))) - (delete-region (point-min) end) - (goto-char (point-min)) - (insert "P4\n48 48\n"))) - -(mh-do-in-xemacs (defvar default-enable-multibyte-characters)) - -(defmacro mh-face-foreground-compat (face &optional frame inherit) - "Return the foreground color name of FACE, or nil if unspecified. -See documentation for `face-foreground' for a description of the -arguments FACE, FRAME, and INHERIT. - -Calls `face-foreground' correctly in older environments. Versions -of Emacs prior to version 22 lacked an INHERIT argument which -when t tells `face-foreground' to consider an inherited value for -the foreground if the face does not define one itself." - (if (>= emacs-major-version 22) - `(face-foreground ,face ,frame ,inherit) - `(face-foreground ,face ,frame))) - -(defmacro mh-face-background-compat (face &optional frame inherit) - "Return the background color name of face, or nil if unspecified. -See documentation for `back-foreground' for a description of the -arguments FACE, FRAME, and INHERIT. - -Calls `face-background' correctly in older environments. Versions -of Emacs prior to version 22 lacked an INHERIT argument which -when t tells `face-background' to consider an inherited value for -the background if the face does not define one itself." - (if (>= emacs-major-version 22) - `(face-background ,face ,frame ,inherit) - `(face-background ,face ,frame))) - -(defun mh-face-display-function () - "Display a Face, X-Face, or X-Image-URL header field. -If more than one of these are present, then the first one found -in this order is used." - (save-restriction - (goto-char (point-min)) - (re-search-forward "\n\n" (point-max) t) - (narrow-to-region (point-min) (point)) - (let* ((case-fold-search t) - (default-enable-multibyte-characters nil) - (face (message-fetch-field "face" t)) - (x-face (message-fetch-field "x-face" t)) - (url (message-fetch-field "x-image-url" t)) - raw type) - (cond (face (setq raw (mh-face-to-png face) - type 'png)) - (x-face (setq raw (mh-uncompface x-face) - type 'pbm)) - (url (setq type 'url)) - (t (multiple-value-setq (type raw) (mh-picon-get-image)))) - (when type - (goto-char (point-min)) - (when (re-search-forward "^from:" (point-max) t) - ;; GNU Emacs - (mh-do-in-gnu-emacs - (if (eq type 'url) - (mh-x-image-url-display url) - (mh-funcall-if-exists - insert-image (create-image - raw type t - :foreground - (mh-face-foreground-compat 'mh-show-xface nil t) - :background - (mh-face-background-compat 'mh-show-xface nil t)) - " "))) - ;; XEmacs - (mh-do-in-xemacs - (cond - ((eq type 'url) - (mh-x-image-url-display url)) - ((eq type 'png) - (when (featurep 'png) - (set-extent-begin-glyph - (make-extent (point) (point)) - (make-glyph (vector 'png ':data (mh-face-to-png face)))))) - ;; Try internal xface support if available... - ((and (eq type 'pbm) (featurep 'xface)) - (set-glyph-face - (set-extent-begin-glyph - (make-extent (point) (point)) - (make-glyph (vector 'xface ':data (concat "X-Face: " x-face)))) - 'mh-show-xface)) - ;; Otherwise try external support with x-face... - ((and (eq type 'pbm) - (fboundp 'x-face-xmas-wl-display-x-face) - (fboundp 'executable-find) (executable-find "uncompface")) - (mh-funcall-if-exists x-face-xmas-wl-display-x-face)) - ;; Picon display - ((and raw (member type '(xpm xbm gif))) - (when (featurep type) - (set-extent-begin-glyph - (make-extent (point) (point)) - (make-glyph (vector type ':data raw)))))) - (when raw (insert " ")))))))) - -(defun mh-show-xface () - "Display X-Face." - (when (and window-system mh-show-use-xface-flag - (or mh-decode-mime-flag mh-mhl-format-file - mh-clean-message-header-flag)) - (funcall mh-show-xface-function))) - - - -;;; Picon display - -;; XXX: This should be customizable. As a side-effect of setting this -;; variable, arrange to reset mh-picon-existing-directory-list to 'unset. -(defvar mh-picon-directory-list - '("~/.picons" "~/.picons/users" "~/.picons/usenix" "~/.picons/news" - "~/.picons/domains" "~/.picons/misc" - "/usr/share/picons/" "/usr/share/picons/users" "/usr/share/picons/usenix" - "/usr/share/picons/news" "/usr/share/picons/domains" - "/usr/share/picons/misc") - "List of directories where picons reside. -The directories are searched for in the order they appear in the list.") - -(defvar mh-picon-existing-directory-list 'unset - "List of directories to search in.") - -(defvar mh-picon-cache (make-hash-table :test #'equal)) - -(defvar mh-picon-image-types - (loop for type in '(xpm xbm gif) - when (or (mh-do-in-gnu-emacs - (ignore-errors - (mh-funcall-if-exists image-type-available-p type))) - (mh-do-in-xemacs (featurep type))) - collect type)) - -(defun mh-picon-set-directory-list () - "Update `mh-picon-existing-directory-list' if needed." - (when (eq mh-picon-existing-directory-list 'unset) - (setq mh-picon-existing-directory-list - (loop for x in mh-picon-directory-list - when (file-directory-p x) collect x)))) - -(defun* mh-picon-get-image () - "Find the best possible match and return contents." - (mh-picon-set-directory-list) - (save-restriction - (let* ((from-field (ignore-errors (car (message-tokenize-header - (mh-get-header-field "from:"))))) - (from (car (ignore-errors - (mh-funcall-if-exists ietf-drums-parse-address - from-field)))) - (host (and from - (string-match "\\([^+]*\\)\\(+.*\\)?@\\(.*\\)" from) - (downcase (match-string 3 from)))) - (user (and host (downcase (match-string 1 from)))) - (canonical-address (format "%s@%s" user host)) - (cached-value (gethash canonical-address mh-picon-cache)) - (host-list (and host (delete "" (split-string host "\\.")))) - (match nil)) - (cond (cached-value (return-from mh-picon-get-image cached-value)) - ((not host-list) (return-from mh-picon-get-image nil))) - (setq match - (block 'loop - ;; u@h search - (loop for dir in mh-picon-existing-directory-list - do (loop for type in mh-picon-image-types - ;; [path]user@host - for file1 = (format "%s/%s.%s" - dir canonical-address type) - when (file-exists-p file1) - do (return-from 'loop file1) - ;; [path]user - for file2 = (format "%s/%s.%s" dir user type) - when (file-exists-p file2) - do (return-from 'loop file2) - ;; [path]host - for file3 = (format "%s/%s.%s" dir host type) - when (file-exists-p file3) - do (return-from 'loop file3))) - ;; facedb search - ;; Search order for user@foo.net: - ;; [path]net/foo/user - ;; [path]net/foo/user/face - ;; [path]net/user - ;; [path]net/user/face - ;; [path]net/foo/unknown - ;; [path]net/foo/unknown/face - ;; [path]net/unknown - ;; [path]net/unknown/face - (loop for u in (list user "unknown") - do (loop for dir in mh-picon-existing-directory-list - do (loop for x on host-list by #'cdr - for y = (mh-picon-generate-path x u dir) - do (loop for type in mh-picon-image-types - for z1 = (format "%s.%s" y type) - when (file-exists-p z1) - do (return-from 'loop z1) - for z2 = (format "%s/face.%s" - y type) - when (file-exists-p z2) - do (return-from 'loop z2))))))) - (setf (gethash canonical-address mh-picon-cache) - (mh-picon-file-contents match))))) - -(defun mh-picon-file-contents (file) - "Return details about FILE. -A list of consisting of a symbol for the type of the file and the -file contents as a string is returned. If FILE is nil, then both -elements of the list are nil." - (if (stringp file) - (with-temp-buffer - (let ((type (and (string-match ".*\\.\\(...\\)$" file) - (intern (match-string 1 file))))) - (insert-file-contents-literally file) - (values type (buffer-string)))) - (values nil nil))) - -(defun mh-picon-generate-path (host-list user directory) - "Generate the image file path. -HOST-LIST is the parsed host address of the email address, USER -the username and DIRECTORY is the directory relative to which the -path is generated." - (loop with acc = "" - for elem in host-list - do (setq acc (format "%s/%s" elem acc)) - finally return (format "%s/%s%s" directory acc user))) - - - -;; X-Image-URL display - -(defvar mh-x-image-cache-directory nil - "Directory where X-Image-URL images are cached.") -(defvar mh-x-image-scaling-function - (cond ((executable-find "convert") - 'mh-x-image-scale-with-convert) - ((and (executable-find "anytopnm") (executable-find "pnmscale") - (executable-find "pnmtopng")) - 'mh-x-image-scale-with-pnm) - (t 'ignore)) - "Function to use to scale image to proper size.") -(defvar mh-wget-executable nil) -(defvar mh-wget-choice - (or (and (setq mh-wget-executable (executable-find "wget")) 'wget) - (and (setq mh-wget-executable (executable-find "fetch")) 'fetch) - (and (setq mh-wget-executable (executable-find "curl")) 'curl))) -(defvar mh-wget-option - (cdr (assoc mh-wget-choice '((curl . "-o") (fetch . "-o") (wget . "-O"))))) -(defvar mh-x-image-temp-file nil) -(defvar mh-x-image-url nil) -(defvar mh-x-image-marker nil) -(defvar mh-x-image-url-cache-file nil) - -;; Functions to scale image to proper size -(defun mh-x-image-scale-with-pnm (input output) - "Scale image in INPUT file and write to OUTPUT file using pnm tools." - (let ((res (shell-command-to-string - (format "anytopnm < %s | pnmscale -xysize 96 48 | pnmtopng > %s" - input output)))) - (unless (equal res "") - (delete-file output)))) - -(defun mh-x-image-scale-with-convert (input output) - "Scale image in INPUT file and write to OUTPUT file using ImageMagick." - (call-process "convert" nil nil nil "-geometry" "96x48" input output)) - -;; Copy of constant from url-util.el in Emacs 22; needed by Emacs 21. -(if (not (boundp 'url-unreserved-chars)) - (defconst url-unreserved-chars - '( - ?a ?b ?c ?d ?e ?f ?g ?h ?i ?j ?k ?l ?m ?n ?o ?p ?q ?r ?s ?t ?u ?v ?w ?x ?y ?z - ?A ?B ?C ?D ?E ?F ?G ?H ?I ?J ?K ?L ?M ?N ?O ?P ?Q ?R ?S ?T ?U ?V ?W ?X ?Y ?Z - ?0 ?1 ?2 ?3 ?4 ?5 ?6 ?7 ?8 ?9 - ?- ?_ ?. ?! ?~ ?* ?' ?\( ?\)) - "A list of characters that are _NOT_ reserved in the URL spec. -This is taken from RFC 2396.")) - -;; Copy of function from url-util.el in Emacs 22; needed by Emacs 21. -(mh-defun-compat url-hexify-string (str) - "Escape characters in a string." - (mapconcat - (lambda (char) - ;; Fixme: use a char table instead. - (if (not (memq char url-unreserved-chars)) - (if (> char 255) - (error "Hexifying multibyte character %s" str) - (format "%%%02X" char)) - (char-to-string char))) - str "")) - -(defun mh-x-image-url-cache-canonicalize (url) - "Canonicalize URL. -Replace the ?/ character with a ?! character and append .png. -Also replaces special characters with `url-hexify-string' since -not all characters, such as :, are legal within Windows -filenames. See URL `http://msdn.microsoft.com/library/default.asp?url=/library/en-us/fileio/fs/naming_a_file.asp'." - (format "%s/%s.png" mh-x-image-cache-directory - (url-hexify-string - (with-temp-buffer - (insert url) - (mh-replace-string "/" "!") - (buffer-string))))) - -(defun mh-x-image-set-download-state (file data) - "Setup a symbolic link from FILE to DATA." - (if data - (make-symbolic-link (symbol-name data) file t) - (delete-file file))) - -(defun mh-x-image-get-download-state (file) - "Check the state of FILE by following any symbolic links." - (unless (file-exists-p mh-x-image-cache-directory) - (call-process "mkdir" nil nil nil mh-x-image-cache-directory)) - (cond ((file-symlink-p file) - (intern (file-name-nondirectory (file-chase-links file)))) - ((not (file-exists-p file)) nil) - (t 'ok))) - -(defun mh-x-image-url-fetch-image (url cache-file marker sentinel) - "Fetch and display the image specified by URL. -After the image is fetched, it is stored in CACHE-FILE. It will -be displayed in a buffer and position specified by MARKER. The -actual display is carried out by the SENTINEL function." - (if mh-wget-executable - (let ((buffer (get-buffer-create (generate-new-buffer-name - mh-temp-fetch-buffer))) - (filename (or (mh-funcall-if-exists make-temp-file "mhe-fetch") - (expand-file-name (make-temp-name "~/mhe-fetch"))))) - (save-excursion - (set-buffer buffer) - (set (make-local-variable 'mh-x-image-url-cache-file) cache-file) - (set (make-local-variable 'mh-x-image-marker) marker) - (set (make-local-variable 'mh-x-image-temp-file) filename)) - (set-process-sentinel - (start-process "*mh-x-image-url-fetch*" buffer - mh-wget-executable mh-wget-option filename url) - sentinel)) - ;; Temporary failure - (mh-x-image-set-download-state cache-file 'try-again))) - -(defun mh-x-image-display (image marker) - "Display IMAGE at MARKER." - (save-excursion - (set-buffer (marker-buffer marker)) - (let ((buffer-read-only nil) - (default-enable-multibyte-characters nil) - (buffer-modified-flag (buffer-modified-p))) - (unwind-protect - (when (and (file-readable-p image) (not (file-symlink-p image)) - (eq marker mh-x-image-marker)) - (goto-char marker) - (mh-do-in-gnu-emacs - (mh-funcall-if-exists insert-image (create-image image 'png))) - (mh-do-in-xemacs - (when (featurep 'png) - (set-extent-begin-glyph - (make-extent (point) (point)) - (make-glyph - (vector 'png ':data (with-temp-buffer - (insert-file-contents-literally image) - (buffer-string)))))))) - (set-buffer-modified-p buffer-modified-flag))))) - -(defun mh-x-image-scale-and-display (process change) - "When the wget PROCESS terminates scale and display image. -The argument CHANGE is ignored." - (when (eq (process-status process) 'exit) - (let (marker temp-file cache-filename wget-buffer) - (save-excursion - (set-buffer (setq wget-buffer (process-buffer process))) - (setq marker mh-x-image-marker - cache-filename mh-x-image-url-cache-file - temp-file mh-x-image-temp-file)) - (cond - ;; Check if we have `convert' - ((eq mh-x-image-scaling-function 'ignore) - (message "The \"convert\" program is needed to display X-Image-URL") - (mh-x-image-set-download-state cache-filename 'try-again)) - ;; Scale fetched image - ((and (funcall mh-x-image-scaling-function temp-file cache-filename) - nil)) - ;; Attempt to display image if we have it - ((file-exists-p cache-filename) - (mh-x-image-display cache-filename marker)) - ;; We didn't find the image. Should we try to display it the next time? - (t (mh-x-image-set-download-state cache-filename 'try-again))) - (ignore-errors - (set-marker marker nil) - (delete-process process) - (kill-buffer wget-buffer) - (delete-file temp-file))))) - -(defun mh-x-image-url-sane-p (url) - "Check if URL is something sensible." - (let ((len (length url))) - (cond ((< len 5) nil) - ((not (equal (substring url 0 5) "http:")) nil) - ((> len 100) nil) - (t t)))) - -(defun mh-x-image-url-display (url) - "Display image from location URL. -If the URL isn't present in the cache then it is fetched with wget." - (let* ((cache-filename (mh-x-image-url-cache-canonicalize url)) - (state (mh-x-image-get-download-state cache-filename)) - (marker (set-marker (make-marker) (point)))) - (set (make-local-variable 'mh-x-image-marker) marker) - (cond ((not (mh-x-image-url-sane-p url))) - ((eq state 'ok) - (mh-x-image-display cache-filename marker)) - ((or (not mh-wget-executable) - (eq mh-x-image-scaling-function 'ignore))) - ((eq state 'never)) - ((not mh-fetch-x-image-url) - (set-marker marker nil)) - ((eq state 'try-again) - (mh-x-image-set-download-state cache-filename nil) - (mh-x-image-url-fetch-image url cache-filename marker - 'mh-x-image-scale-and-display)) - ((and (eq mh-fetch-x-image-url 'ask) - (not (y-or-n-p (format "Fetch %s? " url)))) - (mh-x-image-set-download-state cache-filename 'never)) - ((eq state nil) - (mh-x-image-url-fetch-image url cache-filename marker - 'mh-x-image-scale-and-display))))) +(add-to-list 'debug-ignored-errors "^Cursor not pointing to message$") -(defun mh-maybe-show (&optional msg) - "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 redisplay-flag) - "Display message\\<mh-folder-mode-map>. - -If the message under the cursor is already displayed, this command -scrolls to the beginning of the message. MH-E normally hides a lot of -the superfluous header fields that mailers add to a message, but if -you wish to see all of them, use the command \\[mh-header-display]. - -Two hooks can be used to control how messages are displayed. The -first hook, `mh-show-mode-hook', is called early on in the -process of the message display. It is usually used to perform -some action on the message's content. The second hook, -`mh-show-hook', is the last thing called after messages are -displayed. It's used to affect the behavior of MH-E in general or -when `mh-show-mode-hook' is too early. - -From a program, optional argument MESSAGE can be used to display an -alternative message. The optional argument REDISPLAY-FLAG forces the -redisplay of the message even if the show buffer was already -displaying the correct message. - -See the \"mh-show\" customization group for a litany of options that -control what displayed messages look like." - (interactive (list nil t)) - (when (or redisplay-flag - (and mh-showing-with-headers - (or mh-mhl-format-file mh-clean-message-header-flag))) - (mh-invalidate-show-buffer)) - (mh-show-msg message)) - -(defun mh-show-mouse (event) - "Move point to mouse EVENT and show message." - (interactive "e") - (mouse-set-point event) - (mh-show)) - -(defun mh-summary-height () - "Return ideal value for the variable `mh-summary-height'. -The current frame height is taken into consideration." - (or (and (fboundp 'frame-height) - (> (frame-height) 24) - (min 10 (/ (frame-height) 6))) - 4)) - -(defun mh-show-msg (msg) - "Show MSG. - -The hook `mh-show-hook' is called 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-flag nil) - (let ((folder mh-current-folder) - (folders (list mh-current-folder)) - (clean-message-header mh-clean-message-header-flag) - (show-window (get-buffer-window mh-show-buffer)) - (display-mime-buttons-flag mh-display-buttons-for-inline-parts-flag)) - (if (not (eq (next-window (minibuffer-window)) (selected-window))) - (delete-other-windows)) ; force ourself to the top window - (mh-in-show-buffer (mh-show-buffer) - (setq mh-display-buttons-for-inline-parts-flag display-mime-buttons-flag) - (if (and show-window - (equal (mh-msg-filename msg folder) buffer-file-name)) - (progn ;just back up to start - (goto-char (point-min)) - (if (not clean-message-header) - (mh-start-of-uncleaned-message))) - (mh-display-msg msg folder))) - (if (not (= (1+ (window-height)) (frame-height))) ;not horizontally split - (shrink-window (- (window-height) (or mh-summary-height - (mh-summary-height))))) - (mh-recenter nil) - ;; The following line is a nop which forces update of the scan line so - ;; that font-lock will update it (if needed)... - (mh-notate nil nil mh-cmd-note) - (if (not (memq msg mh-seen-list)) - (setq mh-seen-list (cons msg mh-seen-list))) - (when mh-update-sequences-after-mh-show-flag - (mh-update-sequences) - (when mh-index-data - (setq folders - (append (mh-index-delete-from-sequence mh-unseen-seq (list msg)) - folders))) - (when (mh-speed-flists-active-p) - (apply #'mh-speed-flists t folders))) - (run-hooks 'mh-show-hook))) - -(defun mh-modify (&optional message) - "Edit message. - -There are times when you need to edit a message. For example, you -may need to fix a broken Content-Type header field. You can do -this with this command. It displays the raw message in an -editable buffer. When you are done editing, save and kill the -buffer as you would any other. - -From a program, edit MESSAGE; nil means edit current message." - (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-show-unquote-From () - "Decode >From at beginning of lines for `mh-show-mode'." - (save-excursion - (let ((modified (buffer-modified-p)) - (case-fold-search nil) - (buffer-read-only nil)) - (goto-char (mh-mail-header-end)) - (while (re-search-forward "^>From" nil t) - (replace-match "From")) - (set-buffer-modified-p modified)))) - -(defun mh-msg-folder (folder-name) - "Return the name of the buffer for FOLDER-NAME." - folder-name) - -(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 mh-mhl-format-file) - (clean-message-header mh-clean-message-header-flag) - (invisible-headers mh-invisible-header-fields-compiled) - (visible-headers nil) - (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) - ;; Cleanup old mime handles - (mh-mime-cleanup) - (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-literally msg-filename)) - ;; 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)) - (mh-show-mode) - ;; 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))) - (mh-decode-message-header) - ;; 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) - (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))) - (mh-logo-display) - (set-buffer folder) - (setq mh-showing-with-headers nil)))))) - -(defun mh-clean-msg-header (start invisible-headers visible-headers) - "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." - ;; XXX Note that MH-E no longer supports the `mh-visible-headers' - ;; variable, so this function could be trimmed of this feature too." - (let ((case-fold-search t) - (buffer-read-only nil)) - (save-restriction - (goto-char start) - (if (search-forward "\n\n" nil 'move) - (backward-char 1)) - (narrow-to-region start (point)) - (goto-char (point-min)) - (if visible-headers - (while (< (point) (point-max)) - (cond ((looking-at visible-headers) - (forward-line 1) - (while (looking-at "[ \t]") (forward-line 1))) - (t - (mh-delete-line 1) - (while (looking-at "[ \t]") - (mh-delete-line 1))))) - (while (re-search-forward invisible-headers nil t) - (beginning-of-line) - (mh-delete-line 1) - (while (looking-at "[ \t]") - (mh-delete-line 1))))) - (let ((mh-compose-skipped-header-fields ())) - (mh-letter-hide-all-skipped-fields)) - (unlock-buffer))) - -(defun mh-delete-line (lines) - "Delete the next LINES lines." - (delete-region (point) (progn (forward-line lines) (point)))) - -(defun mh-notate (msg notation offset) - "Mark MSG with the character NOTATION at position OFFSET. -Null MSG means the message at cursor. -If NOTATION is nil then no change in the buffer occurs." - (save-excursion - (if (or (null msg) - (mh-goto-msg msg t t)) - (with-mh-folder-updating (t) - (beginning-of-line) - (forward-char offset) - (let* ((change-stack-flag - (and (equal offset - (+ mh-cmd-note mh-scan-field-destination-offset)) - (not (eq notation mh-note-seq)))) - (msg (and change-stack-flag (or msg (mh-get-msg-num nil)))) - (stack (and msg (gethash msg mh-sequence-notation-history))) - (notation (or notation (char-after)))) - (if stack - ;; The presence of the stack tells us that we don't need to - ;; notate the message, since the notation would be replaced - ;; by a sequence notation. So we will just put the notation - ;; at the bottom of the stack. If the sequence is deleted, - ;; the correct notation will be shown. - (setf (gethash msg mh-sequence-notation-history) - (reverse (cons notation (cdr (reverse stack))))) - ;; Since we don't have any sequence notations in the way, just - ;; notate the scan line. - (delete-char 1) - (insert notation)) - (when change-stack-flag - (mh-thread-update-scan-line-map msg notation offset))))))) - -(defun mh-goto-msg (number &optional no-error-if-no-message dont-show) - "Go to a message\\<mh-folder-mode-map>. - -You can enter the message NUMBER either before or after typing -\\[mh-goto-msg]. In the latter case, Emacs prompts you. - -In a program, optional non-nil second argument NO-ERROR-IF-NO-MESSAGE -means return nil instead of signaling an error if message does not -exist\; in this case, the 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)) - (let ((point (point)) - (return-value t)) - (goto-char (point-min)) - (unless (re-search-forward (format mh-scan-msg-search-regexp 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-set-folder-modified-p (flag) - "Mark current folder as modified or unmodified according to FLAG." - (set-buffer-modified-p flag)) - -(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 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-msg-num-width (folder) - "Return the width of the largest 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 mh-scan-prog 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 dont-annotate-flag) - "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. - -If DONT-ANNOTATE-FLAG is non-nil then the annotations in the -folder buffer are not updated." - (let ((entry (mh-find-seq seq)) - (internal-seq-flag (mh-internal-seq seq))) - (if (and msgs (atom msgs)) (setq msgs (list msgs))) - (if (null 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)))))) - (unless internal-flag - (mh-add-to-sequence seq msgs) - (when (not dont-annotate-flag) - (mh-iterate-on-range msg msgs - (unless (memq msg (cdr entry)) - (mh-add-sequence-notation msg internal-seq-flag))))))) - -(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)) +;;; Folder Cache and Access (defvar mh-sub-folders-cache (make-hash-table :test #'equal)) (defvar mh-current-folder-name nil) (defvar mh-flists-partial-line "") (defvar mh-flists-process nil) +;;;###mh-autoload +(defun mh-clear-sub-folders-cache () + "Clear `mh-sub-folders-cache'." + (clrhash mh-sub-folders-cache)) + ;; Initialize mh-sub-folders-cache... (defun mh-collect-folder-names () "Collect folder names by running \"folders\"." @@ -2050,17 +392,17 @@ folder buffer are not updated." PROCESS is the flists process that was run to collect folder names and the function is called when OUTPUT is available." (let ((position 0) - (prevailing-match-data (match-data)) - line-end folder) + (prevailing-match-data (match-data)) + line-end folder) (unwind-protect - (while (setq line-end (string-match "\n" output position)) - (setq folder (format "+%s%s" + (while (setq line-end (string-match "\n" output position)) + (setq folder (format "+%s%s" mh-flists-partial-line (substring output position line-end))) - (setq mh-flists-partial-line "") + (setq mh-flists-partial-line "") (unless (equal (aref folder 1) ?.) (mh-populate-sub-folders-cache folder)) - (setq position (1+ line-end))) + (setq position (1+ line-end))) (set-match-data prevailing-match-data)) (setq mh-flists-partial-line (substring output position)))) @@ -2148,6 +490,7 @@ number of sub-folders. XXX" t nil)) +;;;###mh-autoload (defun mh-folder-list (folder) "Return FOLDER and its descendents. Returns a list of strings. For example, @@ -2176,6 +519,7 @@ not be returned." (mh-folder-list (concat folder (car f))))))) folder-list)) +;;;###mh-autoload (defun mh-sub-folders (folder &optional add-trailing-slash-flag) "Find the subfolders of FOLDER. The function avoids running folders unnecessarily by caching the @@ -2244,6 +588,7 @@ directories that aren't usually mail folders are hidden." results)))) results)) +;;;###mh-autoload (defun mh-remove-from-sub-folders-cache (folder) "Remove FOLDER and its parent from `mh-sub-folders-cache'. FOLDER should be unconditionally removed from the cache. Also the @@ -2269,12 +614,33 @@ otherwise completion on +foo won't tell us about the option (setq one-ancestor-found t)))) (remhash nil mh-sub-folders-cache)))) + + +;;; Folder Utilities + +;;;###mh-autoload +(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) ?+)))) + +;;;###mh-autoload +(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))) + (defvar mh-folder-hist nil) ;; Shush compiler. -(eval-when-compile - (defvar mh-speed-folder-map) - (defvar mh-speed-flists-cache)) +(eval-when-compile (defvar mh-speed-flists-cache)) (defvar mh-allow-root-folder-flag nil "Non-nil means \"+\" is an acceptable folder name. @@ -2289,12 +655,14 @@ This variable should never be set.") (defvar mh-speed-flists-inhibit-flag nil) +;;;###mh-autoload (defun mh-speed-flists-active-p () "Check if speedbar is running with message counts enabled." (and (featurep 'mh-speed) (not mh-speed-flists-inhibit-flag) (> (hash-table-count mh-speed-flists-cache) 0))) +;;;###mh-autoload (defun mh-folder-completion-function (name predicate flag) "Programmable completion for folder names. NAME is the partial folder name that has been input. PREDICATE if @@ -2332,6 +700,12 @@ and FLAG determines whether the completion is over." ((equal path mh-user-path) nil) (t (file-exists-p path)))))))) +;; Shush compiler. +(eval-when-compile + (mh-do-in-xemacs + (defvar completion-root-regexp) + (defvar minibuffer-completing-file-name))) + (defun mh-folder-completing-read (prompt default allow-root-folder-flag) "Read folder name with PROMPT and default result DEFAULT. If ALLOW-ROOT-FOLDER-FLAG is non-nil then \"+\" is allowed to be @@ -2345,6 +719,7 @@ a folder name corresponding to `mh-user-path'." 'mh-folder-hist default)) t)) +;;;###mh-autoload (defun mh-prompt-for-folder (prompt default can-create &optional default-string allow-root-folder-flag) "Prompt for a folder name with PROMPT. @@ -2408,37 +783,90 @@ used in searching." -;;; List and string manipulation - -(defun mh-list-to-string (l) - "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))) - ((symbolp (car l)) - (setq new-list (cons (symbol-name (car l)) new-list))) - ((numberp (car l)) - (setq new-list (cons (int-to-string (car l)) new-list))) - ((equal (car l) "")) - ((stringp (car l)) (setq new-list (cons (car l) new-list))) - ((listp (car l)) - (setq new-list (nconc (mh-list-to-string-1 (car l)) - new-list))) - (t (error "Bad element in `mh-list-to-string': %s" (car l)))) - (setq l (cdr l))) - new-list)) +;;; Message Utilities -(defun mh-replace-string (old new) - "Replace all occurrences of OLD with NEW in the current buffer. -Ignores case when searching for OLD." +;; Functions that would ordinarily be in mh-letter.el that are needed +;; by mh-show.el are found here in order to prevent the loading of +;; mh-letter.el until a message is actually composed. + +;;;###mh-autoload +(defun mh-in-header-p () + "Return non-nil if the point is in the header of a draft message." + (< (point) (mh-mail-header-end))) + +;;;###mh-autoload +(defun mh-extract-from-header-value () + "Extract From: string from header." + (save-excursion + (if (not (mh-goto-header-field "From:")) + nil + (skip-chars-forward " \t") + (buffer-substring-no-properties + (point) (progn (mh-header-field-end)(point)))))) + +;;;###mh-autoload +(defun mh-goto-header-field (field) + "Move to FIELD in the message header. +Move to the end of the FIELD name, which should end in a colon. +Returns t if found, nil if not." (goto-char (point-min)) - (let ((case-fold-search t)) - (while (search-forward old nil t) - (replace-match new t t)))) + (let ((case-fold-search t) + (headers-end (save-excursion + (mh-goto-header-end 0) + (point)))) + (re-search-forward (format "^%s" field) headers-end t))) + +;;;###mh-autoload +(defun mh-goto-header-end (arg) + "Move the cursor ARG lines after the header." + (if (re-search-forward "^-*$" nil nil) + (forward-line arg))) + +;;;###mh-autoload +(defun mh-mail-header-end () + "Substitute for `mail-header-end' that doesn't widen the buffer. + +In MH-E we frequently need to find the end of headers in nested +messages, where the buffer has been narrowed. This function works +in this situation." + (save-excursion + ;; XXX: The following replaces a call to rfc822-goto-eoh. Occasionally, + ;; mail headers that MH-E has to read contains lines of the form: + ;; From xxx@yyy Mon May 10 11:48:07 2004 + ;; In this situation, rfc822-goto-eoh doesn't go to the end of the + ;; header. The replacement allows From_ lines in the mail header. + (goto-char (point-min)) + (loop for p = (re-search-forward + "^\\([:\n]\\|[^: \t\n]+[ \t\n]\\)" nil 'move) + do (cond ((null p) (return)) + (t (goto-char (match-beginning 0)) + (unless (looking-at "From ") (return)) + (goto-char p)))) + (point))) + +;;;###mh-autoload +(defun mh-header-field-beginning () + "Move to the beginning of the current header field. +Handles RFC 822 continuation lines." + (beginning-of-line) + (while (looking-at "^[ \t]") + (forward-line -1))) + +;;;###mh-autoload +(defun mh-header-field-end () + "Move to the end of the current header field. +Handles RFC 822 continuation lines." + (forward-line 1) + (while (looking-at "^[ \t]") + (forward-line 1)) + (backward-char 1)) ;to end of previous line + +;;;###mh-autoload +(defun mh-signature-separator-p () + "Return non-nil if buffer includes \"^-- $\"." + (save-excursion + (goto-char (point-min)) + (re-search-forward mh-signature-separator-regexp nil t))) (provide 'mh-utils) diff --git a/lisp/mh-e/mh-xface.el b/lisp/mh-e/mh-xface.el new file mode 100644 index 00000000000..12e59bf3b48 --- /dev/null +++ b/lisp/mh-e/mh-xface.el @@ -0,0 +1,528 @@ +;;; mh-xface.el --- MH-E X-Face and Face header field display + +;; Copyright (C) 2002, 2003, 2005, 2006 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., 51 Franklin Street, Fifth Floor, +;; Boston, MA 02110-1301, USA. + +;;; Commentary: + +;;; Change Log: + +;;; Code: + +(require 'mh-e) +(mh-require-cl) + +(autoload 'message-fetch-field "message") + +(defvar mh-show-xface-function + (cond ((and mh-xemacs-flag (locate-library "x-face") (not (featurep 'xface))) + (load "x-face" t t) + #'mh-face-display-function) + ((>= emacs-major-version 21) + #'mh-face-display-function) + (t #'ignore)) + "Determine at run time what function should be called to display X-Face.") + +(defvar mh-uncompface-executable + (and (fboundp 'executable-find) (executable-find "uncompface"))) + + + +;;; X-Face Display + +;;;###mh-autoload +(defun mh-show-xface () + "Display X-Face." + (when (and window-system mh-show-use-xface-flag + (or mh-decode-mime-flag mh-mhl-format-file + mh-clean-message-header-flag)) + (funcall mh-show-xface-function))) + +(defmacro mh-face-foreground-compat (face &optional frame inherit) + "Return the foreground color name of FACE, or nil if unspecified. +See documentation for `face-foreground' for a description of the +arguments FACE, FRAME, and INHERIT. + +Calls `face-foreground' correctly in older environments. Versions +of Emacs prior to version 22 lacked an INHERIT argument which +when t tells `face-foreground' to consider an inherited value for +the foreground if the face does not define one itself." + (if (>= emacs-major-version 22) + `(face-foreground ,face ,frame ,inherit) + `(face-foreground ,face ,frame))) + +(defmacro mh-face-background-compat(face &optional frame inherit) + "Return the background color name of face, or nil if unspecified. +See documentation for `back-foreground' for a description of the +arguments FACE, FRAME, and INHERIT. + +Calls `face-background' correctly in older environments. Versions +of Emacs prior to version 22 lacked an INHERIT argument which +when t tells `face-background' to consider an inherited value for +the background if the face does not define one itself." + (if (>= emacs-major-version 22) + `(face-background ,face ,frame ,inherit) + `(face-background ,face ,frame))) + +;; Shush compiler. +(eval-when-compile + (mh-do-in-xemacs (defvar default-enable-multibyte-characters))) + +(defun mh-face-display-function () + "Display a Face, X-Face, or X-Image-URL header field. +If more than one of these are present, then the first one found +in this order is used." + (save-restriction + (goto-char (point-min)) + (re-search-forward "\n\n" (point-max) t) + (narrow-to-region (point-min) (point)) + (let* ((case-fold-search t) + (default-enable-multibyte-characters nil) + (face (message-fetch-field "face" t)) + (x-face (message-fetch-field "x-face" t)) + (url (message-fetch-field "x-image-url" t)) + raw type) + (cond (face (setq raw (mh-face-to-png face) + type 'png)) + (x-face (setq raw (mh-uncompface x-face) + type 'pbm)) + (url (setq type 'url)) + (t (multiple-value-setq (type raw) (mh-picon-get-image)))) + (when type + (goto-char (point-min)) + (when (re-search-forward "^from:" (point-max) t) + ;; GNU Emacs + (mh-do-in-gnu-emacs + (if (eq type 'url) + (mh-x-image-url-display url) + (mh-funcall-if-exists + insert-image (create-image + raw type t + :foreground + (mh-face-foreground-compat 'mh-show-xface nil t) + :background + (mh-face-background-compat 'mh-show-xface nil t)) + " "))) + ;; XEmacs + (mh-do-in-xemacs + (cond + ((eq type 'url) + (mh-x-image-url-display url)) + ((eq type 'png) + (when (featurep 'png) + (set-extent-begin-glyph + (make-extent (point) (point)) + (make-glyph (vector 'png ':data (mh-face-to-png face)))))) + ;; Try internal xface support if available... + ((and (eq type 'pbm) (featurep 'xface)) + (set-glyph-face + (set-extent-begin-glyph + (make-extent (point) (point)) + (make-glyph (vector 'xface ':data (concat "X-Face: " x-face)))) + 'mh-show-xface)) + ;; Otherwise try external support with x-face... + ((and (eq type 'pbm) + (fboundp 'x-face-xmas-wl-display-x-face) + (fboundp 'executable-find) (executable-find "uncompface")) + (mh-funcall-if-exists x-face-xmas-wl-display-x-face)) + ;; Picon display + ((and raw (member type '(xpm xbm gif))) + (when (featurep type) + (set-extent-begin-glyph + (make-extent (point) (point)) + (make-glyph (vector type ':data raw)))))) + (when raw (insert " ")))))))) + +(defun mh-face-to-png (data) + "Convert base64 encoded DATA to png image." + (with-temp-buffer + (insert data) + (ignore-errors (base64-decode-region (point-min) (point-max))) + (buffer-string))) + +(defun mh-uncompface (data) + "Run DATA through `uncompface' to generate bitmap." + (with-temp-buffer + (insert data) + (when (and mh-uncompface-executable + (equal (call-process-region (point-min) (point-max) + mh-uncompface-executable t '(t nil)) + 0)) + (mh-icontopbm) + (buffer-string)))) + +(defun mh-icontopbm () + "Elisp substitute for `icontopbm'." + (goto-char (point-min)) + (let ((end (point-max))) + (while (re-search-forward "0x\\(..\\)\\(..\\)," nil t) + (save-excursion + (goto-char (point-max)) + (insert (string-to-number (match-string 1) 16)) + (insert (string-to-number (match-string 2) 16)))) + (delete-region (point-min) end) + (goto-char (point-min)) + (insert "P4\n48 48\n"))) + + + +;;; Picon Display + +;; XXX: This should be customizable. As a side-effect of setting this +;; variable, arrange to reset mh-picon-existing-directory-list to 'unset. +(defvar mh-picon-directory-list + '("~/.picons" "~/.picons/users" "~/.picons/usenix" "~/.picons/news" + "~/.picons/domains" "~/.picons/misc" + "/usr/share/picons/" "/usr/share/picons/users" "/usr/share/picons/usenix" + "/usr/share/picons/news" "/usr/share/picons/domains" + "/usr/share/picons/misc") + "List of directories where picons reside. +The directories are searched for in the order they appear in the list.") + +(defvar mh-picon-existing-directory-list 'unset + "List of directories to search in.") + +(defvar mh-picon-cache (make-hash-table :test #'equal)) + +(defvar mh-picon-image-types + (loop for type in '(xpm xbm gif) + when (or (mh-do-in-gnu-emacs + (ignore-errors + (mh-funcall-if-exists image-type-available-p type))) + (mh-do-in-xemacs (featurep type))) + collect type)) + +(autoload 'message-tokenize-header "sendmail") + +(defun* mh-picon-get-image () + "Find the best possible match and return contents." + (mh-picon-set-directory-list) + (save-restriction + (let* ((from-field (ignore-errors (car (message-tokenize-header + (mh-get-header-field "from:"))))) + (from (car (ignore-errors + (mh-funcall-if-exists ietf-drums-parse-address + from-field)))) + (host (and from + (string-match "\\([^+]*\\)\\(+.*\\)?@\\(.*\\)" from) + (downcase (match-string 3 from)))) + (user (and host (downcase (match-string 1 from)))) + (canonical-address (format "%s@%s" user host)) + (cached-value (gethash canonical-address mh-picon-cache)) + (host-list (and host (delete "" (split-string host "\\.")))) + (match nil)) + (cond (cached-value (return-from mh-picon-get-image cached-value)) + ((not host-list) (return-from mh-picon-get-image nil))) + (setq match + (block 'loop + ;; u@h search + (loop for dir in mh-picon-existing-directory-list + do (loop for type in mh-picon-image-types + ;; [path]user@host + for file1 = (format "%s/%s.%s" + dir canonical-address type) + when (file-exists-p file1) + do (return-from 'loop file1) + ;; [path]user + for file2 = (format "%s/%s.%s" dir user type) + when (file-exists-p file2) + do (return-from 'loop file2) + ;; [path]host + for file3 = (format "%s/%s.%s" dir host type) + when (file-exists-p file3) + do (return-from 'loop file3))) + ;; facedb search + ;; Search order for user@foo.net: + ;; [path]net/foo/user + ;; [path]net/foo/user/face + ;; [path]net/user + ;; [path]net/user/face + ;; [path]net/foo/unknown + ;; [path]net/foo/unknown/face + ;; [path]net/unknown + ;; [path]net/unknown/face + (loop for u in (list user "unknown") + do (loop for dir in mh-picon-existing-directory-list + do (loop for x on host-list by #'cdr + for y = (mh-picon-generate-path x u dir) + do (loop for type in mh-picon-image-types + for z1 = (format "%s.%s" y type) + when (file-exists-p z1) + do (return-from 'loop z1) + for z2 = (format "%s/face.%s" + y type) + when (file-exists-p z2) + do (return-from 'loop z2))))))) + (setf (gethash canonical-address mh-picon-cache) + (mh-picon-file-contents match))))) + +(defun mh-picon-set-directory-list () + "Update `mh-picon-existing-directory-list' if needed." + (when (eq mh-picon-existing-directory-list 'unset) + (setq mh-picon-existing-directory-list + (loop for x in mh-picon-directory-list + when (file-directory-p x) collect x)))) + +(defun mh-picon-generate-path (host-list user directory) + "Generate the image file path. +HOST-LIST is the parsed host address of the email address, USER +the username and DIRECTORY is the directory relative to which the +path is generated." + (loop with acc = "" + for elem in host-list + do (setq acc (format "%s/%s" elem acc)) + finally return (format "%s/%s%s" directory acc user))) + +(defun mh-picon-file-contents (file) + "Return details about FILE. +A list of consisting of a symbol for the type of the file and the +file contents as a string is returned. If FILE is nil, then both +elements of the list are nil." + (if (stringp file) + (with-temp-buffer + (let ((type (and (string-match ".*\\.\\(...\\)$" file) + (intern (match-string 1 file))))) + (insert-file-contents-literally file) + (values type (buffer-string)))) + (values nil nil))) + + + +;;; X-Image-URL Display + +(defvar mh-x-image-scaling-function + (cond ((executable-find "convert") + 'mh-x-image-scale-with-convert) + ((and (executable-find "anytopnm") (executable-find "pnmscale") + (executable-find "pnmtopng")) + 'mh-x-image-scale-with-pnm) + (t 'ignore)) + "Function to use to scale image to proper size.") + +(defun mh-x-image-scale-with-pnm (input output) + "Scale image in INPUT file and write to OUTPUT file using pnm tools." + (let ((res (shell-command-to-string + (format "anytopnm < %s | pnmscale -xysize 96 48 | pnmtopng > %s" + input output)))) + (unless (equal res "") + (delete-file output)))) + +(defun mh-x-image-scale-with-convert (input output) + "Scale image in INPUT file and write to OUTPUT file using ImageMagick." + (call-process "convert" nil nil nil "-geometry" "96x48" input output)) + +(defvar mh-wget-executable nil) +(defvar mh-wget-choice + (or (and (setq mh-wget-executable (executable-find "wget")) 'wget) + (and (setq mh-wget-executable (executable-find "fetch")) 'fetch) + (and (setq mh-wget-executable (executable-find "curl")) 'curl))) +(defvar mh-wget-option + (cdr (assoc mh-wget-choice '((curl . "-o") (fetch . "-o") (wget . "-O"))))) +(defvar mh-x-image-temp-file nil) +(defvar mh-x-image-url nil) +(defvar mh-x-image-marker nil) +(defvar mh-x-image-url-cache-file nil) + +(defun mh-x-image-url-display (url) + "Display image from location URL. +If the URL isn't present in the cache then it is fetched with wget." + (let* ((cache-filename (mh-x-image-url-cache-canonicalize url)) + (state (mh-x-image-get-download-state cache-filename)) + (marker (set-marker (make-marker) (point)))) + (set (make-local-variable 'mh-x-image-marker) marker) + (cond ((not (mh-x-image-url-sane-p url))) + ((eq state 'ok) + (mh-x-image-display cache-filename marker)) + ((or (not mh-wget-executable) + (eq mh-x-image-scaling-function 'ignore))) + ((eq state 'never)) + ((not mh-fetch-x-image-url) + (set-marker marker nil)) + ((eq state 'try-again) + (mh-x-image-set-download-state cache-filename nil) + (mh-x-image-url-fetch-image url cache-filename marker + 'mh-x-image-scale-and-display)) + ((and (eq mh-fetch-x-image-url 'ask) + (not (y-or-n-p (format "Fetch %s? " url)))) + (mh-x-image-set-download-state cache-filename 'never)) + ((eq state nil) + (mh-x-image-url-fetch-image url cache-filename marker + 'mh-x-image-scale-and-display))))) + +(defvar mh-x-image-cache-directory nil + "Directory where X-Image-URL images are cached.") + +;;;###mh-autoload +(defun mh-set-x-image-cache-directory (directory) + "Set the DIRECTORY where X-Image-URL images are cached. +This is only done if `mh-x-image-cache-directory' is nil." + ;; XXX This is the code that used to be in find-user-path. Is there + ;; a good reason why the variable is set conditionally? Do we expect + ;; the user to have set this variable directly? + (unless mh-x-image-cache-directory + (setq mh-x-image-cache-directory directory))) + +(defun mh-x-image-url-cache-canonicalize (url) + "Canonicalize URL. +Replace the ?/ character with a ?! character and append .png. +Also replaces special characters with `url-hexify-string' since +not all characters, such as :, are legal within Windows +filenames. See URL `http://msdn.microsoft.com/library/default.asp?url=/library/en-us/fileio/fs/naming_a_file.asp'." + (format "%s/%s.png" mh-x-image-cache-directory + (url-hexify-string + (with-temp-buffer + (insert url) + (mh-replace-string "/" "!") + (buffer-string))))) + +;; Copy of constant from url-util.el in Emacs 22; needed by Emacs 21. +(if (not (boundp 'url-unreserved-chars)) + (defconst url-unreserved-chars + '( + ?a ?b ?c ?d ?e ?f ?g ?h ?i ?j ?k ?l ?m ?n ?o ?p ?q ?r ?s ?t ?u ?v ?w ?x ?y ?z + ?A ?B ?C ?D ?E ?F ?G ?H ?I ?J ?K ?L ?M ?N ?O ?P ?Q ?R ?S ?T ?U ?V ?W ?X ?Y ?Z + ?0 ?1 ?2 ?3 ?4 ?5 ?6 ?7 ?8 ?9 + ?- ?_ ?. ?! ?~ ?* ?' ?\( ?\)) + "A list of characters that are _NOT_ reserved in the URL spec. +This is taken from RFC 2396.")) + +(mh-defun-compat url-hexify-string (str) + "Escape characters in a string. +This is a copy of the function of the same name from url-util.el +in Emacs 22; needed by Emacs 21." + (mapconcat + (lambda (char) + ;; Fixme: use a char table instead. + (if (not (memq char url-unreserved-chars)) + (if (> char 255) + (error "Hexifying multibyte character %s" str) + (format "%%%02X" char)) + (char-to-string char))) + str "")) + +(defun mh-x-image-get-download-state (file) + "Check the state of FILE by following any symbolic links." + (unless (file-exists-p mh-x-image-cache-directory) + (call-process "mkdir" nil nil nil mh-x-image-cache-directory)) + (cond ((file-symlink-p file) + (intern (file-name-nondirectory (file-chase-links file)))) + ((not (file-exists-p file)) nil) + (t 'ok))) + +(defun mh-x-image-set-download-state (file data) + "Setup a symbolic link from FILE to DATA." + (if data + (make-symbolic-link (symbol-name data) file t) + (delete-file file))) + +(defun mh-x-image-url-sane-p (url) + "Check if URL is something sensible." + (let ((len (length url))) + (cond ((< len 5) nil) + ((not (equal (substring url 0 5) "http:")) nil) + ((> len 100) nil) + (t t)))) + +(defun mh-x-image-display (image marker) + "Display IMAGE at MARKER." + (save-excursion + (set-buffer (marker-buffer marker)) + (let ((buffer-read-only nil) + (default-enable-multibyte-characters nil) + (buffer-modified-flag (buffer-modified-p))) + (unwind-protect + (when (and (file-readable-p image) (not (file-symlink-p image)) + (eq marker mh-x-image-marker)) + (goto-char marker) + (mh-do-in-gnu-emacs + (mh-funcall-if-exists insert-image (create-image image 'png))) + (mh-do-in-xemacs + (when (featurep 'png) + (set-extent-begin-glyph + (make-extent (point) (point)) + (make-glyph + (vector 'png ':data (with-temp-buffer + (insert-file-contents-literally image) + (buffer-string)))))))) + (set-buffer-modified-p buffer-modified-flag))))) + +(defun mh-x-image-url-fetch-image (url cache-file marker sentinel) + "Fetch and display the image specified by URL. +After the image is fetched, it is stored in CACHE-FILE. It will +be displayed in a buffer and position specified by MARKER. The +actual display is carried out by the SENTINEL function." + (if mh-wget-executable + (let ((buffer (get-buffer-create (generate-new-buffer-name + mh-temp-fetch-buffer))) + (filename (or (mh-funcall-if-exists make-temp-file "mhe-fetch") + (expand-file-name (make-temp-name "~/mhe-fetch"))))) + (save-excursion + (set-buffer buffer) + (set (make-local-variable 'mh-x-image-url-cache-file) cache-file) + (set (make-local-variable 'mh-x-image-marker) marker) + (set (make-local-variable 'mh-x-image-temp-file) filename)) + (set-process-sentinel + (start-process "*mh-x-image-url-fetch*" buffer + mh-wget-executable mh-wget-option filename url) + sentinel)) + ;; Temporary failure + (mh-x-image-set-download-state cache-file 'try-again))) + +(defun mh-x-image-scale-and-display (process change) + "When the wget PROCESS terminates scale and display image. +The argument CHANGE is ignored." + (when (eq (process-status process) 'exit) + (let (marker temp-file cache-filename wget-buffer) + (save-excursion + (set-buffer (setq wget-buffer (process-buffer process))) + (setq marker mh-x-image-marker + cache-filename mh-x-image-url-cache-file + temp-file mh-x-image-temp-file)) + (cond + ;; Check if we have `convert' + ((eq mh-x-image-scaling-function 'ignore) + (message "The \"convert\" program is needed to display X-Image-URL") + (mh-x-image-set-download-state cache-filename 'try-again)) + ;; Scale fetched image + ((and (funcall mh-x-image-scaling-function temp-file cache-filename) + nil)) + ;; Attempt to display image if we have it + ((file-exists-p cache-filename) + (mh-x-image-display cache-filename marker)) + ;; We didn't find the image. Should we try to display it the next time? + (t (mh-x-image-set-download-state cache-filename 'try-again))) + (ignore-errors + (set-marker marker nil) + (delete-process process) + (kill-buffer wget-buffer) + (delete-file temp-file))))) + +(provide 'mh-xface) + +;; Local Variables: +;; indent-tabs-mode: nil +;; sentence-end-double-space: nil +;; End: + +;;; mh-xface.el ends here |