X-Git-Url: http://git.chise.org/gitweb/?a=blobdiff_plain;f=lisp%2Fgnus-picon.el;h=9a4c9ba4f28529ca56adf55b731356e4ff195b1f;hb=8d5b94488b8fe507a83eb5475ecaa54afb8a98b8;hp=1fd1f066943866e5d4296544c3eceb098263485e;hpb=23c969058026ed1e55687f9942acf0d2e406fb01;p=elisp%2Fgnus.git- diff --git a/lisp/gnus-picon.el b/lisp/gnus-picon.el index 1fd1f06..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 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,8 +27,10 @@ ;;; Code: +(eval-when-compile (require 'cl)) + (require 'gnus) -(require 'xpm) +;; (require 'xpm) (require 'annotations) (require 'custom) (require 'gnus-art) @@ -36,15 +40,13 @@ (defgroup picons nil "Show pictures of people, domains, and newsgroups (XEmacs). -For this to work, you must add gnus-group-display-picons to the -gnus-summary-display-hook or to the gnus-article-display-hook -depending on what gnus-picons-display-where is set to. You must -also add gnus-article-display-picons to gnus-article-display-hook." +For this to work, you must switch on the `gnus-treat-display-picons' +variable." :group 'gnus-visual) (defcustom gnus-picons-display-where 'picons "Where to display the group and article icons. -Legal values are `article' and `picons'." +Valid values are `article' and `picons'." :type '(choice symbol string) :group 'picons) @@ -89,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 @@ -109,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) @@ -148,6 +139,10 @@ please tell me so that we can list it." "Face to show xbm picons in." :group 'picons) +(defface gnus-picons-face '((t (:foreground "black" :background "white"))) + "Face to show picons in." + :group 'picons) + (defcustom gnus-picons-setup-hook nil "Hook run in Picons buffers." :group 'picons @@ -155,6 +150,7 @@ please tell me so that we can list it." ;;; Internal variables: +(defvar gnus-picons-setup-p nil) (defvar gnus-picons-processes-alist nil "Picons processes currently running and their environment.") (defvar gnus-picons-glyph-alist nil @@ -208,18 +204,22 @@ arguments necessary for the job.") (defun gnus-picons-kill-buffer () (let ((buf (get-buffer (gnus-picons-buffer-name)))) - (when (buffer-live-p buf) + (when (and (buffer-live-p buf) + (string-match "Picons" (buffer-name buf))) (kill-buffer buf)))) (defun gnus-picons-setup-buffer () (let ((name (gnus-picons-buffer-name))) (save-excursion - (if (get-buffer name) + (if (and (get-buffer name) + (with-current-buffer name + gnus-picons-setup-p)) (set-buffer name) (set-buffer (gnus-get-buffer-create name)) (buffer-disable-undo) (setq buffer-read-only t) (run-hooks 'gnus-picons-setup-hook) + (set (make-local-variable 'gnus-picons-setup-p) t) (add-hook 'gnus-summary-prepare-exit-hook 'gnus-picons-kill-buffer)) (current-buffer)))) @@ -251,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) @@ -300,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)))) @@ -315,14 +274,13 @@ To use: (setq gnus-article-x-face-command 'gnus-picons-display-x-face)" (gnus-picons-prepare-for-annotations) (gnus-group-display-picons) (unless gnus-picons-display-article-move-p - (save-restriction - (let ((buffer-read-only nil)) - (when (re-search-forward "^From: " nil t) - (narrow-to-region (point) (gnus-point-at-eol)) - (when (search-forward from nil t) - (gnus-put-text-property - (match-beginning 0) (match-end 0) - 'invisible t)))))) + (let ((buffer-read-only nil) + (case-fold-search t)) + (when (re-search-forward "^From *: *" nil t) + (when (search-forward from (gnus-point-at-eol) t) + (gnus-put-text-property + (match-beginning 0) (match-end 0) + 'invisible t))))) (if (null gnus-picons-piconsearch-url) (progn (gnus-picons-display-pairs (gnus-picons-lookup-pairs @@ -337,7 +295,7 @@ To use: (setq gnus-article-x-face-command 'gnus-picons-display-x-face)" (gnus-picons-lookup-user username addrs) username t)) (push (list 'gnus-article-annotations 'search username addrs - gnus-picons-domain-directories t) + gnus-picons-domain-directories t (point-marker)) gnus-picons-jobs-alist) (gnus-picons-next-job))))))) @@ -352,7 +310,7 @@ To use: (setq gnus-article-x-face-command 'gnus-picons-display-x-face)" (let* ((newsgroups (mail-fetch-field "newsgroups")) (groups (if (or gnus-picons-display-article-move-p - (not newsgroups))(mail-fetch-field "newsgroups") + (not newsgroups)) (list (gnus-group-real-name gnus-newsgroup-name)) (split-string newsgroups ","))) group) @@ -360,15 +318,18 @@ To use: (setq gnus-article-x-face-command 'gnus-picons-display-x-face)" (gnus-picons-prepare-for-annotations) (while (setq group (pop groups)) (unless gnus-picons-display-article-move-p - (save-restriction - (let ((buffer-read-only nil)) - (goto-char (point-min)) - (when (re-search-forward "^Newsgroups:" nil t) - (narrow-to-region (point) (gnus-point-at-eol)) - (when (search-forward group nil t) - (gnus-put-text-property - (match-beginning 0) (match-end 0) - 'invisible t)))))) + (let ((buffer-read-only nil) + (case-fold-search t)) + (goto-char (point-min)) + (if (and (re-search-forward "^Newsgroups *: *" nil t) + (search-forward group (gnus-point-at-eol) t)) + (gnus-put-text-property + (match-beginning 0) (match-end 0) + 'invisible t) + (let ((article-goto-body-goes-to-point-min-p nil)) + (article-goto-body)) + (unless (bobp) + (backward-char 1))))) (if (null gnus-picons-piconsearch-url) (gnus-picons-display-pairs (gnus-picons-lookup-pairs @@ -380,7 +341,7 @@ To use: (setq gnus-article-x-face-command 'gnus-picons-display-x-face)" (if (listp gnus-picons-news-directories) gnus-picons-news-directories (list gnus-picons-news-directories)) - nil) + nil (point-marker)) gnus-picons-jobs-alist) (gnus-picons-next-job)) @@ -476,8 +437,9 @@ none, and whose CDR is the corresponding element of DOMAINS." dir))) (setq suffixes nil glyph (make-glyph f)) - (when (equal suf "xbm") - (set-glyph-face glyph 'gnus-picons-xbm-face)) + (if (equal suf "xbm") + (set-glyph-face glyph 'gnus-picons-xbm-face) + (set-glyph-face glyph 'gnus-picons-face)) (push (cons key glyph) gnus-picons-glyph-alist))) glyph)) @@ -564,85 +526,102 @@ none, and whose CDR is the corresponding element of DOMAINS." (defun gnus-picons-parse-value (name) (goto-char (point-min)) - (re-search-forward (concat "" - (regexp-quote name) - " *= * *\\([^ <][^<]*\\) *")) - (buffer-substring (match-beginning 1) (match-end 1))) + (if (re-search-forward (concat "" + (regexp-quote name) + " *= * *\\([^ <][^<]*\\) *") + nil t) + (buffer-substring (match-beginning 1) (match-end 1)))) (defun gnus-picons-parse-filenames () ;; returns an alist of ((USER ADDRS DB) . URL) - (let* ((case-fold-search t) - (user (gnus-picons-parse-value "user")) - (host (gnus-picons-parse-value "host")) - (dbs (message-tokenize-header (gnus-picons-parse-value "db") " ")) - (start-re - (concat - ;; dbs - "^\\(" (mapconcat 'identity dbs "\\|") "\\)/" - ;; host - "\\(\\(" (replace-in-string host "\\." "/\\|" t) "/\\|MISC/\\)*\\)" - ;; user - "\\(" (regexp-quote user) "\\|unknown\\)/" - "face\\.")) - cur-db cur-host cur-user types res) + (let ((case-fold-search t) + (user (gnus-picons-parse-value "user")) + (host (gnus-picons-parse-value "host")) + (dbs (message-tokenize-header (gnus-picons-parse-value "db") " ")) + start-re cur-db cur-host cur-user types res) ;; now point will be somewhere in the header. Find beginning of ;; entries - (re-search-forward "

[ \t\n]*") - (while (re-search-forward start-re nil t) - (setq cur-db (buffer-substring (match-beginning 1) (match-end 1)) - cur-host (buffer-substring (match-beginning 2) (match-end 2)) - cur-user (buffer-substring (match-beginning 4) (match-end 4)) - cur-host (nreverse (message-tokenize-header cur-host "/"))) - ;; XXX - KLUDGE: there is a blank picon in news/MISC/unknown - (unless (and (string-equal cur-db "news") - (string-equal cur-user "unknown") - (equal cur-host '("MISC"))) - ;; ok now we have found an entry (USER HOST DB), find the - ;; corresponding picon URL - (save-restriction - ;; restrict region to this entry - (narrow-to-region (point) (search-forward "
")) - (goto-char (point-min)) - (setq types gnus-picons-file-suffixes) - (while (and types - (not (re-search-forward - (concat "[ \t\n]*") + (while (re-search-forward start-re nil t) + (setq cur-db (buffer-substring (match-beginning 1) (match-end 1)) + cur-host (buffer-substring (match-beginning 2) (match-end 2)) + cur-user (buffer-substring (match-beginning 4) (match-end 4)) + cur-host (nreverse (message-tokenize-header cur-host "/"))) + ;; XXX - KLUDGE: there is a blank picon in news/MISC/unknown + (unless (and (string-equal cur-db "news") + (string-equal cur-user "unknown") + (equal cur-host '("MISC"))) + ;; ok now we have found an entry (USER HOST DB), find the + ;; corresponding picon URL + (save-restriction + ;; restrict region to this entry + (narrow-to-region (point) (search-forward "
")) + (goto-char (point-min)) + (setq types gnus-picons-file-suffixes) + (while (and types + (not (re-search-forward + (concat "