1;;; mh-xface.el --- MH-E X-Face and Face header field display 2 3;; Copyright (C) 2002, 2003, 2005, 2006, 2007 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 2, 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 mh-xemacs-flag (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 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. 67If more than one of these are present, then the first one found 68in 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 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. 174The 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. 262HOST-LIST is the parsed host address of the email address, USER 263the username and DIRECTORY is the directory relative to which the 264path 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. 272A list of consisting of a symbol for the type of the file and the 273file contents as a string is returned. If FILE is nil, then both 274elements 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 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. 322If 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. 352This 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. 361Replace the ?/ character with a ?! character and append .png. 362Also replaces special characters with `mh-url-hexify-string' 363since not all characters, such as :, are legal within Windows 364filenames. 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. 423After the image is fetched, it is stored in CACHE-FILE. It will 424be displayed in a buffer and position specified by MARKER. The 425actual 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. 445The 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 481