code.delx.au - gnu-emacs/blob - 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-2015 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     (if (fboundp 'set-buffer-multibyte)
 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     (if (fboundp 'set-buffer-multibyte)
 138         (set-buffer-multibyte nil))
 139     (insert data)
 140     (when (and mh-uncompface-executable
 141                (equal (call-process-region (point-min) (point-max)
 142                                            mh-uncompface-executable t '(t nil))
 143                       0))
 144       (mh-icontopbm)
 145       (buffer-string))))
 146
 147 (defun mh-icontopbm ()
 148   "Elisp substitute for `icontopbm'."
 149   (goto-char (point-min))
 150   (let ((end (point-max)))
 151     (while (re-search-forward "0x\\(..\\)\\(..\\)," nil t)
 152       (save-excursion
 153         (goto-char (point-max))
 154         (insert (string-to-number (match-string 1) 16))
 155         (insert (string-to-number (match-string 2) 16))))
 156     (delete-region (point-min) end)
 157     (goto-char (point-min))
 158     (insert "P4\n48 48\n")))
 159
 160 \f
 161
 162 ;;; Picon Display
 163
 164 ;; XXX: This should be customizable. As a side-effect of setting this
 165 ;;   variable, arrange to reset mh-picon-existing-directory-list to 'unset.
 166 (defvar mh-picon-directory-list
 167   '("~/.picons" "~/.picons/users" "~/.picons/usenix" "~/.picons/news"
 168     "~/.picons/domains" "~/.picons/misc"
 169     "/usr/share/picons/" "/usr/share/picons/users" "/usr/share/picons/usenix"
 170     "/usr/share/picons/news" "/usr/share/picons/domains"
 171     "/usr/share/picons/misc")
 172   "List of directories where picons reside.
 173 The directories are searched for in the order they appear in the list.")
 174
 175 (defvar mh-picon-existing-directory-list 'unset
 176   "List of directories to search in.")
 177
 178 (defvar mh-picon-cache (make-hash-table :test #'equal))
 179
 180 (defvar mh-picon-image-types
 181   (loop for type in '(xpm xbm gif)
 182         when (or (mh-do-in-gnu-emacs
 183                    (ignore-errors
 184                      (mh-funcall-if-exists image-type-available-p type)))
 185                  (mh-do-in-xemacs (featurep type)))
 186         collect type))
 187
 188 (autoload 'message-tokenize-header "sendmail")
 189
 190 (defun* mh-picon-get-image ()
 191   "Find the best possible match and return contents."
 192   (mh-picon-set-directory-list)
 193   (save-restriction
 194     (let* ((from-field (ignore-errors (car (message-tokenize-header
 195                                             (mh-get-header-field "from:")))))
 196            (from (car (ignore-errors
 197                         (mh-funcall-if-exists ietf-drums-parse-address
 198                                               from-field))))
 199            (host (and from
 200                       (string-match "\\([^+]*\\)\\(+.*\\)?@\\(.*\\)" from)
 201                       (downcase (match-string 3 from))))
 202            (user (and host (downcase (match-string 1 from))))
 203            (canonical-address (format "%s@%s" user host))
 204            (cached-value (gethash canonical-address mh-picon-cache))
 205            (host-list (and host (delete "" (split-string host "\\."))))
 206            (match nil))
 207       (cond (cached-value (return-from mh-picon-get-image cached-value))
 208             ((not host-list) (return-from mh-picon-get-image nil)))
 209       (setq match
 210             (block loop
 211               ;; u@h search
 212               (loop for dir in mh-picon-existing-directory-list
 213                     do (loop for type in mh-picon-image-types
 214                              ;; [path]user@host
 215                              for file1 = (format "%s/%s.%s"
 216                                                  dir canonical-address type)
 217                              when (file-exists-p file1)
 218                              do (return-from loop file1)
 219                              ;; [path]user
 220                              for file2 = (format "%s/%s.%s" dir user type)
 221                              when (file-exists-p file2)
 222                              do (return-from loop file2)
 223                              ;; [path]host
 224                              for file3 = (format "%s/%s.%s" dir host type)
 225                              when (file-exists-p file3)
 226                              do (return-from loop file3)))
 227               ;; facedb search
 228               ;; Search order for user@foo.net:
 229               ;;   [path]net/foo/user
 230               ;;   [path]net/foo/user/face
 231               ;;   [path]net/user
 232               ;;   [path]net/user/face
 233               ;;   [path]net/foo/unknown
 234               ;;   [path]net/foo/unknown/face
 235               ;;   [path]net/unknown
 236               ;;   [path]net/unknown/face
 237               (loop for u in (list user "unknown")
 238                     do (loop for dir in mh-picon-existing-directory-list
 239                              do (loop for x on host-list by #'cdr
 240                                       for y = (mh-picon-generate-path x u dir)
 241                                       do (loop for type in mh-picon-image-types
 242                                                for z1 = (format "%s.%s" y type)
 243                                                when (file-exists-p z1)
 244                                                do (return-from loop z1)
 245                                                for z2 = (format "%s/face.%s"
 246                                                                 y type)
 247                                                when (file-exists-p z2)
 248                                                do (return-from loop z2)))))))
 249       (setf (gethash canonical-address mh-picon-cache)
 250             (mh-picon-file-contents match)))))
 251
 252 (defun mh-picon-set-directory-list ()
 253   "Update `mh-picon-existing-directory-list' if needed."
 254   (when (eq mh-picon-existing-directory-list 'unset)
 255     (setq mh-picon-existing-directory-list
 256           (loop for x in mh-picon-directory-list
 257                 when (file-directory-p x) collect x))))
 258
 259 (defun mh-picon-generate-path (host-list user directory)
 260   "Generate the image file path.
 261 HOST-LIST is the parsed host address of the email address, USER
 262 the username and DIRECTORY is the directory relative to which the
 263 path is generated."
 264   (loop with acc = ""
 265         for elem in host-list
 266         do (setq acc (format "%s/%s" elem acc))
 267         finally return (format "%s/%s%s" directory acc user)))
 268
 269 (defun mh-picon-file-contents (file)
 270   "Return details about FILE.
 271 A list of consisting of a symbol for the type of the file and the
 272 file contents as a string is returned. If FILE is nil, then both
 273 elements of the list are nil."
 274   (if (stringp file)
 275       (with-temp-buffer
 276         (if (fboundp 'set-buffer-multibyte)
 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           (list type (buffer-string))))
 282     (list 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 (point-marker)))
 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 ;;; mh-xface.el ends here