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 ;; Shush compiler.
  63 (eval-when-compile
  64   (mh-do-in-xemacs (defvar default-enable-multibyte-characters)))
  65
  66 (defun mh-face-display-function ()
  67   "Display a Face, X-Face, or X-Image-URL header field.
  68 If more than one of these are present, then the first one found
  69 in this order is used."
  70   (save-restriction
  71     (goto-char (point-min))
  72     (re-search-forward "\n\n" (point-max) t)
  73     (narrow-to-region (point-min) (point))
  74     (let* ((case-fold-search t)
  75            (default-enable-multibyte-characters nil)
  76            (face (message-fetch-field "face" t))
  77            (x-face (message-fetch-field "x-face" t))
  78            (url (message-fetch-field "x-image-url" t))
  79            raw type)
  80       (cond (face (setq raw (mh-face-to-png face)
  81                         type 'png))
  82             (x-face (setq raw (mh-uncompface x-face)
  83                           type 'pbm))
  84             (url (setq type 'url))
  85             (t (multiple-value-setq (type raw) (mh-picon-get-image))))
  86       (when type
  87         (goto-char (point-min))
  88         (when (re-search-forward "^from:" (point-max) t)
  89           ;; GNU Emacs
  90           (mh-do-in-gnu-emacs
  91             (if (eq type 'url)
  92                 (mh-x-image-url-display url)
  93               (mh-funcall-if-exists
  94                insert-image (create-image
  95                              raw type t
  96                              :foreground
  97                              (mh-face-foreground 'mh-show-xface nil t)
  98                              :background
  99                              (mh-face-background 'mh-show-xface nil t))
 100                " ")))
 101           ;; XEmacs
 102           (mh-do-in-xemacs
 103             (cond
 104              ((eq type 'url)
 105               (mh-x-image-url-display url))
 106              ((eq type 'png)
 107               (when (featurep 'png)
 108                 (set-extent-begin-glyph
 109                  (make-extent (point) (point))
 110                  (make-glyph (vector 'png ':data (mh-face-to-png face))))))
 111              ;; Try internal xface support if available...
 112              ((and (eq type 'pbm) (featurep 'xface))
 113               (set-glyph-face
 114                (set-extent-begin-glyph
 115                 (make-extent (point) (point))
 116                 (make-glyph (vector 'xface ':data (concat "X-Face: " x-face))))
 117                'mh-show-xface))
 118              ;; Otherwise try external support with x-face...
 119              ((and (eq type 'pbm)
 120                    (fboundp 'x-face-xmas-wl-display-x-face)
 121                    (fboundp 'executable-find) (executable-find "uncompface"))
 122               (mh-funcall-if-exists x-face-xmas-wl-display-x-face))
 123              ;; Picon display
 124              ((and raw (member type '(xpm xbm gif)))
 125               (when (featurep type)
 126                 (set-extent-begin-glyph
 127                  (make-extent (point) (point))
 128                  (make-glyph (vector type ':data raw))))))
 129             (when raw (insert " "))))))))
 130
 131 (defun mh-face-to-png (data)
 132   "Convert base64 encoded DATA to png image."
 133   (with-temp-buffer
 134     (insert data)
 135     (ignore-errors (base64-decode-region (point-min) (point-max)))
 136     (buffer-string)))
 137
 138 (defun mh-uncompface (data)
 139   "Run DATA through `uncompface' to generate bitmap."
 140   (with-temp-buffer
 141     (insert data)
 142     (when (and mh-uncompface-executable
 143                (equal (call-process-region (point-min) (point-max)
 144                                            mh-uncompface-executable t '(t nil))
 145                       0))
 146       (mh-icontopbm)
 147       (buffer-string))))
 148
 149 (defun mh-icontopbm ()
 150   "Elisp substitute for `icontopbm'."
 151   (goto-char (point-min))
 152   (let ((end (point-max)))
 153     (while (re-search-forward "0x\\(..\\)\\(..\\)," nil t)
 154       (save-excursion
 155         (goto-char (point-max))
 156         (insert (string-to-number (match-string 1) 16))
 157         (insert (string-to-number (match-string 2) 16))))
 158     (delete-region (point-min) end)
 159     (goto-char (point-min))
 160     (insert "P4\n48 48\n")))
 161
 162 \f
 163
 164 ;;; Picon Display
 165
 166 ;; XXX: This should be customizable. As a side-effect of setting this
 167 ;;   variable, arrange to reset mh-picon-existing-directory-list to 'unset.
 168 (defvar mh-picon-directory-list
 169   '("~/.picons" "~/.picons/users" "~/.picons/usenix" "~/.picons/news"
 170     "~/.picons/domains" "~/.picons/misc"
 171     "/usr/share/picons/" "/usr/share/picons/users" "/usr/share/picons/usenix"
 172     "/usr/share/picons/news" "/usr/share/picons/domains"
 173     "/usr/share/picons/misc")
 174   "List of directories where picons reside.
 175 The directories are searched for in the order they appear in the list.")
 176
 177 (defvar mh-picon-existing-directory-list 'unset
 178   "List of directories to search in.")
 179
 180 (defvar mh-picon-cache (make-hash-table :test #'equal))
 181
 182 (defvar mh-picon-image-types
 183   (loop for type in '(xpm xbm gif)
 184         when (or (mh-do-in-gnu-emacs
 185                    (ignore-errors
 186                      (mh-funcall-if-exists image-type-available-p type)))
 187                  (mh-do-in-xemacs (featurep type)))
 188         collect type))
 189
 190 (autoload 'message-tokenize-header "sendmail")
 191
 192 (defun* mh-picon-get-image ()
 193   "Find the best possible match and return contents."
 194   (mh-picon-set-directory-list)
 195   (save-restriction
 196     (let* ((from-field (ignore-errors (car (message-tokenize-header
 197                                             (mh-get-header-field "from:")))))
 198            (from (car (ignore-errors
 199                         (mh-funcall-if-exists ietf-drums-parse-address
 200                                               from-field))))
 201            (host (and from
 202                       (string-match "\\([^+]*\\)\\(+.*\\)?@\\(.*\\)" from)
 203                       (downcase (match-string 3 from))))
 204            (user (and host (downcase (match-string 1 from))))
 205            (canonical-address (format "%s@%s" user host))
 206            (cached-value (gethash canonical-address mh-picon-cache))
 207            (host-list (and host (delete "" (split-string host "\\."))))
 208            (match nil))
 209       (cond (cached-value (return-from mh-picon-get-image cached-value))
 210             ((not host-list) (return-from mh-picon-get-image nil)))
 211       (setq match
 212             (block 'loop
 213               ;; u@h search
 214               (loop for dir in mh-picon-existing-directory-list
 215                     do (loop for type in mh-picon-image-types
 216                              ;; [path]user@host
 217                              for file1 = (format "%s/%s.%s"
 218                                                  dir canonical-address type)
 219                              when (file-exists-p file1)
 220                              do (return-from 'loop file1)
 221                              ;; [path]user
 222                              for file2 = (format "%s/%s.%s" dir user type)
 223                              when (file-exists-p file2)
 224                              do (return-from 'loop file2)
 225                              ;; [path]host
 226                              for file3 = (format "%s/%s.%s" dir host type)
 227                              when (file-exists-p file3)
 228                              do (return-from 'loop file3)))
 229               ;; facedb search
 230               ;; Search order for user@foo.net:
 231               ;;   [path]net/foo/user
 232               ;;   [path]net/foo/user/face
 233               ;;   [path]net/user
 234               ;;   [path]net/user/face
 235               ;;   [path]net/foo/unknown
 236               ;;   [path]net/foo/unknown/face
 237               ;;   [path]net/unknown
 238               ;;   [path]net/unknown/face
 239               (loop for u in (list user "unknown")
 240                     do (loop for dir in mh-picon-existing-directory-list
 241                              do (loop for x on host-list by #'cdr
 242                                       for y = (mh-picon-generate-path x u dir)
 243                                       do (loop for type in mh-picon-image-types
 244                                                for z1 = (format "%s.%s" y type)
 245                                                when (file-exists-p z1)
 246                                                do (return-from 'loop z1)
 247                                                for z2 = (format "%s/face.%s"
 248                                                                 y type)
 249                                                when (file-exists-p z2)
 250                                                do (return-from 'loop z2)))))))
 251       (setf (gethash canonical-address mh-picon-cache)
 252             (mh-picon-file-contents match)))))
 253
 254 (defun mh-picon-set-directory-list ()
 255   "Update `mh-picon-existing-directory-list' if needed."
 256   (when (eq mh-picon-existing-directory-list 'unset)
 257     (setq mh-picon-existing-directory-list
 258           (loop for x in mh-picon-directory-list
 259                 when (file-directory-p x) collect x))))
 260
 261 (defun mh-picon-generate-path (host-list user directory)
 262   "Generate the image file path.
 263 HOST-LIST is the parsed host address of the email address, USER
 264 the username and DIRECTORY is the directory relative to which the
 265 path is generated."
 266   (loop with acc = ""
 267         for elem in host-list
 268         do (setq acc (format "%s/%s" elem acc))
 269         finally return (format "%s/%s%s" directory acc user)))
 270
 271 (defun mh-picon-file-contents (file)
 272   "Return details about FILE.
 273 A list of consisting of a symbol for the type of the file and the
 274 file contents as a string is returned. If FILE is nil, then both
 275 elements of the list are nil."
 276   (if (stringp file)
 277       (with-temp-buffer
 278         (let ((type (and (string-match ".*\\.\\(...\\)$" file)
 279                          (intern (match-string 1 file)))))
 280           (insert-file-contents-literally file)
 281           (values type (buffer-string))))
 282     (values nil nil)))
 283
 284 \f
 285
 286 ;;; X-Image-URL Display
 287
 288 (defvar mh-x-image-scaling-function
 289   (cond ((executable-find "convert")
 290          'mh-x-image-scale-with-convert)
 291         ((and (executable-find "anytopnm") (executable-find "pnmscale")
 292               (executable-find "pnmtopng"))
 293          'mh-x-image-scale-with-pnm)
 294         (t 'ignore))
 295   "Function to use to scale image to proper size.")
 296
 297 (defun mh-x-image-scale-with-pnm (input output)
 298   "Scale image in INPUT file and write to OUTPUT file using pnm tools."
 299   (let ((res (shell-command-to-string
 300               (format "anytopnm < %s | pnmscale -xysize 96 48 | pnmtopng > %s"
 301                       input output))))
 302     (unless (equal res "")
 303       (delete-file output))))
 304
 305 (defun mh-x-image-scale-with-convert (input output)
 306   "Scale image in INPUT file and write to OUTPUT file using ImageMagick."
 307   (call-process "convert" nil nil nil "-geometry" "96x48" input output))
 308
 309 (defvar mh-wget-executable nil)
 310 (defvar mh-wget-choice
 311   (or (and (setq mh-wget-executable (executable-find "wget")) 'wget)
 312       (and (setq mh-wget-executable (executable-find "fetch")) 'fetch)
 313       (and (setq mh-wget-executable (executable-find "curl")) 'curl)))
 314 (defvar mh-wget-option
 315   (cdr (assoc mh-wget-choice '((curl . "-o") (fetch . "-o") (wget . "-O")))))
 316 (defvar mh-x-image-temp-file nil)
 317 (defvar mh-x-image-url nil)
 318 (defvar mh-x-image-marker nil)
 319 (defvar mh-x-image-url-cache-file nil)
 320
 321 (defun mh-x-image-url-display (url)
 322   "Display image from location URL.
 323 If the URL isn't present in the cache then it is fetched with wget."
 324   (let* ((cache-filename (mh-x-image-url-cache-canonicalize url))
 325          (state (mh-x-image-get-download-state cache-filename))
 326          (marker (set-marker (make-marker) (point))))
 327     (set (make-local-variable 'mh-x-image-marker) marker)
 328     (cond ((not (mh-x-image-url-sane-p url)))
 329           ((eq state 'ok)
 330            (mh-x-image-display cache-filename marker))
 331           ((or (not mh-wget-executable)
 332                (eq mh-x-image-scaling-function 'ignore)))
 333           ((eq state 'never))
 334           ((not mh-fetch-x-image-url)
 335            (set-marker marker nil))
 336           ((eq state 'try-again)
 337            (mh-x-image-set-download-state cache-filename nil)
 338            (mh-x-image-url-fetch-image url cache-filename marker
 339                                        'mh-x-image-scale-and-display))
 340           ((and (eq mh-fetch-x-image-url 'ask)
 341                 (not (y-or-n-p (format "Fetch %s? " url))))
 342            (mh-x-image-set-download-state cache-filename 'never))
 343           ((eq state nil)
 344            (mh-x-image-url-fetch-image url cache-filename marker
 345                                        'mh-x-image-scale-and-display)))))
 346
 347 (defvar mh-x-image-cache-directory nil
 348   "Directory where X-Image-URL images are cached.")
 349
 350 ;;;###mh-autoload
 351 (defun mh-set-x-image-cache-directory (directory)
 352   "Set the DIRECTORY where X-Image-URL images are cached.
 353 This is only done if `mh-x-image-cache-directory' is nil."
 354   ;; XXX This is the code that used to be in find-user-path. Is there
 355   ;; a good reason why the variable is set conditionally? Do we expect
 356   ;; the user to have set this variable directly?
 357   (unless mh-x-image-cache-directory
 358     (setq mh-x-image-cache-directory directory)))
 359
 360 (defun mh-x-image-url-cache-canonicalize (url)
 361   "Canonicalize URL.
 362 Replace the ?/ character with a ?! character and append .png.
 363 Also replaces special characters with `mh-url-hexify-string'
 364 since not all characters, such as :, are legal within Windows
 365 filenames. See URL
 366 `http://msdn.microsoft.com/library/default.asp?url=/library/en-us/fileio/fs/naming_a_file.asp'."
 367   (format "%s/%s.png" mh-x-image-cache-directory
 368           (mh-url-hexify-string
 369            (with-temp-buffer
 370              (insert url)
 371              (mh-replace-string "/" "!")
 372              (buffer-string)))))
 373
 374 (defun mh-x-image-get-download-state (file)
 375   "Check the state of FILE by following any symbolic links."
 376   (unless (file-exists-p mh-x-image-cache-directory)
 377     (call-process "mkdir" nil nil nil mh-x-image-cache-directory))
 378   (cond ((file-symlink-p file)
 379          (intern (file-name-nondirectory (file-chase-links file))))
 380         ((not (file-exists-p file)) nil)
 381         (t 'ok)))
 382
 383 (defun mh-x-image-set-download-state (file data)
 384   "Setup a symbolic link from FILE to DATA."
 385   (if data
 386       (make-symbolic-link (symbol-name data) file t)
 387     (delete-file file)))
 388
 389 (defun mh-x-image-url-sane-p (url)
 390   "Check if URL is something sensible."
 391   (let ((len (length url)))
 392     (cond ((< len 5) nil)
 393           ((not (equal (substring url 0 5) "http:")) nil)
 394           ((> len 100) nil)
 395           (t t))))
 396
 397 (defun mh-x-image-display (image marker)
 398   "Display IMAGE at MARKER."
 399   (save-excursion
 400     (set-buffer (marker-buffer marker))
 401     (let ((buffer-read-only nil)
 402           (default-enable-multibyte-characters nil)
 403           (buffer-modified-flag (buffer-modified-p)))
 404       (unwind-protect
 405           (when (and (file-readable-p image) (not (file-symlink-p image))
 406                      (eq marker mh-x-image-marker))
 407             (goto-char marker)
 408             (mh-do-in-gnu-emacs
 409               (mh-funcall-if-exists insert-image (create-image image 'png)))
 410             (mh-do-in-xemacs
 411               (when (featurep 'png)
 412                 (set-extent-begin-glyph
 413                  (make-extent (point) (point))
 414                  (make-glyph
 415                   (vector 'png ':data (with-temp-buffer
 416                                         (insert-file-contents-literally image)
 417                                         (buffer-string))))))))
 418         (set-buffer-modified-p buffer-modified-flag)))))
 419
 420 (defun mh-x-image-url-fetch-image (url cache-file marker sentinel)
 421   "Fetch and display the image specified by URL.
 422 After the image is fetched, it is stored in CACHE-FILE. It will
 423 be displayed in a buffer and position specified by MARKER. The
 424 actual display is carried out by the SENTINEL function."
 425   (if mh-wget-executable
 426       (let ((buffer (get-buffer-create (generate-new-buffer-name
 427                                         mh-temp-fetch-buffer)))
 428             (filename (or (mh-funcall-if-exists make-temp-file "mhe-fetch")
 429                           (expand-file-name (make-temp-name "~/mhe-fetch")))))
 430         (save-excursion
 431           (set-buffer buffer)
 432           (set (make-local-variable 'mh-x-image-url-cache-file) cache-file)
 433           (set (make-local-variable 'mh-x-image-marker) marker)
 434           (set (make-local-variable 'mh-x-image-temp-file) filename))
 435         (set-process-sentinel
 436          (start-process "*mh-x-image-url-fetch*" buffer
 437                         mh-wget-executable mh-wget-option filename url)
 438          sentinel))
 439     ;; Temporary failure
 440     (mh-x-image-set-download-state cache-file 'try-again)))
 441
 442 (defun mh-x-image-scale-and-display (process change)
 443   "When the wget PROCESS terminates scale and display image.
 444 The argument CHANGE is ignored."
 445   (when (eq (process-status process) 'exit)
 446     (let (marker temp-file cache-filename wget-buffer)
 447       (save-excursion
 448         (set-buffer (setq wget-buffer (process-buffer process)))
 449         (setq marker mh-x-image-marker
 450               cache-filename mh-x-image-url-cache-file
 451               temp-file mh-x-image-temp-file))
 452       (cond
 453        ;; Check if we have `convert'
 454        ((eq mh-x-image-scaling-function 'ignore)
 455         (message "The \"convert\" program is needed to display X-Image-URL")
 456         (mh-x-image-set-download-state cache-filename 'try-again))
 457        ;; Scale fetched image
 458        ((and (funcall mh-x-image-scaling-function temp-file cache-filename)
 459              nil))
 460        ;; Attempt to display image if we have it
 461        ((file-exists-p cache-filename)
 462         (mh-x-image-display cache-filename marker))
 463        ;; We didn't find the image. Should we try to display it the next time?
 464        (t (mh-x-image-set-download-state cache-filename 'try-again)))
 465       (ignore-errors
 466         (set-marker marker nil)
 467         (delete-process process)
 468         (kill-buffer wget-buffer)
 469         (delete-file temp-file)))))
 470
 471 (provide 'mh-xface)
 472
 473 ;; Local Variables:
 474 ;; indent-tabs-mode: nil
 475 ;; sentence-end-double-space: nil
 476 ;; End:
 477
 478 ;; arch-tag: a79dd33f-d0e5-4b19-a53a-be690f90229a
 479 ;;; mh-xface.el ends here