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