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, 2007, 2008 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 3, 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 (featurep 'xemacs) (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
  64 (defun mh-face-display-function ()
  65   "Display a Face, X-Face, or X-Image-URL header field.
  66 If more than one of these are present, then the first one found
  67 in this order is used."
  68   (save-restriction
  69     (goto-char (point-min))
  70     (re-search-forward "\n\n" (point-max) t)
  71     (narrow-to-region (point-min) (point))
  72     (let* ((case-fold-search t)
  73            (face (message-fetch-field "face" t))
  74            (x-face (message-fetch-field "x-face" t))
  75            (url (message-fetch-field "x-image-url" t))
  76            raw type)
  77       (cond (face (setq raw (mh-face-to-png face)
  78                         type 'png))
  79             (x-face (setq raw (mh-uncompface x-face)
  80                           type 'pbm))
  81             (url (setq type 'url))
  82             (t (multiple-value-setq (type raw) (mh-picon-get-image))))
  83       (when type
  84         (goto-char (point-min))
  85         (when (re-search-forward "^from:" (point-max) t)
  86           ;; GNU Emacs
  87           (mh-do-in-gnu-emacs
  88             (if (eq type 'url)
  89                 (mh-x-image-url-display url)
  90               (mh-funcall-if-exists
  91                insert-image (create-image
  92                              raw type t
  93                              :foreground
  94                              (mh-face-foreground 'mh-show-xface nil t)
  95                              :background
  96                              (mh-face-background 'mh-show-xface nil t))
  97                " ")))
  98           ;; XEmacs
  99           (mh-do-in-xemacs
 100             (cond
 101              ((eq type 'url)
 102               (mh-x-image-url-display url))
 103              ((eq type 'png)
 104               (when (featurep 'png)
 105                 (set-extent-begin-glyph
 106                  (make-extent (point) (point))
 107                  (make-glyph (vector 'png ':data (mh-face-to-png face))))))
 108              ;; Try internal xface support if available...
 109              ((and (eq type 'pbm) (featurep 'xface))
 110               (set-glyph-face
 111                (set-extent-begin-glyph
 112                 (make-extent (point) (point))
 113                 (make-glyph (vector 'xface ':data (concat "X-Face: " x-face))))
 114                'mh-show-xface))
 115              ;; Otherwise try external support with x-face...
 116              ((and (eq type 'pbm)
 117                    (fboundp 'x-face-xmas-wl-display-x-face)
 118                    (fboundp 'executable-find) (executable-find "uncompface"))
 119               (mh-funcall-if-exists x-face-xmas-wl-display-x-face))
 120              ;; Picon display
 121              ((and raw (member type '(xpm xbm gif)))
 122               (when (featurep type)
 123                 (set-extent-begin-glyph
 124                  (make-extent (point) (point))
 125                  (make-glyph (vector type ':data raw))))))
 126             (when raw (insert " "))))))))
 127
 128 (defun mh-face-to-png (data)
 129   "Convert base64 encoded DATA to png image."
 130   (with-temp-buffer
 131     (set-buffer-multibyte nil)
 132     (insert data)
 133     (ignore-errors (base64-decode-region (point-min) (point-max)))
 134     (buffer-string)))
 135
 136 (defun mh-uncompface (data)
 137   "Run DATA through `uncompface' to generate bitmap."
 138   (with-temp-buffer
 139     (set-buffer-multibyte nil)
 140     (insert data)
 141     (when (and mh-uncompface-executable
 142                (equal (call-process-region (point-min) (point-max)
 143                                            mh-uncompface-executable t '(t nil))
 144                       0))
 145       (mh-icontopbm)
 146       (buffer-string))))
 147
 148 (defun mh-icontopbm ()
 149   "Elisp substitute for `icontopbm'."
 150   (goto-char (point-min))
 151   (let ((end (point-max)))
 152     (while (re-search-forward "0x\\(..\\)\\(..\\)," nil t)
 153       (save-excursion
 154         (goto-char (point-max))
 155         (insert (string-to-number (match-string 1) 16))
 156         (insert (string-to-number (match-string 2) 16))))
 157     (delete-region (point-min) end)
 158     (goto-char (point-min))
 159     (insert "P4\n48 48\n")))
 160
 161 \f
 162
 163 ;;; Picon Display
 164
 165 ;; XXX: This should be customizable. As a side-effect of setting this
 166 ;;   variable, arrange to reset mh-picon-existing-directory-list to 'unset.
 167 (defvar mh-picon-directory-list
 168   '("~/.picons" "~/.picons/users" "~/.picons/usenix" "~/.picons/news"
 169     "~/.picons/domains" "~/.picons/misc"
 170     "/usr/share/picons/" "/usr/share/picons/users" "/usr/share/picons/usenix"
 171     "/usr/share/picons/news" "/usr/share/picons/domains"
 172     "/usr/share/picons/misc")
 173   "List of directories where picons reside.
 174 The directories are searched for in the order they appear in the list.")
 175
 176 (defvar mh-picon-existing-directory-list 'unset
 177   "List of directories to search in.")
 178
 179 (defvar mh-picon-cache (make-hash-table :test #'equal))
 180
 181 (defvar mh-picon-image-types
 182   (loop for type in '(xpm xbm gif)
 183         when (or (mh-do-in-gnu-emacs
 184                    (ignore-errors
 185                      (mh-funcall-if-exists image-type-available-p type)))
 186                  (mh-do-in-xemacs (featurep type)))
 187         collect type))
 188
 189 (autoload 'message-tokenize-header "sendmail")
 190
 191 (defun* mh-picon-get-image ()
 192   "Find the best possible match and return contents."
 193   (mh-picon-set-directory-list)
 194   (save-restriction
 195     (let* ((from-field (ignore-errors (car (message-tokenize-header
 196                                             (mh-get-header-field "from:")))))
 197            (from (car (ignore-errors
 198                         (mh-funcall-if-exists ietf-drums-parse-address
 199                                               from-field))))
 200            (host (and from
 201                       (string-match "\\([^+]*\\)\\(+.*\\)?@\\(.*\\)" from)
 202                       (downcase (match-string 3 from))))
 203            (user (and host (downcase (match-string 1 from))))
 204            (canonical-address (format "%s@%s" user host))
 205            (cached-value (gethash canonical-address mh-picon-cache))
 206            (host-list (and host (delete "" (split-string host "\\."))))
 207            (match nil))
 208       (cond (cached-value (return-from mh-picon-get-image cached-value))
 209             ((not host-list) (return-from mh-picon-get-image nil)))
 210       (setq match
 211             (block 'loop
 212               ;; u@h search
 213               (loop for dir in mh-picon-existing-directory-list
 214                     do (loop for type in mh-picon-image-types
 215                              ;; [path]user@host
 216                              for file1 = (format "%s/%s.%s"
 217                                                  dir canonical-address type)
 218                              when (file-exists-p file1)
 219                              do (return-from 'loop file1)
 220                              ;; [path]user
 221                              for file2 = (format "%s/%s.%s" dir user type)
 222                              when (file-exists-p file2)
 223                              do (return-from 'loop file2)
 224                              ;; [path]host
 225                              for file3 = (format "%s/%s.%s" dir host type)
 226                              when (file-exists-p file3)
 227                              do (return-from 'loop file3)))
 228               ;; facedb search
 229               ;; Search order for user@foo.net:
 230               ;;   [path]net/foo/user
 231               ;;   [path]net/foo/user/face
 232               ;;   [path]net/user
 233               ;;   [path]net/user/face
 234               ;;   [path]net/foo/unknown
 235               ;;   [path]net/foo/unknown/face
 236               ;;   [path]net/unknown
 237               ;;   [path]net/unknown/face
 238               (loop for u in (list user "unknown")
 239                     do (loop for dir in mh-picon-existing-directory-list
 240                              do (loop for x on host-list by #'cdr
 241                                       for y = (mh-picon-generate-path x u dir)
 242                                       do (loop for type in mh-picon-image-types
 243                                                for z1 = (format "%s.%s" y type)
 244                                                when (file-exists-p z1)
 245                                                do (return-from 'loop z1)
 246                                                for z2 = (format "%s/face.%s"
 247                                                                 y type)
 248                                                when (file-exists-p z2)
 249                                                do (return-from 'loop z2)))))))
 250       (setf (gethash canonical-address mh-picon-cache)
 251             (mh-picon-file-contents match)))))
 252
 253 (defun mh-picon-set-directory-list ()
 254   "Update `mh-picon-existing-directory-list' if needed."
 255   (when (eq mh-picon-existing-directory-list 'unset)
 256     (setq mh-picon-existing-directory-list
 257           (loop for x in mh-picon-directory-list
 258                 when (file-directory-p x) collect x))))
 259
 260 (defun mh-picon-generate-path (host-list user directory)
 261   "Generate the image file path.
 262 HOST-LIST is the parsed host address of the email address, USER
 263 the username and DIRECTORY is the directory relative to which the
 264 path is generated."
 265   (loop with acc = ""
 266         for elem in host-list
 267         do (setq acc (format "%s/%s" elem acc))
 268         finally return (format "%s/%s%s" directory acc user)))
 269
 270 (defun mh-picon-file-contents (file)
 271   "Return details about FILE.
 272 A list of consisting of a symbol for the type of the file and the
 273 file contents as a string is returned. If FILE is nil, then both
 274 elements of the list are nil."
 275   (if (stringp file)
 276       (with-temp-buffer
 277         (set-buffer-multibyte nil)
 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 valid within Windows
 365 filenames.  In addition, replaces * with %2a. See URL
 366 `http://msdn.microsoft.com/library/default.asp?url=/library/en-us/shellcc/platform/shell/reference/ifaces/iitemnamelimits/GetValidCharacters.asp'."
 367   (format "%s/%s.png" mh-x-image-cache-directory
 368           (mh-replace-regexp-in-string
 369            "\*" "%2a"
 370            (mh-url-hexify-string
 371             (with-temp-buffer
 372               (insert url)
 373               (mh-replace-string "/" "!")
 374               (buffer-string))))))
 375
 376 (defun mh-x-image-get-download-state (file)
 377   "Check the state of FILE by following any symbolic links."
 378   (unless (file-exists-p mh-x-image-cache-directory)
 379     (call-process "mkdir" nil nil nil mh-x-image-cache-directory))
 380   (cond ((file-symlink-p file)
 381          (intern (file-name-nondirectory (file-chase-links file))))
 382         ((not (file-exists-p file)) nil)
 383         (t 'ok)))
 384
 385 (defun mh-x-image-set-download-state (file data)
 386   "Setup a symbolic link from FILE to DATA."
 387   (if data
 388       (make-symbolic-link (symbol-name data) file t)
 389     (delete-file file)))
 390
 391 (defun mh-x-image-url-sane-p (url)
 392   "Check if URL is something sensible."
 393   (let ((len (length url)))
 394     (cond ((< len 5) nil)
 395           ((not (equal (substring url 0 5) "http:")) nil)
 396           ((> len 100) nil)
 397           (t t))))
 398
 399 (defun mh-x-image-display (image marker)
 400   "Display IMAGE at MARKER."
 401   (with-current-buffer (marker-buffer marker)
 402     (let ((inhibit-read-only t)
 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         (with-current-buffer buffer
 431           (set (make-local-variable 'mh-x-image-url-cache-file) cache-file)
 432           (set (make-local-variable 'mh-x-image-marker) marker)
 433           (set (make-local-variable 'mh-x-image-temp-file) filename))
 434         (set-process-sentinel
 435          (start-process "*mh-x-image-url-fetch*" buffer
 436                         mh-wget-executable mh-wget-option filename url)
 437          sentinel))
 438     ;; Temporary failure
 439     (mh-x-image-set-download-state cache-file 'try-again)))
 440
 441 (defun mh-x-image-scale-and-display (process change)
 442   "When the wget PROCESS terminates scale and display image.
 443 The argument CHANGE is ignored."
 444   (when (eq (process-status process) 'exit)
 445     (let (marker temp-file cache-filename wget-buffer)
 446       (with-current-buffer (setq wget-buffer (process-buffer process))
 447         (setq marker mh-x-image-marker
 448               cache-filename mh-x-image-url-cache-file
 449               temp-file mh-x-image-temp-file))
 450       (cond
 451        ;; Check if we have `convert'
 452        ((eq mh-x-image-scaling-function 'ignore)
 453         (message "The \"convert\" program is needed to display X-Image-URL")
 454         (mh-x-image-set-download-state cache-filename 'try-again))
 455        ;; Scale fetched image
 456        ((and (funcall mh-x-image-scaling-function temp-file cache-filename)
 457              nil))
 458        ;; Attempt to display image if we have it
 459        ((file-exists-p cache-filename)
 460         (mh-x-image-display cache-filename marker))
 461        ;; We didn't find the image. Should we try to display it the next time?
 462        (t (mh-x-image-set-download-state cache-filename 'try-again)))
 463       (ignore-errors
 464         (set-marker marker nil)
 465         (delete-process process)
 466         (kill-buffer wget-buffer)
 467         (delete-file temp-file)))))
 468
 469 (provide 'mh-xface)
 470
 471 ;; Local Variables:
 472 ;; indent-tabs-mode: nil
 473 ;; sentence-end-double-space: nil
 474 ;; End:
 475
 476 ;; arch-tag: a79dd33f-d0e5-4b19-a53a-be690f90229a
 477 ;;; mh-xface.el ends here