X-Git-Url: http://git.chise.org/gitweb/?a=blobdiff_plain;f=lisp%2Fgnus-picon.el;h=38de8dfeb8e71d19338df3ffd0d557e9ac6195d0;hb=92e487b48b97af4b331420a1870bb7f185fccf99;hp=ed11b5964700ee6c2a82338c2249e06bbe603254;hpb=4131ea9653854d4dd1b73263c52b6c0962ab74de;p=elisp%2Fgnus.git- diff --git a/lisp/gnus-picon.el b/lisp/gnus-picon.el index ed11b59..38de8df 100644 --- a/lisp/gnus-picon.el +++ b/lisp/gnus-picon.el @@ -1,5 +1,5 @@ ;;; gnus-picon.el --- displaying pretty icons in Gnus -;; Copyright (C) 1996,97 Free Software Foundation, Inc. +;; Copyright (C) 1996,97,98,99 Free Software Foundation, Inc. ;; Author: Wes Hardaker ;; Keywords: news xpm annotation glyph faces @@ -26,7 +26,7 @@ ;;; Code: (require 'gnus) -(require 'xpm) +;; (require 'xpm) (require 'annotations) (require 'custom) (require 'gnus-art) @@ -36,20 +36,18 @@ (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'." + "Where to display the group and article icons. +Valid values are `article' and `picons'." :type '(choice symbol string) :group 'picons) (defcustom gnus-picons-has-modeline-p t - "*Wether the picons window should have a modeline. + "*Whether the picons window should have a modeline. This is only useful if `gnus-picons-display-where' is `picons'." :type 'boolean :group 'picons) @@ -62,7 +60,7 @@ see http://www.cs.indiana.edu/picons/ftp/index.html" :group 'picons) (defcustom gnus-picons-news-directories '("news") - "*Sub-directory of the faces database containing the icons for newsgroups." + "*List of directories to search for newsgroups faces." :type '(repeat string) :group 'picons) (define-obsolete-variable-alias 'gnus-picons-news-directory @@ -89,17 +87,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 @@ -117,7 +104,7 @@ Some people may want to add \"unknown\" to this list." :type '(repeat string) :group 'picons) -(defcustom gnus-picons-display-article-move-p t +(defcustom gnus-picons-display-article-move-p nil "*Whether to move point to first empty line when displaying picons. This has only an effect if `gnus-picons-display-where' has value `article'." :type 'boolean @@ -145,11 +132,21 @@ please tell me so that we can list it." :group 'picons) (defface gnus-picons-xbm-face '((t (:foreground "black" :background "white"))) - "Face to show X face" + "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 + :type 'hook) + ;;; 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 @@ -159,13 +156,6 @@ List of pairs (KEY . GLYPH) where KEY is either a filename or an URL.") "Picons file names cache. List of pairs (KEY . NAME) where KEY is (USER HOST DBS) and NAME is an URL.") -(defvar gnus-group-annotations nil - "List of annotations added/removed when selecting/exiting a group") -(defvar gnus-article-annotations nil - "List of annotations added/removed when selecting an article") -(defvar gnus-x-face-annotations nil - "List of annotations added/removed when selecting an article with an X-Face.") - (defvar gnus-picons-jobs-alist nil "List of jobs that still need be done. This is a list of (SYM-ANN TAG ARGS...) where SYM-ANN three annotations list, @@ -178,41 +168,59 @@ arguments necessary for the job.") ;;; Functions: -(defun gnus-picons-remove (symbol) - "Remove all annotations in variable named SYMBOL. -This function is careful to set it to nil before removing anything so that -asynchronous process don't get crazy." - (setq gnus-picons-jobs-alist (remassq symbol gnus-picons-jobs-alist)) - ;; notify running job that it may have been preempted - (if (eq (car gnus-picons-job-already-running) symbol) - (setq gnus-picons-job-already-running t)) - ;; clear all annotations - (mapc (function (lambda (item) - (if (annotationp item) - (delete-annotation item)))) - (prog1 (symbol-value symbol) - (set symbol nil)))) - (defun gnus-picons-remove-all () "Removes all picons from the Gnus display(s)." (interactive) - (gnus-picons-remove 'gnus-article-annotations) - (gnus-picons-remove 'gnus-group-annotations) - (gnus-picons-remove 'gnus-x-face-annotations)) + (map-extents (function (lambda (ext unused) (delete-annotation ext) nil)) + nil nil nil nil nil 'gnus-picon) + (setq gnus-picons-jobs-alist '()) + ;; notify running job that it may have been preempted + (if (and (listp gnus-picons-job-already-running) + gnus-picons-job-already-running) + (setq gnus-picons-job-already-running t))) (defun gnus-get-buffer-name (variable) "Returns the buffer name associated with the contents of a variable." - (cond ((symbolp variable) (let ((newvar (cdr (assq variable - gnus-window-to-buffer)))) - (cond ((symbolp newvar) - (symbol-value newvar)) - ((stringp newvar) newvar)))) - ((stringp variable) variable))) + (let ((buf (gnus-get-buffer-create + (gnus-window-to-buffer-helper + (cdr (assq variable gnus-window-to-buffer)))))) + (and buf + (buffer-name buf)))) + +(defun gnus-picons-buffer-name () + (cond ((or (stringp gnus-picons-display-where) + (bufferp gnus-picons-display-where)) + gnus-picons-display-where) + ((eq gnus-picons-display-where 'picons) + (if gnus-single-article-buffer + "*Picons*" + (concat "*Picons " gnus-newsgroup-name "*"))) + (t + (gnus-get-buffer-name gnus-picons-display-where)))) + +(defun gnus-picons-kill-buffer () + (let ((buf (get-buffer (gnus-picons-buffer-name)))) + (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 (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)))) (defun gnus-picons-set-buffer () - (set-buffer - (get-buffer-create (gnus-get-buffer-name gnus-picons-display-where))) - (gnus-add-current-to-buffer-list) + (set-buffer (gnus-picons-setup-buffer)) (goto-char (point-min)) (if (and (eq gnus-picons-display-where 'article) gnus-picons-display-article-move-p) @@ -225,73 +233,20 @@ asynchronous process don't get crazy." (list (list (current-buffer) (cons nil gnus-picons-has-modeline-p))))))) -(defun gnus-picons-prepare-for-annotations (annotations) - "Prepare picons buffer for puting annotations memorized in ANNOTATIONS. -ANNOTATIONS should be a symbol naming a variable wich contains a list of -annotations. Sets buffer to `gnus-picons-display-where'." +(defun gnus-picons-prepare-for-annotations () + "Prepare picons buffer for putting annotations." ;; let drawing catch up (when gnus-picons-refresh-before-display (sit-for 0)) (gnus-picons-set-buffer) - (gnus-picons-remove annotations)) + (gnus-picons-remove-all)) -(defsubst gnus-picons-make-annotation (&rest args) +(defun gnus-picons-make-annotation (&rest args) (let ((annot (apply 'make-annotation args))) - (set-extent-property annot 'duplicable nil) + (set-extent-property annot 'gnus-picon t) + (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." - ;; delete any old ones. - ;; This is needed here because gnus-picons-display-x-face will not - ;; be called if there is no X-Face header - (gnus-picons-remove 'gnus-x-face-annotations) - ;; display the new one. - (let ((gnus-article-x-face-command 'gnus-picons-display-x-face)) - (gnus-article-display-x-face))) - -(defun gnus-picons-x-face-sentinel (process event) - (let* ((env (assq process gnus-picons-processes-alist)) - (annot (cdr env))) - (setq gnus-picons-processes-alist - (remassq process gnus-picons-processes-alist)) - (when (annotationp annot) - (set-annotation-glyph annot - (make-glyph gnus-picons-x-face-file-name)) - (if (memq annot gnus-x-face-annotations) - (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 - (let ((buf (current-buffer))) - (save-excursion - (gnus-picons-prepare-for-annotations 'gnus-x-face-annotations) - (setq gnus-x-face-annotations - (cons (gnus-picons-make-annotation - (vector 'xface - :data (concat "X-Face: " - (buffer-substring beg end buf))) - nil 'text) - gnus-x-face-annotations)))) - ;; convert the x-face header to a .xbm file - (let* ((process-connection-type nil) - (annot (save-excursion - (gnus-picons-prepare-for-annotations - 'gnus-x-face-annotations) - (gnus-picons-make-annotation nil nil 'text))) - (process (start-process-shell-command "gnus-x-face" nil - gnus-picons-convert-x-face))) - (push annot gnus-x-face-annotations) - (push (cons process annot) 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) @@ -299,8 +254,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)))) @@ -311,66 +267,83 @@ To use: (setq gnus-article-x-face-command 'gnus-picons-display-x-face)" (message-tokenize-header gnus-local-domain ".")) (message-tokenize-header (substring from (1+ at-idx)) ".")))) - (gnus-picons-prepare-for-annotations 'gnus-article-annotations) - ;; if display in article buffer, the group annotations - ;; wrongly placed. Move them here - (if (eq gnus-picons-display-where 'article) - (dolist (ext gnus-group-annotations) - (set-extent-endpoints ext (point) (point)))) + (gnus-picons-prepare-for-annotations) + (gnus-group-display-picons) + (unless gnus-picons-display-article-move-p + (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) - (setq gnus-article-annotations - (nconc gnus-article-annotations - (gnus-picons-display-pairs - (gnus-picons-lookup-pairs - addrs gnus-picons-domain-directories) - gnus-picons-display-as-address - "." t) - (if (and gnus-picons-display-as-address addrs) - (list (gnus-picons-make-annotation - [string :data "@"] nil - 'text nil nil nil t))) - (gnus-picons-display-picon-or-name - (gnus-picons-lookup-user username addrs) - username t))) + (progn + (gnus-picons-display-pairs (gnus-picons-lookup-pairs + addrs + gnus-picons-domain-directories) + gnus-picons-display-as-address + "." t) + (if (and gnus-picons-display-as-address addrs) + (gnus-picons-make-annotation + [string :data "@"] nil 'text nil nil nil t)) + (gnus-picons-display-picon-or-name + (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)) - - (add-hook 'gnus-summary-exit-hook 'gnus-picons-remove-all)))))) + (gnus-picons-next-job))))))) (defun gnus-group-display-picons () - "Display icons for the group in the gnus-picons-display-where buffer." + "Display icons for the group in the `gnus-picons-display-where' buffer." (interactive) (when (and (featurep 'xpm) (or (not (fboundp 'device-type)) (equal (device-type) 'x)) (or (null gnus-picons-group-excluded-groups) (not (string-match gnus-picons-group-excluded-groups gnus-newsgroup-name)))) - (save-excursion - (gnus-picons-prepare-for-annotations 'gnus-group-annotations) - (if (null gnus-picons-piconsearch-url) - (setq gnus-group-annotations - (gnus-picons-display-pairs - (gnus-picons-lookup-pairs - (reverse (message-tokenize-header - (gnus-group-real-name gnus-newsgroup-name) - ".")) - gnus-picons-news-directories) - t ".")) - (push (list 'gnus-group-annotations 'search nil - (message-tokenize-header - (gnus-group-real-name gnus-newsgroup-name) ".") - (if (listp gnus-picons-news-directories) - gnus-picons-news-directories - (list gnus-picons-news-directories)) - nil) - gnus-picons-jobs-alist) - (gnus-picons-next-job)) - - (add-hook 'gnus-summary-exit-hook 'gnus-picons-remove-all)))) - -(defsubst gnus-picons-lookup-internal (addrs dir) + (let* ((newsgroups (mail-fetch-field "newsgroups")) + (groups + (if (or gnus-picons-display-article-move-p + (not newsgroups)) + (list (gnus-group-real-name gnus-newsgroup-name)) + (split-string newsgroups ","))) + group) + (save-excursion + (gnus-picons-prepare-for-annotations) + (while (setq group (pop groups)) + (unless gnus-picons-display-article-move-p + (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 + (reverse (split-string group "\\.")) + gnus-picons-news-directories) + t ".") + (push (list 'gnus-group-annotations 'search nil + (split-string group "\\.") + (if (listp gnus-picons-news-directories) + gnus-picons-news-directories + (list gnus-picons-news-directories)) + nil (point-marker)) + gnus-picons-jobs-alist) + (gnus-picons-next-job)) + + (add-hook 'gnus-summary-exit-hook 'gnus-picons-remove-all)))))) + +(defun gnus-picons-lookup-internal (addrs dir) (setq dir (expand-file-name dir gnus-picons-database)) (gnus-picons-try-face (dolist (part (reverse addrs) dir) (setq dir (expand-file-name part dir))))) @@ -430,7 +403,8 @@ none, and whose CDR is the corresponding element of DOMAINS." "Display picons in list PAIRS." (let ((domain-p (and gnus-picons-display-as-address dot-p)) pair picons) - (when (and bar-p domain-p right-p) + (when (and bar-p domain-p right-p + gnus-picons-display-article-move-p) (setq picons (gnus-picons-display-glyph (let ((gnus-picons-file-suffixes '("xbm"))) (gnus-picons-try-face @@ -459,12 +433,14 @@ 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)) (defun gnus-picons-display-glyph (glyph &optional part rightp) + (set-glyph-baseline glyph 70) (let ((new (gnus-picons-make-annotation glyph (point) 'text nil nil nil rightp))) (when (and part gnus-picons-display-as-address) @@ -480,7 +456,7 @@ none, and whose CDR is the corresponding element of DOMAINS." 'text nil nil nil rightp)))))) (defun gnus-picons-action-toggle (data) - "Toggle annotation" + "Toggle annotation." (interactive "e") (let* ((annot (car data)) (glyph (annotation-glyph annot))) @@ -488,7 +464,7 @@ none, and whose CDR is the corresponding element of DOMAINS." (set-annotation-data annot (cons annot glyph)))) (defun gnus-picons-clear-cache () - "Clear the picons cache" + "Clear the picons cache." (interactive) (setq gnus-picons-glyph-alist nil gnus-picons-url-alist nil)) @@ -502,8 +478,10 @@ none, and whose CDR is the corresponding element of DOMAINS." ;;; Query a remote DB. This requires some stuff from w3 ! -(require 'url) -(require 'w3-forms) +(eval-and-compile + (ignore-errors + (require 'url) + (require 'w3-forms))) (defun gnus-picons-url-retrieve (url fn arg) (let ((old-asynch (default-value 'url-be-asynchronous)) @@ -544,87 +522,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 "" + (if (re-search-forward (concat "" (regexp-quote name) - " *= * *\\([^ <][^<]*\\) *")) - (buffer-substring (match-beginning 1) (match-end 1))) + " *= * *\\([^ <][^<]*\\) *") + 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 "