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