mirror/emacs
1
0
Fork 0
mirror of https://git.savannah.gnu.org/git/emacs.git synced 2025-01-21 18:23:59 +00:00
Code Issues Releases Activity

The Great Cleanup

Browse Source 
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.
This commit is contained in:
Bill Wohler 2006-01-29 19:34:57 +00:00
parent a102b25292
commit dda00b2cb5
30 changed files with 13807 additions and 12896 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
lisp/mh-e/.gitignore vendored
View File

@ -1,2 +1,3 @@
mh-autoloads.el
mh-cus-load.el
mh-loaddefs.el

427
lisp/mh-e/ChangeLog
View File

@ -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.

207
lisp/mh-e/mh-acros.el
View File

@ -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)

72
lisp/mh-e/mh-alias.el
View File

@ -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:

4
lisp/mh-e/mh-buffers.el
View File

@ -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:

1704
lisp/mh-e/mh-comp.el
View File

File diff suppressed because it is too large Load Diff

72
lisp/mh-e/mh-compat.el Normal file
View File

@ -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

2902
lisp/mh-e/mh-customize.el
View File

File diff suppressed because it is too large Load Diff

5677
lisp/mh-e/mh-e.el
View File

File diff suppressed because it is too large Load Diff

264
lisp/mh-e/mh-exec.el
View File

@ -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

1989
lisp/mh-e/mh-folder.el Normal file
View File

File diff suppressed because it is too large Load Diff

135
lisp/mh-e/mh-funcs.el
View File

@ -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 ()
@ -212,27 +197,6 @@ Display RANGE after packing, or the entire folder if RANGE is nil."
(mh-reset-threads-and-narrowing)
(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."
@ -267,6 +231,27 @@ to the command."
(forward-line 2))
(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.
@ -288,21 +273,6 @@ By default, messages are sorted by date. The option
(cond (threaded-flag (mh-toggle-threads))
(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."
(defun mh-undo-folder ()
"Undo all refiles and deletes in the current folder."
(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."
(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)

42
lisp/mh-e/mh-gnus.el
View File

@ -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:

103
lisp/mh-e/mh-identity.el
View File

@ -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

68
lisp/mh-e/mh-inc.el
View File

@ -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)

441
lisp/mh-e/mh-init.el
View File

@ -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

19
lisp/mh-e/mh-junk.el
View File

@ -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.

1040
lisp/mh-e/mh-letter.el Normal file
View File

File diff suppressed because it is too large Load Diff

329
lisp/mh-e/mh-limit.el Normal file
View File

@ -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

2549
lisp/mh-e/mh-mime.el
View File

File diff suppressed because it is too large Load Diff

113
lisp/mh-e/mh-print.el
View File

@ -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"))))

490
lisp/mh-e/mh-scan.el Normal file
View File

@ -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

718
lisp/mh-e/mh-search.el
View File

@ -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,30 +366,182 @@ 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)))
;;;###mh-autoload
(defvar mh-search-mode-map (make-sparse-keymap)
"Keymap for searching folder.")
;; Sequence Searches
;;;###mh-autoload
;; If this changes, modify mh-search-mode-help-messages accordingly, below.
(gnus-define-keys mh-search-mode-map
"\C-c?" mh-help
"\C-c\C-c" mh-index-do-search
"\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-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-fs" mh-to-field
"\C-c\C-ft" mh-to-field)
(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"
@ -394,11 +549,35 @@ configuration and is used when the search folder is dismissed."
["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
"\C-c\C-c" mh-index-do-search
"\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-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-fm" mh-to-field
"\C-c\C-fs" mh-to-field
"\C-c\C-ft" mh-to-field)
;;; 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)

1934
lisp/mh-e/mh-seq.el
View File

File diff suppressed because it is too large Load Diff

906
lisp/mh-e/mh-show.el Normal file
View File

@ -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

317
lisp/mh-e/mh-speed.el
View File

@ -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)))))
(mh-clear-sub-folders-cache)))))
(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 ""))
;; 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:

883
lisp/mh-e/mh-thread.el Normal file
View File

@ -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

419
lisp/mh-e/mh-tool-bar.el Normal file
View File

@ -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

2350
lisp/mh-e/mh-utils.el
View File

File diff suppressed because it is too large Load Diff

528
lisp/mh-e/mh-xface.el Normal file
View File

@ -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