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 (defvar default-enable-multibyte-characters) ; XEmacs
  64
  65 (defun mh-face-display-function ()
  66   "Display a Face, X-Face, or X-Image-URL header field.
  67 If more than one of these are present, then the first one found
  68 in this order is used."
  69   (save-restriction
  70     (goto-char (point-min))
  71     (re-search-forward "\n\n" (point-max) t)
  72     (narrow-to-region (point-min) (point))
  73     (let* ((case-fold-search t)
  74            (default-enable-multibyte-characters nil)
  75            (face (message-fetch-field "face" t))
  76            (x-face (message-fetch-field "x-face" t))
  77            (url (message-fetch-field "x-image-url" t))
  78            raw type)
  79       (cond (face (setq raw (mh-face-to-png face)
  80                         type 'png))
  81             (x-face (setq raw (mh-uncompface x-face)
  82                           type 'pbm))
  83             (url (setq type 'url))
  84             (t (multiple-value-setq (type raw) (mh-picon-get-image))))
  85       (when type
  86         (goto-char (point-min))
  87         (when (re-search-forward "^from:" (point-max) t)
  88           ;; GNU Emacs
  89           (mh-do-in-gnu-emacs
  90             (if (eq type 'url)
  91                 (mh-x-image-url-display url)
  92               (mh-funcall-if-exists
  93                insert-image (create-image
  94                              raw type t
  95                              :foreground
  96                              (mh-face-foreground 'mh-show-xface nil t)
  97                              :background
  98                              (mh-face-background 'mh-show-xface nil t))
  99                " ")))
 100           ;; XEmacs
 101           (mh-do-in-xemacs
 102             (cond
 103              ((eq type 'url)
 104               (mh-x-image-url-display url))
 105              ((eq type 'png)
 106               (when (featurep 'png)
 107                 (set-extent-begin-glyph
 108                  (make-extent (point) (point))
 109                  (make-glyph (vector 'png ':data (mh-face-to-png face))))))
 110              ;; Try internal xface support if available...
 111              ((and (eq type 'pbm) (featurep 'xface))
 112               (set-glyph-face
 113                (set-extent-begin-glyph
 114                 (make-extent (point) (point))
 115                 (make-glyph (vector 'xface ':data (concat "X-Face: " x-face))))
 116                'mh-show-xface))
 117              ;; Otherwise try external support with x-face...
 118              ((and (eq type 'pbm)
 119                    (fboundp 'x-face-xmas-wl-display-x-face)
 120                    (fboundp 'executable-find) (executable-find "uncompface"))
 121               (mh-funcall-if-exists x-face-xmas-wl-display-x-face))
 122              ;; Picon display
 123              ((and raw (member type '(xpm xbm gif)))
 124               (when (featurep type)
 125                 (set-extent-begin-glyph
 126                  (make-extent (point) (point))
 127                  (make-glyph (vector type ':data raw))))))
 128             (when raw (insert " "))))))))
 129
 130 (defun mh-face-to-png (data)
 131   "Convert base64 encoded DATA to png image."
 132   (with-temp-buffer
 133     (insert data)
 134     (ignore-errors (base64-decode-region (point-min) (point-max)))
 135     (buffer-string)))
 136
 137 (defun mh-uncompface (data)
 138   "Run DATA through `uncompface' to generate bitmap."
 139   (with-temp-buffer
 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         (let ((type (and (string-match ".*\\.\\(...\\)$" file)
 278                          (intern (match-string 1 file)))))
 279           (insert-file-contents-literally file)
 280           (values type (buffer-string))))
 281     (values nil nil)))
 282
 283 \f
 284
 285 ;;; X-Image-URL Display
 286
 287 (defvar mh-x-image-scaling-function
 288   (cond ((executable-find "convert")
 289          'mh-x-image-scale-with-convert)
 290         ((and (executable-find "anytopnm") (executable-find "pnmscale")
 291               (executable-find "pnmtopng"))
 292          'mh-x-image-scale-with-pnm)
 293         (t 'ignore))
 294   "Function to use to scale image to proper size.")
 295
 296 (defun mh-x-image-scale-with-pnm (input output)
 297   "Scale image in INPUT file and write to OUTPUT file using pnm tools."
 298   (let ((res (shell-command-to-string
 299               (format "anytopnm < %s | pnmscale -xysize 96 48 | pnmtopng > %s"
 300                       input output))))
 301     (unless (equal res "")
 302       (delete-file output))))
 303
 304 (defun mh-x-image-scale-with-convert (input output)
 305   "Scale image in INPUT file and write to OUTPUT file using ImageMagick."
 306   (call-process "convert" nil nil nil "-geometry" "96x48" input output))
 307
 308 (defvar mh-wget-executable nil)
 309 (defvar mh-wget-choice
 310   (or (and (setq mh-wget-executable (executable-find "wget")) 'wget)
 311       (and (setq mh-wget-executable (executable-find "fetch")) 'fetch)
 312       (and (setq mh-wget-executable (executable-find "curl")) 'curl)))
 313 (defvar mh-wget-option
 314   (cdr (assoc mh-wget-choice '((curl . "-o") (fetch . "-o") (wget . "-O")))))
 315 (defvar mh-x-image-temp-file nil)
 316 (defvar mh-x-image-url nil)
 317 (defvar mh-x-image-marker nil)
 318 (defvar mh-x-image-url-cache-file nil)
 319
 320 (defun mh-x-image-url-display (url)
 321   "Display image from location URL.
 322 If the URL isn't present in the cache then it is fetched with wget."
 323   (let* ((cache-filename (mh-x-image-url-cache-canonicalize url))
 324          (state (mh-x-image-get-download-state cache-filename))
 325          (marker (set-marker (make-marker) (point))))
 326     (set (make-local-variable 'mh-x-image-marker) marker)
 327     (cond ((not (mh-x-image-url-sane-p url)))
 328           ((eq state 'ok)
 329            (mh-x-image-display cache-filename marker))
 330           ((or (not mh-wget-executable)
 331                (eq mh-x-image-scaling-function 'ignore)))
 332           ((eq state 'never))
 333           ((not mh-fetch-x-image-url)
 334            (set-marker marker nil))
 335           ((eq state 'try-again)
 336            (mh-x-image-set-download-state cache-filename nil)
 337            (mh-x-image-url-fetch-image url cache-filename marker
 338                                        'mh-x-image-scale-and-display))
 339           ((and (eq mh-fetch-x-image-url 'ask)
 340                 (not (y-or-n-p (format "Fetch %s? " url))))
 341            (mh-x-image-set-download-state cache-filename 'never))
 342           ((eq state nil)
 343            (mh-x-image-url-fetch-image url cache-filename marker
 344                                        'mh-x-image-scale-and-display)))))
 345
 346 (defvar mh-x-image-cache-directory nil
 347   "Directory where X-Image-URL images are cached.")
 348
 349 ;;;###mh-autoload
 350 (defun mh-set-x-image-cache-directory (directory)
 351   "Set the DIRECTORY where X-Image-URL images are cached.
 352 This is only done if `mh-x-image-cache-directory' is nil."
 353   ;; XXX This is the code that used to be in find-user-path. Is there
 354   ;; a good reason why the variable is set conditionally? Do we expect
 355   ;; the user to have set this variable directly?
 356   (unless mh-x-image-cache-directory
 357     (setq mh-x-image-cache-directory directory)))
 358
 359 (defun mh-x-image-url-cache-canonicalize (url)
 360   "Canonicalize URL.
 361 Replace the ?/ character with a ?! character and append .png.
 362 Also replaces special characters with `mh-url-hexify-string'
 363 since not all characters, such as :, are legal within Windows
 364 filenames. In addition, replaces * with %2a. See URL
 365 `http://msdn.microsoft.com/library/default.asp?url=/library/en-us/shellcc/platform/shell/reference/ifaces/iitemnamelimits/GetValidCharacters.asp'."
 366   (format "%s/%s.png" mh-x-image-cache-directory
 367           (mh-replace-regexp-in-string
 368            "\*" "%2a"
 369            (mh-url-hexify-string
 370             (with-temp-buffer
 371               (insert url)
 372               (mh-replace-string "/" "!")
 373               (buffer-string))))))
 374
 375 (defun mh-x-image-get-download-state (file)
 376   "Check the state of FILE by following any symbolic links."
 377   (unless (file-exists-p mh-x-image-cache-directory)
 378     (call-process "mkdir" nil nil nil mh-x-image-cache-directory))
 379   (cond ((file-symlink-p file)
 380          (intern (file-name-nondirectory (file-chase-links file))))
 381         ((not (file-exists-p file)) nil)
 382         (t 'ok)))
 383
 384 (defun mh-x-image-set-download-state (file data)
 385   "Setup a symbolic link from FILE to DATA."
 386   (if data
 387       (make-symbolic-link (symbol-name data) file t)
 388     (delete-file file)))
 389
 390 (defun mh-x-image-url-sane-p (url)
 391   "Check if URL is something sensible."
 392   (let ((len (length url)))
 393     (cond ((< len 5) nil)
 394           ((not (equal (substring url 0 5) "http:")) nil)
 395           ((> len 100) nil)
 396           (t t))))
 397
 398 (defun mh-x-image-display (image marker)
 399   "Display IMAGE at MARKER."
 400   (save-excursion
 401     (set-buffer (marker-buffer marker))
 402     (let ((buffer-read-only nil)
 403           (default-enable-multibyte-characters nil)
 404           (buffer-modified-flag (buffer-modified-p)))
 405       (unwind-protect
 406           (when (and (file-readable-p image) (not (file-symlink-p image))
 407                      (eq marker mh-x-image-marker))
 408             (goto-char marker)
 409             (mh-do-in-gnu-emacs
 410               (mh-funcall-if-exists insert-image (create-image image 'png)))
 411             (mh-do-in-xemacs
 412               (when (featurep 'png)
 413                 (set-extent-begin-glyph
 414                  (make-extent (point) (point))
 415                  (make-glyph
 416                   (vector 'png ':data (with-temp-buffer
 417                                         (insert-file-contents-literally image)
 418                                         (buffer-string))))))))
 419         (set-buffer-modified-p buffer-modified-flag)))))
 420
 421 (defun mh-x-image-url-fetch-image (url cache-file marker sentinel)
 422   "Fetch and display the image specified by URL.
 423 After the image is fetched, it is stored in CACHE-FILE. It will
 424 be displayed in a buffer and position specified by MARKER. The
 425 actual display is carried out by the SENTINEL function."
 426   (if mh-wget-executable
 427       (let ((buffer (get-buffer-create (generate-new-buffer-name
 428                                         mh-temp-fetch-buffer)))
 429             (filename (or (mh-funcall-if-exists make-temp-file "mhe-fetch")
 430                           (expand-file-name (make-temp-name "~/mhe-fetch")))))
 431         (save-excursion
 432           (set-buffer buffer)
 433           (set (make-local-variable 'mh-x-image-url-cache-file) cache-file)
 434           (set (make-local-variable 'mh-x-image-marker) marker)
 435           (set (make-local-variable 'mh-x-image-temp-file) filename))
 436         (set-process-sentinel
 437          (start-process "*mh-x-image-url-fetch*" buffer
 438                         mh-wget-executable mh-wget-option filename url)
 439          sentinel))
 440     ;; Temporary failure
 441     (mh-x-image-set-download-state cache-file 'try-again)))
 442
 443 (defun mh-x-image-scale-and-display (process change)
 444   "When the wget PROCESS terminates scale and display image.
 445 The argument CHANGE is ignored."
 446   (when (eq (process-status process) 'exit)
 447     (let (marker temp-file cache-filename wget-buffer)
 448       (save-excursion
 449         (set-buffer (setq wget-buffer (process-buffer process)))
 450         (setq marker mh-x-image-marker
 451               cache-filename mh-x-image-url-cache-file
 452               temp-file mh-x-image-temp-file))
 453       (cond
 454        ;; Check if we have `convert'
 455        ((eq mh-x-image-scaling-function 'ignore)
 456         (message "The \"convert\" program is needed to display X-Image-URL")
 457         (mh-x-image-set-download-state cache-filename 'try-again))
 458        ;; Scale fetched image
 459        ((and (funcall mh-x-image-scaling-function temp-file cache-filename)
 460              nil))
 461        ;; Attempt to display image if we have it
 462        ((file-exists-p cache-filename)
 463         (mh-x-image-display cache-filename marker))
 464        ;; We didn't find the image. Should we try to display it the next time?
 465        (t (mh-x-image-set-download-state cache-filename 'try-again)))
 466       (ignore-errors
 467         (set-marker marker nil)
 468         (delete-process process)
 469         (kill-buffer wget-buffer)
 470         (delete-file temp-file)))))
 471
 472 (provide 'mh-xface)
 473
 474 ;; Local Variables:
 475 ;; indent-tabs-mode: nil
 476 ;; sentence-end-double-space: nil
 477 ;; End:
 478
 479 ;; arch-tag: a79dd33f-d0e5-4b19-a53a-be690f90229a
 480 ;;; mh-xface.el ends here