-;;; Build mh-show-mode keymaps
-
-(gnus-define-keys mh-show-mode-map
- " " mh-show-page-msg
- "!" mh-show-refile-or-write-again
- "'" mh-show-toggle-tick
- "," mh-show-header-display
- "." mh-show-show
- ">" mh-show-write-message-to-file
- "?" mh-help
- "E" mh-show-extract-rejected-mail
- "M" mh-show-modify
- "\177" mh-show-previous-page
- "\C-d" mh-show-delete-msg-no-motion
- "\t" mh-show-next-button
- [backtab] mh-show-prev-button
- "\M-\t" mh-show-prev-button
- "\ed" mh-show-redistribute
- "^" mh-show-refile-msg
- "c" mh-show-copy-msg
- "d" mh-show-delete-msg
- "e" mh-show-edit-again
- "f" mh-show-forward
- "g" mh-show-goto-msg
- "i" mh-show-inc-folder
- "k" mh-show-delete-subject-or-thread
- "m" mh-show-send
- "n" mh-show-next-undeleted-msg
- "\M-n" mh-show-next-unread-msg
- "o" mh-show-refile-msg
- "p" mh-show-previous-undeleted-msg
- "\M-p" mh-show-previous-unread-msg
- "q" mh-show-quit
- "r" mh-show-reply
- "s" mh-show-send
- "t" mh-show-toggle-showing
- "u" mh-show-undo
- "x" mh-show-execute-commands
- "v" mh-show-index-visit-folder
- "|" mh-show-pipe-msg)
-
-(gnus-define-keys (mh-show-folder-map "F" mh-show-mode-map)
- "?" mh-prefix-help
- "'" mh-index-ticked-messages
- "S" mh-show-sort-folder
- "c" mh-show-catchup
- "f" mh-show-visit-folder
- "i" mh-index-search
- "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-show-search-folder
- "t" mh-show-toggle-threads
- "u" mh-show-undo-folder
- "v" mh-show-visit-folder)
-
-(gnus-define-keys (mh-show-sequence-map "S" mh-show-mode-map)
- "'" mh-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
- "f" mh-show-narrow-to-from
- "r" mh-show-narrow-to-range
- "s" mh-show-narrow-to-subject
- "t" mh-show-narrow-to-to
- "w" mh-show-widen)
-
-(gnus-define-keys (mh-show-extract-map "X" mh-show-mode-map)
- "?" mh-prefix-help
- "s" mh-show-store-msg
- "u" mh-show-store-msg)
-
-;; Untested...
-(gnus-define-keys (mh-show-digest-map "D" mh-show-mode-map)
- "?" mh-prefix-help
- " " mh-show-page-digest
- "\177" mh-show-page-digest-backwards
- "b" mh-show-burst-digest)
-
-(gnus-define-keys (mh-show-mime-map "K" mh-show-mode-map)
- "?" mh-prefix-help
- "a" mh-mime-save-parts
- "e" mh-show-display-with-external-viewer
- "v" mh-show-toggle-mime-part
- "o" mh-show-save-mime-part
- "i" mh-show-inline-mime-part
- "t" mh-show-toggle-mime-buttons
- "\t" mh-show-next-button
- [backtab] mh-show-prev-button
- "\M-\t" mh-show-prev-button)
-
-(easy-menu-define
- mh-show-sequence-menu mh-show-mode-map "Menu for MH-E folder-sequence."
- '("Sequence"
- ["Add Message to Sequence..." mh-show-put-msg-in-seq t]
- ["List Sequences for Message" mh-show-msg-is-in-seq t]
- ["Delete Message from Sequence..." mh-show-delete-msg-from-seq t]
- ["List Sequences in Folder..." mh-show-list-sequences t]
- ["Delete Sequence..." mh-show-delete-seq t]
- ["Narrow to Sequence..." mh-show-narrow-to-seq t]
- ["Widen from Sequence" mh-show-widen t]
- "--"
- ["Narrow to Subject Sequence" mh-show-narrow-to-subject t]
- ["Narrow to Tick Sequence" mh-show-narrow-to-tick
- (save-excursion
- (set-buffer mh-show-folder-buffer)
- (and mh-tick-seq (mh-seq-msgs (mh-find-seq mh-tick-seq))))]
- ["Delete Rest of Same Subject" mh-show-delete-subject t]
- ["Toggle Tick Mark" mh-show-toggle-tick t]
- "--"
- ["Push State Out to MH" mh-show-update-sequences t]))
-
-(easy-menu-define
- mh-show-message-menu mh-show-mode-map "Menu for MH-E folder-message."
- '("Message"
- ["Show Message" mh-show-show t]
- ["Show Message with Header" mh-show-header-display t]
- ["Next Message" mh-show-next-undeleted-msg t]
- ["Previous Message" mh-show-previous-undeleted-msg t]
- ["Go to First Message" mh-show-first-msg t]
- ["Go to Last Message" mh-show-last-msg t]
- ["Go to Message by Number..." mh-show-goto-msg t]
- ["Modify Message" mh-show-modify t]
- ["Delete Message" mh-show-delete-msg t]
- ["Refile Message" mh-show-refile-msg t]
- ["Undo Delete/Refile" mh-show-undo t]
- ["Process Delete/Refile" mh-show-execute-commands t]
- "--"
- ["Compose a New Message" mh-send t]
- ["Reply to Message..." mh-show-reply t]
- ["Forward Message..." mh-show-forward t]
- ["Redistribute Message..." mh-show-redistribute t]
- ["Edit Message Again" mh-show-edit-again t]
- ["Re-edit a Bounced Message" mh-show-extract-rejected-mail t]
- "--"
- ["Copy Message to Folder..." mh-show-copy-msg t]
- ["Print Message" mh-show-print-msg t]
- ["Write Message to File..." mh-show-write-msg-to-file t]
- ["Pipe Message to Command..." mh-show-pipe-msg t]
- ["Unpack Uuencoded Message..." mh-show-store-msg t]
- ["Burst Digest Message" mh-show-burst-digest t]))
-
-(easy-menu-define
- mh-show-folder-menu mh-show-mode-map "Menu for MH-E folder."
- '("Folder"
- ["Incorporate New Mail" mh-show-inc-folder t]
- ["Toggle Show/Folder" mh-show-toggle-showing t]
- ["Execute Delete/Refile" mh-show-execute-commands t]
- ["Rescan Folder" mh-show-rescan-folder t]
- ["Thread Folder" mh-show-toggle-threads t]
- ["Pack Folder" mh-show-pack-folder t]
- ["Sort Folder" mh-show-sort-folder t]
- "--"
- ["List Folders" mh-show-list-folders t]
- ["Visit a Folder..." mh-show-visit-folder t]
- ["View New Messages" mh-show-index-new-messages t]
- ["Search a Folder..." mh-show-search-folder t]
- ["Indexed Search..." mh-index-search t]
- "--"
- ["Quit MH-E" mh-quit t]))
-
-;; Ensure new buffers won't get this mode if default-major-mode is nil.
-(put 'mh-show-mode 'mode-class 'special)
-
-;; Shush compiler.
-(eval-when-compile (defvar font-lock-auto-fontify))
-
-(define-derived-mode mh-show-mode text-mode "MH-Show"
- "Major mode for showing messages in MH-E.\\<mh-show-mode-map>
-
-The hook `mh-show-mode-hook' is called upon entry to this mode.
-
-See also `mh-folder-mode'.
-
-\\{mh-show-mode-map}"
- (set (make-local-variable 'mail-header-separator) mh-mail-header-separator)
- (setq paragraph-start (default-value 'paragraph-start))
- (mh-show-unquote-From)
- (mh-show-xface)
- (mh-show-addr)
- (setq buffer-invisibility-spec '((vanish . t) t))
- (set (make-local-variable 'line-move-ignore-invisible) t)
- (make-local-variable 'font-lock-defaults)
- ;;(set (make-local-variable 'font-lock-support-mode) nil)
- (cond
- ((equal mh-highlight-citation-style 'font-lock)
- (setq font-lock-defaults '(mh-show-font-lock-keywords-with-cite t)))
- ((equal mh-highlight-citation-style 'gnus)
- (setq font-lock-defaults '((mh-show-font-lock-keywords)
- t nil nil nil
- (font-lock-fontify-region-function
- . mh-show-font-lock-fontify-region)))
- (mh-gnus-article-highlight-citation))
- (t
- (setq font-lock-defaults '(mh-show-font-lock-keywords t))))
- (if (and mh-xemacs-flag
- font-lock-auto-fontify)
- (turn-on-font-lock))
- (set (make-local-variable 'tool-bar-map) mh-show-tool-bar-map)
- (mh-funcall-if-exists mh-tool-bar-init :show)
- (when mh-decode-mime-flag
- (mh-make-local-hook 'kill-buffer-hook)
- (add-hook 'kill-buffer-hook 'mh-mime-cleanup nil t))
- (easy-menu-add mh-show-sequence-menu)
- (easy-menu-add mh-show-message-menu)
- (easy-menu-add mh-show-folder-menu)
- (make-local-variable 'mh-show-folder-buffer)
- (buffer-disable-undo)
- (setq buffer-read-only t)
- (use-local-map mh-show-mode-map))
-
-(defun mh-show-addr ()
- "Use `goto-address'."
- (when mh-show-use-goto-addr-flag
- (if (not (featurep 'goto-addr))
- (load "goto-addr" t t))
- (if (fboundp 'goto-address)
- (goto-address))))
-
-\f
-
-;; X-Face and Face display
-(defvar mh-show-xface-function
- (cond ((and mh-xemacs-flag (locate-library "x-face") (not (featurep 'xface)))
- (load "x-face" t t)
- #'mh-face-display-function)
- ((>= emacs-major-version 21)
- #'mh-face-display-function)
- (t #'ignore))
- "Determine at run time what function should be called to display X-Face.")
-
-(defvar mh-uncompface-executable
- (and (fboundp 'executable-find) (executable-find "uncompface")))
-
-(defun mh-face-to-png (data)
- "Convert base64 encoded DATA to png image."
- (with-temp-buffer
- (insert data)
- (ignore-errors (base64-decode-region (point-min) (point-max)))
- (buffer-string)))
-
-(defun mh-uncompface (data)
- "Run DATA through `uncompface' to generate bitmap."
- (with-temp-buffer
- (insert data)
- (when (and mh-uncompface-executable
- (equal (call-process-region (point-min) (point-max)
- mh-uncompface-executable t '(t nil))
- 0))
- (mh-icontopbm)
- (buffer-string))))
-
-(defun mh-icontopbm ()
- "Elisp substitute for `icontopbm'."
- (goto-char (point-min))
- (let ((end (point-max)))
- (while (re-search-forward "0x\\(..\\)\\(..\\)," nil t)
- (save-excursion
- (goto-char (point-max))
- (insert (string-to-number (match-string 1) 16))
- (insert (string-to-number (match-string 2) 16))))
- (delete-region (point-min) end)
- (goto-char (point-min))
- (insert "P4\n48 48\n")))
-
-(mh-do-in-xemacs (defvar default-enable-multibyte-characters))
-
-(defmacro mh-face-foreground-compat (face &optional frame inherit)
- "Return the foreground color name of FACE, or nil if unspecified.
-See documentation for `face-foreground' for a description of the
-arguments FACE, FRAME, and INHERIT.
-
-Calls `face-foreground' correctly in older environments. Versions
-of Emacs prior to version 22 lacked an INHERIT argument which
-when t tells `face-foreground' to consider an inherited value for
-the foreground if the face does not define one itself."
- (if (>= emacs-major-version 22)
- `(face-foreground ,face ,frame ,inherit)
- `(face-foreground ,face ,frame)))
-
-(defmacro mh-face-background-compat (face &optional frame inherit)
- "Return the background color name of face, or nil if unspecified.
-See documentation for `back-foreground' for a description of the
-arguments FACE, FRAME, and INHERIT.
-
-Calls `face-background' correctly in older environments. Versions
-of Emacs prior to version 22 lacked an INHERIT argument which
-when t tells `face-background' to consider an inherited value for
-the background if the face does not define one itself."
- (if (>= emacs-major-version 22)
- `(face-background ,face ,frame ,inherit)
- `(face-background ,face ,frame)))
-
-(defun mh-face-display-function ()
- "Display a Face, X-Face, or X-Image-URL header field.
-If more than one of these are present, then the first one found
-in this order is used."
- (save-restriction
- (goto-char (point-min))
- (re-search-forward "\n\n" (point-max) t)
- (narrow-to-region (point-min) (point))
- (let* ((case-fold-search t)
- (default-enable-multibyte-characters nil)
- (face (message-fetch-field "face" t))
- (x-face (message-fetch-field "x-face" t))
- (url (message-fetch-field "x-image-url" t))
- raw type)
- (cond (face (setq raw (mh-face-to-png face)
- type 'png))
- (x-face (setq raw (mh-uncompface x-face)
- type 'pbm))
- (url (setq type 'url))
- (t (multiple-value-setq (type raw) (mh-picon-get-image))))
- (when type
- (goto-char (point-min))
- (when (re-search-forward "^from:" (point-max) t)
- ;; GNU Emacs
- (mh-do-in-gnu-emacs
- (if (eq type 'url)
- (mh-x-image-url-display url)
- (mh-funcall-if-exists
- insert-image (create-image
- raw type t
- :foreground
- (mh-face-foreground-compat 'mh-show-xface nil t)
- :background
- (mh-face-background-compat 'mh-show-xface nil t))
- " ")))
- ;; XEmacs
- (mh-do-in-xemacs
- (cond
- ((eq type 'url)
- (mh-x-image-url-display url))
- ((eq type 'png)
- (when (featurep 'png)
- (set-extent-begin-glyph
- (make-extent (point) (point))
- (make-glyph (vector 'png ':data (mh-face-to-png face))))))
- ;; Try internal xface support if available...
- ((and (eq type 'pbm) (featurep 'xface))
- (set-glyph-face
- (set-extent-begin-glyph
- (make-extent (point) (point))
- (make-glyph (vector 'xface ':data (concat "X-Face: " x-face))))
- 'mh-show-xface))
- ;; Otherwise try external support with x-face...
- ((and (eq type 'pbm)
- (fboundp 'x-face-xmas-wl-display-x-face)
- (fboundp 'executable-find) (executable-find "uncompface"))
- (mh-funcall-if-exists x-face-xmas-wl-display-x-face))
- ;; Picon display
- ((and raw (member type '(xpm xbm gif)))
- (when (featurep type)
- (set-extent-begin-glyph
- (make-extent (point) (point))
- (make-glyph (vector type ':data raw))))))
- (when raw (insert " "))))))))
-
-(defun mh-show-xface ()
- "Display X-Face."
- (when (and window-system mh-show-use-xface-flag
- (or mh-decode-mime-flag mh-mhl-format-file
- mh-clean-message-header-flag))
- (funcall mh-show-xface-function)))
-
-\f
-
-;;; Picon display
-
-;; XXX: This should be customizable. As a side-effect of setting this
-;; variable, arrange to reset mh-picon-existing-directory-list to 'unset.
-(defvar mh-picon-directory-list
- '("~/.picons" "~/.picons/users" "~/.picons/usenix" "~/.picons/news"
- "~/.picons/domains" "~/.picons/misc"
- "/usr/share/picons/" "/usr/share/picons/users" "/usr/share/picons/usenix"
- "/usr/share/picons/news" "/usr/share/picons/domains"
- "/usr/share/picons/misc")
- "List of directories where picons reside.
-The directories are searched for in the order they appear in the list.")
-
-(defvar mh-picon-existing-directory-list 'unset
- "List of directories to search in.")
-
-(defvar mh-picon-cache (make-hash-table :test #'equal))
-
-(defvar mh-picon-image-types
- (loop for type in '(xpm xbm gif)
- when (or (mh-do-in-gnu-emacs
- (ignore-errors
- (mh-funcall-if-exists image-type-available-p type)))
- (mh-do-in-xemacs (featurep type)))
- collect type))
-
-(defun mh-picon-set-directory-list ()
- "Update `mh-picon-existing-directory-list' if needed."
- (when (eq mh-picon-existing-directory-list 'unset)
- (setq mh-picon-existing-directory-list
- (loop for x in mh-picon-directory-list
- when (file-directory-p x) collect x))))
-
-(defun* mh-picon-get-image ()
- "Find the best possible match and return contents."
- (mh-picon-set-directory-list)
- (save-restriction
- (let* ((from-field (ignore-errors (car (message-tokenize-header
- (mh-get-header-field "from:")))))
- (from (car (ignore-errors
- (mh-funcall-if-exists ietf-drums-parse-address
- from-field))))
- (host (and from
- (string-match "\\([^+]*\\)\\(+.*\\)?@\\(.*\\)" from)
- (downcase (match-string 3 from))))
- (user (and host (downcase (match-string 1 from))))
- (canonical-address (format "%s@%s" user host))
- (cached-value (gethash canonical-address mh-picon-cache))
- (host-list (and host (delete "" (split-string host "\\."))))
- (match nil))
- (cond (cached-value (return-from mh-picon-get-image cached-value))
- ((not host-list) (return-from mh-picon-get-image nil)))
- (setq match
- (block 'loop
- ;; u@h search
- (loop for dir in mh-picon-existing-directory-list
- do (loop for type in mh-picon-image-types
- ;; [path]user@host
- for file1 = (format "%s/%s.%s"
- dir canonical-address type)
- when (file-exists-p file1)
- do (return-from 'loop file1)
- ;; [path]user
- for file2 = (format "%s/%s.%s" dir user type)
- when (file-exists-p file2)
- do (return-from 'loop file2)
- ;; [path]host
- for file3 = (format "%s/%s.%s" dir host type)
- when (file-exists-p file3)
- do (return-from 'loop file3)))
- ;; facedb search
- ;; Search order for user@foo.net:
- ;; [path]net/foo/user
- ;; [path]net/foo/user/face
- ;; [path]net/user
- ;; [path]net/user/face
- ;; [path]net/foo/unknown
- ;; [path]net/foo/unknown/face
- ;; [path]net/unknown
- ;; [path]net/unknown/face
- (loop for u in (list user "unknown")
- do (loop for dir in mh-picon-existing-directory-list
- do (loop for x on host-list by #'cdr
- for y = (mh-picon-generate-path x u dir)
- do (loop for type in mh-picon-image-types
- for z1 = (format "%s.%s" y type)
- when (file-exists-p z1)
- do (return-from 'loop z1)
- for z2 = (format "%s/face.%s"
- y type)
- when (file-exists-p z2)
- do (return-from 'loop z2)))))))
- (setf (gethash canonical-address mh-picon-cache)
- (mh-picon-file-contents match)))))
-
-(defun mh-picon-file-contents (file)
- "Return details about FILE.
-A list of consisting of a symbol for the type of the file and the
-file contents as a string is returned. If FILE is nil, then both
-elements of the list are nil."
- (if (stringp file)
- (with-temp-buffer
- (let ((type (and (string-match ".*\\.\\(...\\)$" file)
- (intern (match-string 1 file)))))
- (insert-file-contents-literally file)
- (values type (buffer-string))))
- (values nil nil)))
-
-(defun mh-picon-generate-path (host-list user directory)
- "Generate the image file path.
-HOST-LIST is the parsed host address of the email address, USER
-the username and DIRECTORY is the directory relative to which the
-path is generated."
- (loop with acc = ""
- for elem in host-list
- do (setq acc (format "%s/%s" elem acc))
- finally return (format "%s/%s%s" directory acc user)))
-
-\f
-
-;; X-Image-URL display
-
-(defvar mh-x-image-cache-directory nil
- "Directory where X-Image-URL images are cached.")
-(defvar mh-x-image-scaling-function
- (cond ((executable-find "convert")
- 'mh-x-image-scale-with-convert)
- ((and (executable-find "anytopnm") (executable-find "pnmscale")
- (executable-find "pnmtopng"))
- 'mh-x-image-scale-with-pnm)
- (t 'ignore))
- "Function to use to scale image to proper size.")
-(defvar mh-wget-executable nil)
-(defvar mh-wget-choice
- (or (and (setq mh-wget-executable (executable-find "wget")) 'wget)
- (and (setq mh-wget-executable (executable-find "fetch")) 'fetch)
- (and (setq mh-wget-executable (executable-find "curl")) 'curl)))
-(defvar mh-wget-option
- (cdr (assoc mh-wget-choice '((curl . "-o") (fetch . "-o") (wget . "-O")))))
-(defvar mh-x-image-temp-file nil)
-(defvar mh-x-image-url nil)
-(defvar mh-x-image-marker nil)
-(defvar mh-x-image-url-cache-file nil)
-
-;; Functions to scale image to proper size
-(defun mh-x-image-scale-with-pnm (input output)
- "Scale image in INPUT file and write to OUTPUT file using pnm tools."
- (let ((res (shell-command-to-string
- (format "anytopnm < %s | pnmscale -xysize 96 48 | pnmtopng > %s"
- input output))))
- (unless (equal res "")
- (delete-file output))))
-
-(defun mh-x-image-scale-with-convert (input output)
- "Scale image in INPUT file and write to OUTPUT file using ImageMagick."
- (call-process "convert" nil nil nil "-geometry" "96x48" input output))
-
-(defun mh-x-image-url-cache-canonicalize (url)
- "Canonicalize URL.
-Replace the ?/ character with a ?! character and append .png."
- (format "%s/%s.png" mh-x-image-cache-directory
- (with-temp-buffer
- (insert url)
- (mh-replace-string "/" "!")
- (buffer-string))))
-
-(defun mh-x-image-set-download-state (file data)
- "Setup a symbolic link from FILE to DATA."
- (if data
- (make-symbolic-link (symbol-name data) file t)
- (delete-file file)))
-
-(defun mh-x-image-get-download-state (file)
- "Check the state of FILE by following any symbolic links."
- (unless (file-exists-p mh-x-image-cache-directory)
- (call-process "mkdir" nil nil nil mh-x-image-cache-directory))
- (cond ((file-symlink-p file)
- (intern (file-name-nondirectory (file-chase-links file))))
- ((not (file-exists-p file)) nil)
- (t 'ok)))
-
-(defun mh-x-image-url-fetch-image (url cache-file marker sentinel)
- "Fetch and display the image specified by URL.
-After the image is fetched, it is stored in CACHE-FILE. It will
-be displayed in a buffer and position specified by MARKER. The
-actual display is carried out by the SENTINEL function."
- (if mh-wget-executable
- (let ((buffer (get-buffer-create (generate-new-buffer-name
- mh-temp-fetch-buffer)))
- (filename (or (mh-funcall-if-exists make-temp-file "mhe-fetch")
- (expand-file-name (make-temp-name "~/mhe-fetch")))))
- (save-excursion
- (set-buffer buffer)
- (set (make-local-variable 'mh-x-image-url-cache-file) cache-file)
- (set (make-local-variable 'mh-x-image-marker) marker)
- (set (make-local-variable 'mh-x-image-temp-file) filename))
- (set-process-sentinel
- (start-process "*mh-x-image-url-fetch*" buffer
- mh-wget-executable mh-wget-option filename url)
- sentinel))
- ;; Temporary failure
- (mh-x-image-set-download-state cache-file 'try-again)))
-
-(defun mh-x-image-display (image marker)
- "Display IMAGE at MARKER."
- (save-excursion
- (set-buffer (marker-buffer marker))
- (let ((buffer-read-only nil)
- (default-enable-multibyte-characters nil)
- (buffer-modified-flag (buffer-modified-p)))
- (unwind-protect
- (when (and (file-readable-p image) (not (file-symlink-p image))
- (eq marker mh-x-image-marker))
- (goto-char marker)
- (mh-do-in-gnu-emacs
- (mh-funcall-if-exists insert-image (create-image image 'png)))
- (mh-do-in-xemacs
- (when (featurep 'png)
- (set-extent-begin-glyph
- (make-extent (point) (point))
- (make-glyph
- (vector 'png ':data (with-temp-buffer
- (insert-file-contents-literally image)
- (buffer-string))))))))
- (set-buffer-modified-p buffer-modified-flag)))))
-
-(defun mh-x-image-scale-and-display (process change)
- "When the wget PROCESS terminates scale and display image.
-The argument CHANGE is ignored."
- (when (eq (process-status process) 'exit)
- (let (marker temp-file cache-filename wget-buffer)
- (save-excursion
- (set-buffer (setq wget-buffer (process-buffer process)))
- (setq marker mh-x-image-marker
- cache-filename mh-x-image-url-cache-file
- temp-file mh-x-image-temp-file))
- (cond
- ;; Check if we have `convert'
- ((eq mh-x-image-scaling-function 'ignore)
- (message "The \"convert\" program is needed to display X-Image-URL")
- (mh-x-image-set-download-state cache-filename 'try-again))
- ;; Scale fetched image
- ((and (funcall mh-x-image-scaling-function temp-file cache-filename)
- nil))
- ;; Attempt to display image if we have it
- ((file-exists-p cache-filename)
- (mh-x-image-display cache-filename marker))
- ;; We didn't find the image. Should we try to display it the next time?
- (t (mh-x-image-set-download-state cache-filename 'try-again)))
- (ignore-errors
- (set-marker marker nil)
- (delete-process process)
- (kill-buffer wget-buffer)
- (delete-file temp-file)))))
-
-(defun mh-x-image-url-sane-p (url)
- "Check if URL is something sensible."
- (let ((len (length url)))
- (cond ((< len 5) nil)
- ((not (equal (substring url 0 5) "http:")) nil)
- ((> len 100) nil)
- (t t))))
-
-(defun mh-x-image-url-display (url)
- "Display image from location URL.
-If the URL isn't present in the cache then it is fetched with wget."
- (let* ((cache-filename (mh-x-image-url-cache-canonicalize url))
- (state (mh-x-image-get-download-state cache-filename))
- (marker (set-marker (make-marker) (point))))
- (set (make-local-variable 'mh-x-image-marker) marker)
- (cond ((not (mh-x-image-url-sane-p url)))
- ((eq state 'ok)
- (mh-x-image-display cache-filename marker))
- ((or (not mh-wget-executable)
- (eq mh-x-image-scaling-function 'ignore)))
- ((eq state 'never))
- ((not mh-fetch-x-image-url)
- (set-marker marker nil))
- ((eq state 'try-again)
- (mh-x-image-set-download-state cache-filename nil)
- (mh-x-image-url-fetch-image url cache-filename marker
- 'mh-x-image-scale-and-display))
- ((and (eq mh-fetch-x-image-url 'ask)
- (not (y-or-n-p (format "Fetch %s? " url))))
- (mh-x-image-set-download-state cache-filename 'never))
- ((eq state nil)
- (mh-x-image-url-fetch-image url cache-filename marker
- 'mh-x-image-scale-and-display)))))
-
-\f
-
-(defun mh-maybe-show (&optional msg)
- "Display message at cursor, but only if in show mode.
-If optional arg MSG is non-nil, display that message instead."
- (if mh-showing-mode (mh-show msg)))
-
-(defun mh-show (&optional message redisplay-flag)
- "Display message\\<mh-folder-mode-map>.
-
-If the message under the cursor is already displayed, this command
-scrolls to the beginning of the message. MH-E normally hides a lot of
-the superfluous header fields that mailers add to a message, but if
-you wish to see all of them, use the command \\[mh-header-display].
-
-Two hooks can be used to control how messages are displayed. The
-first hook, `mh-show-mode-hook', is called early on in the
-process of the message display. It is usually used to perform
-some action on the message's content. The second hook,
-`mh-show-hook', is the last thing called after messages are
-displayed. It's used to affect the behavior of MH-E in general or
-when `mh-show-mode-hook' is too early.
-
-From a program, optional argument MESSAGE can be used to display an
-alternative message. The optional argument REDISPLAY-FLAG forces the
-redisplay of the message even if the show buffer was already
-displaying the correct message.
-
-See the \"mh-show\" customization group for a litany of options that
-control what displayed messages look like."
- (interactive (list nil t))
- (when (or redisplay-flag
- (and mh-showing-with-headers
- (or mh-mhl-format-file mh-clean-message-header-flag)))
- (mh-invalidate-show-buffer))
- (mh-show-msg message))
-
-(defun mh-show-mouse (event)
- "Move point to mouse EVENT and show message."
- (interactive "e")
- (mouse-set-point event)
- (mh-show))
-
-(defun mh-summary-height ()
- "Return ideal value for the variable `mh-summary-height'.
-The current frame height is taken into consideration."
- (or (and (fboundp 'frame-height)
- (> (frame-height) 24)
- (min 10 (/ (frame-height) 6)))
- 4))
-
-(defun mh-show-msg (msg)
- "Show MSG.
-
-The hook `mh-show-hook' is called after the message has been
-displayed."
- (if (not msg)
- (setq msg (mh-get-msg-num t)))
- (mh-showing-mode t)
- (setq mh-page-to-next-msg-flag nil)
- (let ((folder mh-current-folder)
- (folders (list mh-current-folder))
- (clean-message-header mh-clean-message-header-flag)
- (show-window (get-buffer-window mh-show-buffer))
- (display-mime-buttons-flag mh-display-buttons-for-inline-parts-flag))
- (if (not (eq (next-window (minibuffer-window)) (selected-window)))
- (delete-other-windows)) ; force ourself to the top window
- (mh-in-show-buffer (mh-show-buffer)
- (setq mh-display-buttons-for-inline-parts-flag display-mime-buttons-flag)
- (if (and show-window
- (equal (mh-msg-filename msg folder) buffer-file-name))
- (progn ;just back up to start
- (goto-char (point-min))
- (if (not clean-message-header)
- (mh-start-of-uncleaned-message)))
- (mh-display-msg msg folder)))
- (if (not (= (1+ (window-height)) (frame-height))) ;not horizontally split
- (shrink-window (- (window-height) (or mh-summary-height
- (mh-summary-height)))))
- (mh-recenter nil)
- ;; The following line is a nop which forces update of the scan line so
- ;; that font-lock will update it (if needed)...
- (mh-notate nil nil mh-cmd-note)
- (if (not (memq msg mh-seen-list))
- (setq mh-seen-list (cons msg mh-seen-list)))
- (when mh-update-sequences-after-mh-show-flag
- (mh-update-sequences)
- (when mh-index-data
- (setq folders
- (append (mh-index-delete-from-sequence mh-unseen-seq (list msg))
- folders)))
- (when (mh-speed-flists-active-p)
- (apply #'mh-speed-flists t folders)))
- (run-hooks 'mh-show-hook)))
-
-(defun mh-modify (&optional message)
- "Edit message.
-
-There are times when you need to edit a message. For example, you
-may need to fix a broken Content-Type header field. You can do
-this with this command. It displays the raw message in an
-editable buffer. When you are done editing, save and kill the
-buffer as you would any other.
-
-From a program, edit MESSAGE; nil means edit current message."
- (interactive)
- (let* ((message (or message (mh-get-msg-num t)))
- (msg-filename (mh-msg-filename message))
- edit-buffer)
- (when (not (file-exists-p msg-filename))
- (error "Message %d does not exist" message))
-
- ;; Invalidate the show buffer if it is showing the same message that is
- ;; to be edited.
- (when (and (buffer-live-p (get-buffer mh-show-buffer))
- (equal (save-excursion (set-buffer mh-show-buffer)
- buffer-file-name)
- msg-filename))
- (mh-invalidate-show-buffer))
-
- ;; Edit message
- (find-file msg-filename)
- (setq edit-buffer (current-buffer))
-
- ;; Set buffer properties
- (mh-letter-mode)
- (use-local-map text-mode-map)
-
- ;; Just show the edit buffer...
- (delete-other-windows)
- (switch-to-buffer edit-buffer)))
-
-(defun mh-show-unquote-From ()
- "Decode >From at beginning of lines for `mh-show-mode'."
- (save-excursion
- (let ((modified (buffer-modified-p))
- (case-fold-search nil)
- (buffer-read-only nil))
- (goto-char (mh-mail-header-end))
- (while (re-search-forward "^>From" nil t)
- (replace-match "From"))
- (set-buffer-modified-p modified))))
-
-(defun mh-msg-folder (folder-name)
- "Return the name of the buffer for FOLDER-NAME."
- folder-name)
-
-(defun mh-display-msg (msg-num folder-name)
- "Display MSG-NUM of FOLDER-NAME.
-Sets the current buffer to the show buffer."
- (let ((folder (mh-msg-folder folder-name)))
- (set-buffer folder)
- ;; When Gnus uses external displayers it has to keep handles longer. So
- ;; we will delete these handles when mh-quit is called on the folder. It
- ;; would be nicer if there are weak pointers in emacs lisp, then we could
- ;; get the garbage collector to do this for us.
- (unless (mh-buffer-data)
- (setf (mh-buffer-data) (mh-make-buffer-data)))
- ;; Bind variables in folder buffer in case they are local
- (let ((formfile mh-mhl-format-file)
- (clean-message-header mh-clean-message-header-flag)
- (invisible-headers mh-invisible-header-fields-compiled)
- (visible-headers nil)
- (msg-filename (mh-msg-filename msg-num folder-name))
- (show-buffer mh-show-buffer)
- (mm-inline-media-tests mh-mm-inline-media-tests))
- (if (not (file-exists-p msg-filename))
- (error "Message %d does not exist" msg-num))
- (if (and (> mh-show-maximum-size 0)
- (> (elt (file-attributes msg-filename) 7)
- mh-show-maximum-size)
- (not (y-or-n-p
- (format
- "Message %d (%d bytes) exceeds %d bytes. Display it? "
- msg-num (elt (file-attributes msg-filename) 7)
- mh-show-maximum-size))))
- (error "Message %d not displayed" msg-num))
- (set-buffer show-buffer)
- (cond ((not (equal msg-filename buffer-file-name))
- (mh-unvisit-file)
- (setq buffer-read-only nil)
- ;; Cleanup old mime handles
- (mh-mime-cleanup)
- (erase-buffer)
- ;; Changing contents, so this hook needs to be reinitialized.
- ;; pgp.el uses this.
- (if (boundp 'write-contents-hooks) ;Emacs 19
- (kill-local-variable 'write-contents-hooks))
- (if formfile
- (mh-exec-lib-cmd-output "mhl" "-nobell" "-noclear"
- (if (stringp formfile)
- (list "-form" formfile))
- msg-filename)
- (insert-file-contents-literally msg-filename))
- ;; Use mm to display buffer
- (when (and mh-decode-mime-flag (not formfile))
- (mh-add-missing-mime-version-header)
- (setf (mh-buffer-data) (mh-make-buffer-data))
- (mh-mime-display))
- (mh-show-mode)
- ;; Header cleanup
- (goto-char (point-min))
- (cond (clean-message-header
- (mh-clean-msg-header (point-min)
- invisible-headers
- visible-headers)
- (goto-char (point-min)))
- (t
- (mh-start-of-uncleaned-message)))
- (mh-decode-message-header)
- ;; the parts of visiting we want to do (no locking)
- (or (eq buffer-undo-list t) ;don't save undo info for prev msgs
- (setq buffer-undo-list nil))
- (set-buffer-auto-saved)
- ;; the parts of set-visited-file-name we want to do (no locking)
- (setq buffer-file-name msg-filename)
- (setq buffer-backed-up nil)
- (auto-save-mode 1)
- (set-mark nil)
- (unwind-protect
- (when (and mh-decode-mime-flag (not formfile))
- (setq buffer-read-only nil)
- (mh-display-smileys)
- (mh-display-emphasis))
- (setq buffer-read-only t))
- (set-buffer-modified-p nil)
- (setq mh-show-folder-buffer folder)
- (setq mode-line-buffer-identification
- (list (format mh-show-buffer-mode-line-buffer-id
- folder-name msg-num)))
- (mh-logo-display)
- (set-buffer folder)
- (setq mh-showing-with-headers nil))))))
-
-(defun mh-clean-msg-header (start invisible-headers visible-headers)
- "Flush extraneous lines in message header.
-
-Header is cleaned from START to the end of the message header.
-INVISIBLE-HEADERS contains a regular expression specifying lines
-to delete from the header. VISIBLE-HEADERS contains a regular
-expression specifying the lines to display. INVISIBLE-HEADERS is
-ignored if VISIBLE-HEADERS is non-nil."
- ;; XXX Note that MH-E no longer supports the `mh-visible-headers'
- ;; variable, so this function could be trimmed of this feature too."
- (let ((case-fold-search t)
- (buffer-read-only nil))
- (save-restriction
- (goto-char start)
- (if (search-forward "\n\n" nil 'move)
- (backward-char 1))
- (narrow-to-region start (point))
- (goto-char (point-min))
- (if visible-headers
- (while (< (point) (point-max))
- (cond ((looking-at visible-headers)
- (forward-line 1)
- (while (looking-at "[ \t]") (forward-line 1)))
- (t
- (mh-delete-line 1)
- (while (looking-at "[ \t]")
- (mh-delete-line 1)))))
- (while (re-search-forward invisible-headers nil t)
- (beginning-of-line)
- (mh-delete-line 1)
- (while (looking-at "[ \t]")
- (mh-delete-line 1)))))
- (let ((mh-compose-skipped-header-fields ()))
- (mh-letter-hide-all-skipped-fields))
- (unlock-buffer)))
-
-(defun mh-delete-line (lines)
- "Delete the next LINES lines."
- (delete-region (point) (progn (forward-line lines) (point))))
-
-(defun mh-notate (msg notation offset)
- "Mark MSG with the character NOTATION at position OFFSET.
-Null MSG means the message at cursor.
-If NOTATION is nil then no change in the buffer occurs."
- (save-excursion
- (if (or (null msg)
- (mh-goto-msg msg t t))
- (with-mh-folder-updating (t)
- (beginning-of-line)
- (forward-char offset)
- (let* ((change-stack-flag
- (and (equal offset
- (+ mh-cmd-note mh-scan-field-destination-offset))
- (not (eq notation mh-note-seq))))
- (msg (and change-stack-flag (or msg (mh-get-msg-num nil))))
- (stack (and msg (gethash msg mh-sequence-notation-history)))
- (notation (or notation (char-after))))
- (if stack
- ;; The presence of the stack tells us that we don't need to
- ;; notate the message, since the notation would be replaced
- ;; by a sequence notation. So we will just put the notation
- ;; at the bottom of the stack. If the sequence is deleted,
- ;; the correct notation will be shown.
- (setf (gethash msg mh-sequence-notation-history)
- (reverse (cons notation (cdr (reverse stack)))))
- ;; Since we don't have any sequence notations in the way, just
- ;; notate the scan line.
- (delete-char 1)
- (insert notation))
- (when change-stack-flag
- (mh-thread-update-scan-line-map msg notation offset)))))))
-
-(defun mh-goto-msg (number &optional no-error-if-no-message dont-show)
- "Go to a message\\<mh-folder-mode-map>.
-
-You can enter the message NUMBER either before or after typing
-\\[mh-goto-msg]. In the latter case, Emacs prompts you.
-
-In a program, optional non-nil second argument NO-ERROR-IF-NO-MESSAGE
-means return nil instead of signaling an error if message does not
-exist\; in this case, the cursor is positioned near where the message
-would have been. Non-nil third argument DONT-SHOW means not to show
-the message."
- (interactive "NGo to message: ")
- (setq number (prefix-numeric-value number))
- (let ((point (point))
- (return-value t))
- (goto-char (point-min))
- (unless (re-search-forward (format mh-scan-msg-search-regexp number) nil t)
- (goto-char point)
- (unless no-error-if-no-message
- (error "No message %d" number))
- (setq return-value nil))
- (beginning-of-line)
- (or dont-show (not return-value) (mh-maybe-show number))
- return-value))
-
-(defun mh-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)))))))
-
-(defun mh-set-folder-modified-p (flag)
- "Mark current folder as modified or unmodified according to FLAG."
- (set-buffer-modified-p flag))
-
-(defun mh-find-seq (name)
- "Return sequence NAME."
- (assoc name mh-seq-list))
-
-(defun mh-seq-to-msgs (seq)
- "Return a list of the messages in SEQ."
- (mh-seq-msgs (mh-find-seq seq)))
-
-(defun mh-update-scan-format (fmt width)
- "Return a scan format with the (msg) width in the FMT replaced with WIDTH.
-
-The message number width portion of the format is discovered
-using `mh-scan-msg-format-regexp'. Its replacement is controlled
-with `mh-scan-msg-format-string'."
- (or (and
- (string-match mh-scan-msg-format-regexp fmt)
- (let ((begin (match-beginning 1))
- (end (match-end 1)))
- (concat (substring fmt 0 begin)
- (format mh-scan-msg-format-string width)
- (substring fmt end))))
- fmt))
-
-(defun mh-msg-num-width (folder)
- "Return the width of the largest message number in this FOLDER."
- (or mh-progs (mh-find-path))
- (let ((tmp-buffer (get-buffer-create mh-temp-buffer))
- (width 0))
- (save-excursion
- (set-buffer tmp-buffer)
- (erase-buffer)
- (apply 'call-process
- (expand-file-name mh-scan-prog mh-progs) nil '(t nil) nil
- (list folder "last" "-format" "%(msg)"))
- (goto-char (point-min))
- (if (re-search-forward mh-scan-msg-number-regexp nil 0 1)
- (setq width (length (buffer-substring
- (match-beginning 1) (match-end 1))))))
- width))
-
-(defun mh-add-msgs-to-seq (msgs seq &optional internal-flag dont-annotate-flag)
- "Add MSGS to SEQ.
-
-Remove duplicates and keep sequence sorted. If optional
-INTERNAL-FLAG is non-nil, do not mark the message in the scan
-listing or inform MH of the addition.
-
-If DONT-ANNOTATE-FLAG is non-nil then the annotations in the
-folder buffer are not updated."
- (let ((entry (mh-find-seq seq))
- (internal-seq-flag (mh-internal-seq seq)))
- (if (and msgs (atom msgs)) (setq msgs (list msgs)))
- (if (null entry)
- (setq mh-seq-list
- (cons (mh-make-seq seq (mh-canonicalize-sequence msgs))
- mh-seq-list))
- (if msgs (setcdr entry (mh-canonicalize-sequence
- (append msgs (mh-seq-msgs entry))))))
- (unless internal-flag
- (mh-add-to-sequence seq msgs)
- (when (not dont-annotate-flag)
- (mh-iterate-on-range msg msgs
- (unless (memq msg (cdr entry))
- (mh-add-sequence-notation msg internal-seq-flag)))))))
-
-(defun mh-canonicalize-sequence (msgs)
- "Sort MSGS in decreasing order and remove duplicates."
- (let* ((sorted-msgs (sort (copy-sequence msgs) '>))
- (head sorted-msgs))
- (while (cdr head)
- (if (= (car head) (cadr head))
- (setcdr head (cddr head))
- (setq head (cdr head))))
- sorted-msgs))