diff options
Diffstat (limited to 'lisp/mh-e/mh-xface.el')
| -rw-r--r-- | lisp/mh-e/mh-xface.el | 479 |
1 files changed, 479 insertions, 0 deletions
diff --git a/lisp/mh-e/mh-xface.el b/lisp/mh-e/mh-xface.el new file mode 100644 index 00000000000..58d175f5470 --- /dev/null +++ b/lisp/mh-e/mh-xface.el @@ -0,0 +1,479 @@ +;;; 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))) + +;; 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 'mh-show-xface nil t) + :background + (mh-face-background '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 `mh-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 + (mh-url-hexify-string + (with-temp-buffer + (insert url) + (mh-replace-string "/" "!") + (buffer-string))))) + +(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: + +;; arch-tag: a79dd33f-d0e5-4b19-a53a-be690f90229a +;;; mh-xface.el ends here |