X-Git-Url: http://git.chise.org/gitweb/?a=blobdiff_plain;f=lisp%2Fgnus-picon.el;h=9a4c9ba4f28529ca56adf55b731356e4ff195b1f;hb=e5bec5d05f433a43fa2d14cdb7bebeeefab8835f;hp=e059fdb97665450b1e8affd328201cda35aa3e92;hpb=7554e4249c821770633b5aea99298d92bf1e5b5d;p=elisp%2Fgnus.git- diff --git a/lisp/gnus-picon.el b/lisp/gnus-picon.el index e059fdb..9a4c9ba 100644 --- a/lisp/gnus-picon.el +++ b/lisp/gnus-picon.el @@ -1,5 +1,7 @@ ;;; gnus-picon.el --- displaying pretty icons in Gnus -;; Copyright (C) 1996,97,98,99 Free Software Foundation, Inc. + +;; Copyright (C) 1996, 1997, 1998, 1999, 2000 +;; Free Software Foundation, Inc. ;; Author: Wes Hardaker ;; Keywords: news xpm annotation glyph faces @@ -25,6 +27,8 @@ ;;; Code: +(eval-when-compile (require 'cl)) + (require 'gnus) ;; (require 'xpm) (require 'annotations) @@ -87,17 +91,6 @@ Some people may want to add \"unknown\" to this list." :type 'regexp :group 'picons) -(defcustom gnus-picons-x-face-file-name - (format "/tmp/picon-xface.%s.xbm" (user-login-name)) - "*The name of the file in which to store the converted X-face header." - :type 'string - :group 'picons) - -(defcustom gnus-picons-convert-x-face (format "{ echo '/* Width=48, Height=48 */'; uncompface; } | icontopbm | pbmtoxbm > %s" gnus-picons-x-face-file-name) - "*Command to convert the x-face header into a xbm file." - :type 'string - :group 'picons) - (defcustom gnus-picons-display-as-address t "*If t display textual email addresses along with pictures." :type 'boolean @@ -107,9 +100,9 @@ Some people may want to add \"unknown\" to this list." (when (featurep 'x) (let ((types (list "xbm"))) (when (featurep 'gif) - (push "gif" types)) + (setq types (cons "gif" types))) (when (featurep 'xpm) - (push "xpm" types)) + (setq types (cons "xpm" types))) types)) "*List of suffixes on picon file names to try." :type '(repeat string) @@ -258,48 +251,6 @@ arguments necessary for the job.") (set-extent-property annot 'duplicable t) annot)) -(defun gnus-picons-article-display-x-face () - "Display the x-face header bitmap in the 'gnus-picons-display-where buffer." - (let ((gnus-article-x-face-command 'gnus-picons-display-x-face)) - (gnus-article-display-x-face))) - -(defun gnus-picons-x-face-sentinel (process event) - (when (memq process gnus-picons-processes-alist) - (setq gnus-picons-processes-alist - (delq process gnus-picons-processes-alist)) - (gnus-picons-set-buffer) - (gnus-picons-make-annotation - (make-glyph gnus-picons-x-face-file-name) nil 'text) - (when (file-exists-p gnus-picons-x-face-file-name) - (delete-file gnus-picons-x-face-file-name)))) - -(defun gnus-picons-display-x-face (beg end) - "Function to display the x-face header in the picons window. -To use: (setq gnus-article-x-face-command 'gnus-picons-display-x-face)" - (interactive) - (if (featurep 'xface) - ;; Use builtin support - (save-excursion - ;; Don't remove this binding, it is really needed: when - ;; `gnus-picons-set-buffer' changes buffer (like when it is - ;; set to display picons outside of the article buffer), BEG - ;; and END still refer the buffer current now ! - (let ((buf (current-buffer))) - (gnus-picons-set-buffer) - (gnus-picons-make-annotation - (vector 'xface - :data (concat "X-Face: " (buffer-substring beg end buf))) - nil 'text nil nil nil t))) - ;; convert the x-face header to a .xbm file - (let* ((process-connection-type nil) - (process (start-process-shell-command - "gnus-x-face" nil gnus-picons-convert-x-face))) - (push process gnus-picons-processes-alist) - (process-kill-without-query process) - (set-process-sentinel process 'gnus-picons-x-face-sentinel) - (process-send-region process beg end) - (process-send-eof process)))) - (defun gnus-article-display-picons () "Display faces for an author and her domain in gnus-picons-display-where." (interactive) @@ -307,8 +258,9 @@ To use: (setq gnus-article-x-face-command 'gnus-picons-display-x-face)" (when (and (featurep 'xpm) (or (not (fboundp 'device-type)) (equal (device-type) 'x)) (setq from (mail-fetch-field "from")) - (setq from (downcase (or (cadr (mail-extract-address-components - from)) + (setq from (downcase (or (cadr + (funcall gnus-extract-address-components + from)) ""))) (or (setq at-idx (string-match "@" from)) (setq at-idx (length from)))) @@ -575,8 +527,8 @@ none, and whose CDR is the corresponding element of DOMAINS." (defun gnus-picons-parse-value (name) (goto-char (point-min)) (if (re-search-forward (concat "" - (regexp-quote name) - " *= * *\\([^ <][^<]*\\) *") + (regexp-quote name) + " *= * *\\([^ <][^<]*\\) *") nil t) (buffer-substring (match-beginning 1) (match-end 1)))) @@ -664,8 +616,9 @@ none, and whose CDR is the corresponding element of DOMAINS." ;;; search job functions (defun gnus-picons-display-bar-p () - (and (not (eq gnus-picons-display-where 'article)) - gnus-picons-display-as-address)) + (if (eq gnus-picons-display-where 'article) + gnus-picons-display-article-move-p + gnus-picons-display-as-address)) (defun gnus-picons-network-search-internal (user addrs dbs sym-ann right-p marker &optional fnames) @@ -746,8 +699,8 @@ none, and whose CDR is the corresponding element of DOMAINS." (defun gnus-picons-network-search (user addrs dbs sym-ann right-p marker) (let* ((host (mapconcat 'identity addrs ".")) (key (list (or user "unknown") host (if user - gnus-picons-user-directories - dbs))) + gnus-picons-user-directories + dbs))) (cache (assoc key gnus-picons-url-alist))) (if (null cache) (gnus-picons-url-retrieve