lisp/mh-e/mh-xface.el

   1 ;;; mh-xface.el --- MH-E X-Face and Face header field display
   2
   3 ;; Copyright (C) 2002, 2003, 2005, 2006 Free Software Foundation, Inc.
   4
   5 ;; Author: Bill Wohler <wohler@newt.com>
   6 ;; Maintainer: Bill Wohler <wohler@newt.com>
   7 ;; Keywords: mail
   8 ;; See: mh-e.el
   9
  10 ;; This file is part of GNU Emacs.
  11
  12 ;; GNU Emacs is free software; you can redistribute it and/or modify
  13 ;; it under the terms of the GNU General Public License as published by
  14 ;; the Free Software Foundation; either version 2, or (at your option)
  15 ;; any later version.
  16
  17 ;; GNU Emacs is distributed in the hope that it will be useful,
  18 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  19 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  20 ;; GNU General Public License for more details.
  21
  22 ;; You should have received a copy of the GNU General Public License
  23 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  24 ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
  25 ;; Boston, MA 02110-1301, USA.
  26
  27 ;;; Commentary:
  28
  29 ;;; Change Log:
  30
  31 ;;; Code:
  32
  33 (require 'mh-e)
  34 (mh-require-cl)
  35
  36 (autoload 'message-fetch-field "message")
  37
  38 (defvar mh-show-xface-function
  39   (cond ((and mh-xemacs-flag (locate-library "x-face") (not (featurep 'xface)))
  40          (load "x-face" t t)
  41          #'mh-face-display-function)
  42         ((>= emacs-major-version 21)
  43          #'mh-face-display-function)
  44         (t #'ignore))
  45   "Determine at run time what function should be called to display X-Face.")
  46
  47 (defvar mh-uncompface-executable
  48   (and (fboundp 'executable-find) (executable-find "uncompface")))
  49
  50 \f
  51
  52 ;;; X-Face Display
  53
  54 ;;;###mh-autoload
  55 (defun mh-show-xface ()
  56   "Display X-Face."
  57   (when (and window-system mh-show-use-xface-flag
  58              (or mh-decode-mime-flag mh-mhl-format-file
  59                  mh-clean-message-header-flag))
  60     (funcall mh-show-xface-function)))
  61
  62 (defmacro mh-face-foreground-compat (face &optional frame inherit)
  63   "Return the foreground color name of FACE, or nil if unspecified.
  64 See documentation for `face-foreground' for a description of the
  65 arguments FACE, FRAME, and INHERIT.
  66
  67 Calls `face-foreground' correctly in older environments. Versions
  68 of Emacs prior to version 22 lacked an INHERIT argument which
  69 when t tells `face-foreground' to consider an inherited value for
  70 the foreground if the face does not define one itself."
  71   (if (>= emacs-major-version 22)
  72       `(face-foreground ,face ,frame ,inherit)
  73     `(face-foreground ,face ,frame)))
  74
  75 (defmacro mh-face-background-compat(face &optional frame inherit)
  76   "Return the background color name of face, or nil if unspecified.
  77 See documentation for `back-foreground' for a description of the
  78 arguments FACE, FRAME, and INHERIT.
  79
  80 Calls `face-background' correctly in older environments. Versions
  81 of Emacs prior to version 22 lacked an INHERIT argument which
  82 when t tells `face-background' to consider an inherited value for
  83 the background if the face does not define one itself."
  84   (if (>= emacs-major-version 22)
  85       `(face-background ,face ,frame ,inherit)
  86     `(face-background ,face ,frame)))
  87
  88 ;; Shush compiler.
  89 (eval-when-compile
  90   (mh-do-in-xemacs (defvar default-enable-multibyte-characters)))
  91
  92 (defun mh-face-display-function ()
  93   "Display a Face, X-Face, or X-Image-URL header field.
  94 If more than one of these are present, then the first one found
  95 in this order is used."
  96   (save-restriction
  97     (goto-char (point-min))
  98     (re-search-forward "\n\n" (point-max) t)
  99     (narrow-to-region (point-min) (point))
 100     (let* ((case-fold-search t)
 101            (default-enable-multibyte-characters nil)
 102            (face (message-fetch-field "face" t))
 103            (x-face (message-fetch-field "x-face" t))
 104            (url (message-fetch-field "x-image-url" t))
 105            raw type)
 106       (cond (face (setq raw (mh-face-to-png face)
 107                         type 'png))
 108             (x-face (setq raw (mh-uncompface x-face)
 109                           type 'pbm))
 110             (url (setq type 'url))
 111             (t (multiple-value-setq (type raw) (mh-picon-get-image))))
 112       (when type
 113         (goto-char (point-min))
 114         (when (re-search-forward "^from:" (point-max) t)
 115           ;; GNU Emacs
 116           (mh-do-in-gnu-emacs
 117             (if (eq type 'url)
 118                 (mh-x-image-url-display url)
 119               (mh-funcall-if-exists
 120                insert-image (create-image
 121                              raw type t
 122                              :foreground
 123                              (mh-face-foreground-compat 'mh-show-xface nil t)
 124                              :background
 125                              (mh-face-background-compat 'mh-show-xface nil t))
 126                " ")))
 127           ;; XEmacs
 128           (mh-do-in-xemacs
 129             (cond
 130              ((eq type 'url)
 131               (mh-x-image-url-display url))
 132              ((eq type 'png)
 133               (when (featurep 'png)
 134                 (set-extent-begin-glyph
 135                  (make-extent (point) (point))
 136                  (make-glyph (vector 'png ':data (mh-face-to-png face))))))
 137              ;; Try internal xface support if available...
 138              ((and (eq type 'pbm) (featurep 'xface))
 139               (set-glyph-face
 140                (set-extent-begin-glyph
 141                 (make-extent (point) (point))
 142                 (make-glyph (vector 'xface ':data (concat "X-Face: " x-face))))
 143                'mh-show-xface))
 144              ;; Otherwise try external support with x-face...
 145              ((and (eq type 'pbm)
 146                    (fboundp 'x-face-xmas-wl-display-x-face)
 147                    (fboundp 'executable-find) (executable-find "uncompface"))
 148               (mh-funcall-if-exists x-face-xmas-wl-display-x-face))
 149              ;; Picon display
 150              ((and raw (member type '(xpm xbm gif)))
 151               (when (featurep type)
 152                 (set-extent-begin-glyph
 153                  (make-extent (point) (point))
 154                  (make-glyph (vector type ':data raw))))))
 155             (when raw (insert " "))))))))
 156
 157 (defun mh-face-to-png (data)
 158   "Convert base64 encoded DATA to png image."
 159   (with-temp-buffer
 160     (insert data)
 161     (ignore-errors (base64-decode-region (point-min) (point-max)))
 162     (buffer-string)))
 163
 164 (defun mh-uncompface (data)
 165   "Run DATA through `uncompface' to generate bitmap."
 166   (with-temp-buffer
 167     (insert data)
 168     (when (and mh-uncompface-executable
 169                (equal (call-process-region (point-min) (point-max)
 170                                            mh-uncompface-executable t '(t nil))
 171                       0))
 172       (mh-icontopbm)
 173       (buffer-string))))
 174
 175 (defun mh-icontopbm ()
 176   "Elisp substitute for `icontopbm'."
 177   (goto-char (point-min))
 178   (let ((end (point-max)))
 179     (while (re-search-forward "0x\\(..\\)\\(..\\)," nil t)
 180       (save-excursion
 181         (goto-char (point-max))
 182         (insert (string-to-number (match-string 1) 16))
 183         (insert (string-to-number (match-string 2) 16))))
 184     (delete-region (point-min) end)
 185     (goto-char (point-min))
 186     (insert "P4\n48 48\n")))
 187
 188 \f
 189
 190 ;;; Picon Display
 191
 192 ;; XXX: This should be customizable. As a side-effect of setting this
 193 ;;   variable, arrange to reset mh-picon-existing-directory-list to 'unset.
 194 (defvar mh-picon-directory-list
 195   '("~/.picons" "~/.picons/users" "~/.picons/usenix" "~/.picons/news"
 196     "~/.picons/domains" "~/.picons/misc"
 197     "/usr/share/picons/" "/usr/share/picons/users" "/usr/share/picons/usenix"
 198     "/usr/share/picons/news" "/usr/share/picons/domains"
 199     "/usr/share/picons/misc")
 200   "List of directories where picons reside.
 201 The directories are searched for in the order they appear in the list.")
 202
 203 (defvar mh-picon-existing-directory-list 'unset
 204   "List of directories to search in.")
 205
 206 (defvar mh-picon-cache (make-hash-table :test #'equal))
 207
 208 (defvar mh-picon-image-types
 209   (loop for type in '(xpm xbm gif)
 210         when (or (mh-do-in-gnu-emacs
 211                    (ignore-errors
 212                      (mh-funcall-if-exists image-type-available-p type)))
 213                  (mh-do-in-xemacs (featurep type)))
 214         collect type))
 215
 216 (autoload 'message-tokenize-header "sendmail")
 217
 218 (defun* mh-picon-get-image ()
 219   "Find the best possible match and return contents."
 220   (mh-picon-set-directory-list)
 221   (save-restriction
 222     (let* ((from-field (ignore-errors (car (message-tokenize-header
 223                                             (mh-get-header-field "from:")))))
 224            (from (car (ignore-errors
 225                         (mh-funcall-if-exists ietf-drums-parse-address
 226                                               from-field))))
 227            (host (and from
 228                       (string-match "\\([^+]*\\)\\(+.*\\)?@\\(.*\\)" from)
 229                       (downcase (match-string 3 from))))
 230            (user (and host (downcase (match-string 1 from))))
 231            (canonical-address (format "%s@%s" user host))
 232            (cached-value (gethash canonical-address mh-picon-cache))
 233            (host-list (and host (delete "" (split-string host "\\."))))
 234            (match nil))
 235       (cond (cached-value (return-from mh-picon-get-image cached-value))
 236             ((not host-list) (return-from mh-picon-get-image nil)))
 237       (setq match
 238             (block 'loop
 239               ;; u@h search
 240               (loop for dir in mh-picon-existing-directory-list
 241                     do (loop for type in mh-picon-image-types
 242                              ;; [path]user@host
 243                              for file1 = (format "%s/%s.%s"
 244                                                  dir canonical-address type)
 245                              when (file-exists-p file1)
 246                              do (return-from 'loop file1)
 247                              ;; [path]user
 248                              for file2 = (format "%s/%s.%s" dir user type)
 249                              when (file-exists-p file2)
 250                              do (return-from 'loop file2)
 251                              ;; [path]host
 252                              for file3 = (format "%s/%s.%s" dir host type)
 253                              when (file-exists-p file3)
 254                              do (return-from 'loop file3)))
 255               ;; facedb search
 256               ;; Search order for user@foo.net:
 257               ;;   [path]net/foo/user
 258               ;;   [path]net/foo/user/face
 259               ;;   [path]net/user
 260               ;;   [path]net/user/face
 261               ;;   [path]net/foo/unknown
 262               ;;   [path]net/foo/unknown/face
 263               ;;   [path]net/unknown
 264               ;;   [path]net/unknown/face
 265               (loop for u in (list user "unknown")
 266                     do (loop for dir in mh-picon-existing-directory-list
 267                              do (loop for x on host-list by #'cdr
 268                                       for y = (mh-picon-generate-path x u dir)
 269                                       do (loop for type in mh-picon-image-types
 270                                                for z1 = (format "%s.%s" y type)
 271                                                when (file-exists-p z1)
 272                                                do (return-from 'loop z1)
 273                                                for z2 = (format "%s/face.%s"
 274                                                                 y type)
 275                                                when (file-exists-p z2)
 276                                                do (return-from 'loop z2)))))))
 277       (setf (gethash canonical-address mh-picon-cache)
 278             (mh-picon-file-contents match)))))
 279
 280 (defun mh-picon-set-directory-list ()
 281   "Update `mh-picon-existing-directory-list' if needed."
 282   (when (eq mh-picon-existing-directory-list 'unset)
 283     (setq mh-picon-existing-directory-list
 284           (loop for x in mh-picon-directory-list
 285                 when (file-directory-p x) collect x))))
 286
 287 (defun mh-picon-generate-path (host-list user directory)
 288   "Generate the image file path.
 289 HOST-LIST is the parsed host address of the email address, USER
 290 the username and DIRECTORY is the directory relative to which the
 291 path is generated."
 292   (loop with acc = ""
 293         for elem in host-list
 294         do (setq acc (format "%s/%s" elem acc))
 295         finally return (format "%s/%s%s" directory acc user)))
 296
 297 (defun mh-picon-file-contents (file)
 298   "Return details about FILE.
 299 A list of consisting of a symbol for the type of the file and the
 300 file contents as a string is returned. If FILE is nil, then both
 301 elements of the list are nil."
 302   (if (stringp file)
 303       (with-temp-buffer
 304         (let ((type (and (string-match ".*\\.\\(...\\)$" file)
 305                          (intern (match-string 1 file)))))
 306           (insert-file-contents-literally file)
 307           (values type (buffer-string))))
 308     (values nil nil)))
 309
 310 \f
 311
 312 ;;; X-Image-URL Display
 313
 314 (defvar mh-x-image-scaling-function
 315   (cond ((executable-find "convert")
 316          'mh-x-image-scale-with-convert)
 317         ((and (executable-find "anytopnm") (executable-find "pnmscale")
 318               (executable-find "pnmtopng"))
 319          'mh-x-image-scale-with-pnm)
 320         (t 'ignore))
 321   "Function to use to scale image to proper size.")
 322
 323 (defun mh-x-image-scale-with-pnm (input output)
 324   "Scale image in INPUT file and write to OUTPUT file using pnm tools."
 325   (let ((res (shell-command-to-string
 326               (format "anytopnm < %s | pnmscale -xysize 96 48 | pnmtopng > %s"
 327                       input output))))
 328     (unless (equal res "")
 329       (delete-file output))))
 330
 331 (defun mh-x-image-scale-with-convert (input output)
 332   "Scale image in INPUT file and write to OUTPUT file using ImageMagick."
 333   (call-process "convert" nil nil nil "-geometry" "96x48" input output))
 334
 335 (defvar mh-wget-executable nil)
 336 (defvar mh-wget-choice
 337   (or (and (setq mh-wget-executable (executable-find "wget")) 'wget)
 338       (and (setq mh-wget-executable (executable-find "fetch")) 'fetch)
 339       (and (setq mh-wget-executable (executable-find "curl")) 'curl)))
 340 (defvar mh-wget-option
 341   (cdr (assoc mh-wget-choice '((curl . "-o") (fetch . "-o") (wget . "-O")))))
 342 (defvar mh-x-image-temp-file nil)
 343 (defvar mh-x-image-url nil)
 344 (defvar mh-x-image-marker nil)
 345 (defvar mh-x-image-url-cache-file nil)
 346
 347 (defun mh-x-image-url-display (url)
 348   "Display image from location URL.
 349 If the URL isn't present in the cache then it is fetched with wget."
 350   (let* ((cache-filename (mh-x-image-url-cache-canonicalize url))
 351          (state (mh-x-image-get-download-state cache-filename))
 352          (marker (set-marker (make-marker) (point))))
 353     (set (make-local-variable 'mh-x-image-marker) marker)
 354     (cond ((not (mh-x-image-url-sane-p url)))
 355           ((eq state 'ok)
 356            (mh-x-image-display cache-filename marker))
 357           ((or (not mh-wget-executable)
 358                (eq mh-x-image-scaling-function 'ignore)))
 359           ((eq state 'never))
 360           ((not mh-fetch-x-image-url)
 361            (set-marker marker nil))
 362           ((eq state 'try-again)
 363            (mh-x-image-set-download-state cache-filename nil)
 364            (mh-x-image-url-fetch-image url cache-filename marker
 365                                        'mh-x-image-scale-and-display))
 366           ((and (eq mh-fetch-x-image-url 'ask)
 367                 (not (y-or-n-p (format "Fetch %s? " url))))
 368            (mh-x-image-set-download-state cache-filename 'never))
 369           ((eq state nil)
 370            (mh-x-image-url-fetch-image url cache-filename marker
 371                                        'mh-x-image-scale-and-display)))))
 372
 373 (defvar mh-x-image-cache-directory nil
 374   "Directory where X-Image-URL images are cached.")
 375
 376 ;;;###mh-autoload
 377 (defun mh-set-x-image-cache-directory (directory)
 378   "Set the DIRECTORY where X-Image-URL images are cached.
 379 This is only done if `mh-x-image-cache-directory' is nil."
 380   ;; XXX This is the code that used to be in find-user-path. Is there
 381   ;; a good reason why the variable is set conditionally? Do we expect
 382   ;; the user to have set this variable directly?
 383   (unless mh-x-image-cache-directory
 384     (setq mh-x-image-cache-directory directory)))
 385
 386 (defun mh-x-image-url-cache-canonicalize (url)
 387   "Canonicalize URL.
 388 Replace the ?/ character with a ?! character and append .png.
 389 Also replaces special characters with `url-hexify-string' since
 390 not all characters, such as :, are legal within Windows
 391 filenames. See URL `http://msdn.microsoft.com/library/default.asp?url=/library/en-us/fileio/fs/naming_a_file.asp'."
 392   (format "%s/%s.png" mh-x-image-cache-directory
 393           (url-hexify-string
 394            (with-temp-buffer
 395              (insert url)
 396              (mh-replace-string "/" "!")
 397              (buffer-string)))))
 398
 399 ;; Copy of constant from url-util.el in Emacs 22; needed by Emacs 21.
 400 (if (not (boundp 'url-unreserved-chars))
 401     (defconst url-unreserved-chars
 402       '(
 403         ?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
 404         ?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
 405         ?0 ?1 ?2 ?3 ?4 ?5 ?6 ?7 ?8 ?9
 406         ?- ?_ ?. ?! ?~ ?* ?' ?\( ?\))
 407       "A list of characters that are _NOT_ reserved in the URL spec.
 408 This is taken from RFC 2396."))
 409
 410 (mh-defun-compat url-hexify-string (str)
 411   "Escape characters in a string.
 412 This is a copy of the function of the same name from url-util.el
 413 in Emacs 22; needed by Emacs 21."
 414   (mapconcat
 415    (lambda (char)
 416      ;; Fixme: use a char table instead.
 417      (if (not (memq char url-unreserved-chars))
 418          (if (> char 255)
 419                (error "Hexifying multibyte character %s" str)
 420            (format "%%%02X" char))
 421        (char-to-string char)))
 422    str ""))
 423
 424 (defun mh-x-image-get-download-state (file)
 425   "Check the state of FILE by following any symbolic links."
 426   (unless (file-exists-p mh-x-image-cache-directory)
 427     (call-process "mkdir" nil nil nil mh-x-image-cache-directory))
 428   (cond ((file-symlink-p file)
 429          (intern (file-name-nondirectory (file-chase-links file))))
 430         ((not (file-exists-p file)) nil)
 431         (t 'ok)))
 432
 433 (defun mh-x-image-set-download-state (file data)
 434   "Setup a symbolic link from FILE to DATA."
 435   (if data
 436       (make-symbolic-link (symbol-name data) file t)
 437     (delete-file file)))
 438
 439 (defun mh-x-image-url-sane-p (url)
 440   "Check if URL is something sensible."
 441   (let ((len (length url)))
 442     (cond ((< len 5) nil)
 443           ((not (equal (substring url 0 5) "http:")) nil)
 444           ((> len 100) nil)
 445           (t t))))
 446
 447 (defun mh-x-image-display (image marker)
 448   "Display IMAGE at MARKER."
 449   (save-excursion
 450     (set-buffer (marker-buffer marker))
 451     (let ((buffer-read-only nil)
 452           (default-enable-multibyte-characters nil)
 453           (buffer-modified-flag (buffer-modified-p)))
 454       (unwind-protect
 455           (when (and (file-readable-p image) (not (file-symlink-p image))
 456                      (eq marker mh-x-image-marker))
 457             (goto-char marker)
 458             (mh-do-in-gnu-emacs
 459               (mh-funcall-if-exists insert-image (create-image image 'png)))
 460             (mh-do-in-xemacs
 461               (when (featurep 'png)
 462                 (set-extent-begin-glyph
 463                  (make-extent (point) (point))
 464                  (make-glyph
 465                   (vector 'png ':data (with-temp-buffer
 466                                         (insert-file-contents-literally image)
 467                                         (buffer-string))))))))
 468         (set-buffer-modified-p buffer-modified-flag)))))
 469
 470 (defun mh-x-image-url-fetch-image (url cache-file marker sentinel)
 471   "Fetch and display the image specified by URL.
 472 After the image is fetched, it is stored in CACHE-FILE. It will
 473 be displayed in a buffer and position specified by MARKER. The
 474 actual display is carried out by the SENTINEL function."
 475   (if mh-wget-executable
 476       (let ((buffer (get-buffer-create (generate-new-buffer-name
 477                                         mh-temp-fetch-buffer)))
 478             (filename (or (mh-funcall-if-exists make-temp-file "mhe-fetch")
 479                           (expand-file-name (make-temp-name "~/mhe-fetch")))))
 480         (save-excursion
 481           (set-buffer buffer)
 482           (set (make-local-variable 'mh-x-image-url-cache-file) cache-file)
 483           (set (make-local-variable 'mh-x-image-marker) marker)
 484           (set (make-local-variable 'mh-x-image-temp-file) filename))
 485         (set-process-sentinel
 486          (start-process "*mh-x-image-url-fetch*" buffer
 487                         mh-wget-executable mh-wget-option filename url)
 488          sentinel))
 489     ;; Temporary failure
 490     (mh-x-image-set-download-state cache-file 'try-again)))
 491
 492 (defun mh-x-image-scale-and-display (process change)
 493   "When the wget PROCESS terminates scale and display image.
 494 The argument CHANGE is ignored."
 495   (when (eq (process-status process) 'exit)
 496     (let (marker temp-file cache-filename wget-buffer)
 497       (save-excursion
 498         (set-buffer (setq wget-buffer (process-buffer process)))
 499         (setq marker mh-x-image-marker
 500               cache-filename mh-x-image-url-cache-file
 501               temp-file mh-x-image-temp-file))
 502       (cond
 503        ;; Check if we have `convert'
 504        ((eq mh-x-image-scaling-function 'ignore)
 505         (message "The \"convert\" program is needed to display X-Image-URL")
 506         (mh-x-image-set-download-state cache-filename 'try-again))
 507        ;; Scale fetched image
 508        ((and (funcall mh-x-image-scaling-function temp-file cache-filename)
 509              nil))
 510        ;; Attempt to display image if we have it
 511        ((file-exists-p cache-filename)
 512         (mh-x-image-display cache-filename marker))
 513        ;; We didn't find the image. Should we try to display it the next time?
 514        (t (mh-x-image-set-download-state cache-filename 'try-again)))
 515       (ignore-errors
 516         (set-marker marker nil)
 517         (delete-process process)
 518         (kill-buffer wget-buffer)
 519         (delete-file temp-file)))))
 520
 521 (provide 'mh-xface)
 522
 523 ;; Local Variables:
 524 ;; indent-tabs-mode: nil
 525 ;; sentence-end-double-space: nil
 526 ;; End:
 527
 528 ;; arch-tag: a79dd33f-d0e5-4b19-a53a-be690f90229a
 529 ;;; mh-xface.el ends here