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