X-Git-Url: https://cgit.sxemacs.org/?a=blobdiff_plain;f=lisp%2Fgnus-picon.el;h=36857325a83e90c054385536c66b804689b71a13;hb=2b0c0cb2a86396d92edee61abb90415291c4e40f;hp=ec529eadcd3814a859675b864d011ca9b061cfb5;hpb=17b7a13f8745857496a1fbe961154aa541024c7a;p=gnus diff --git a/lisp/gnus-picon.el b/lisp/gnus-picon.el index ec529eadc..36857325a 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,68 +26,65 @@ ;;; Code: (require 'gnus) -(require 'xpm) +;; (require 'xpm) (require 'annotations) (require 'custom) (require 'gnus-art) (require 'gnus-win) +;;; User variables: + (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-buffer "*Icon Buffer*" - "Buffer name to display the icons in if gnus-picons-display-where is 'picons." - :type 'string - :group 'picons) - (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) +(defcustom gnus-picons-has-modeline-p t + "*Whether the picons window should have a modeline. +This is only useful if `gnus-picons-display-where' is `picons'." + :type 'boolean + :group 'picons) + (defcustom gnus-picons-database "/usr/local/faces" - "Defines the location of the faces database. + "*Defines the location of the faces database. For information on obtaining this database of pretty pictures, please see http://www.cs.indiana.edu/picons/ftp/index.html" :type 'directory :group 'picons) -(defcustom gnus-picons-news-directory "news" - "Sub-directory of the faces database containing the icons for newsgroups." - :type 'string +(defcustom gnus-picons-news-directories '("news") + "*List of directories to search for newsgroups faces." + :type '(repeat string) :group 'picons) +(define-obsolete-variable-alias 'gnus-picons-news-directory + 'gnus-picons-news-directories) (defcustom gnus-picons-user-directories '("local" "users" "usenix" "misc") - "List of directories to search for user faces." + "*List of directories to search for user faces." :type '(repeat string) :group 'picons) (defcustom gnus-picons-domain-directories '("domains") - "List of directories to search for domain faces. + "*List of directories to search for domain faces. Some people may want to add \"unknown\" to this list." :type '(repeat string) :group 'picons) (defcustom gnus-picons-refresh-before-display nil - "If non-nil, display the article buffer before computing the picons." + "*If non-nil, display the article buffer before computing the picons." :type 'boolean :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 +(defcustom gnus-picons-group-excluded-groups nil + "*If this regexp matches the group name, group picons will be disabled." + :type 'regexp :group 'picons) (defcustom gnus-picons-display-as-address t @@ -103,234 +100,274 @@ Some people may want to add \"unknown\" to this list." (when (featurep 'xpm) (push "xpm" types)) types)) - "List of suffixes on picon file names to try." + "*List of suffixes on picon file names to try." :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 :group 'picons) -(defvar gnus-picons-map (make-sparse-keymap "gnus-picons-keys") - "keymap to hide/show picon glyphs") - -(define-key gnus-picons-map [(button2)] 'gnus-picons-toggle-extent) - -;;; Internal variables. - -(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.") - -(defun gnus-picons-remove (symbol) - "Remove all annotations/processes in variable named SYMBOL. -This function is careful to set it to nil before removing anything so that -asynchronous process don't get crazy." - (let ((listitems (symbol-value symbol))) - (set symbol nil) - (while listitems - (let ((item (pop listitems))) - (cond ((annotationp item) - (delete-annotation item)) - ((processp item) - ;; kill the process, ignore any output. - (set-process-sentinel item (function (lambda (p e)))) - (delete-process item))))))) +(defcustom gnus-picons-clear-cache-on-shutdown t + "*Whether to clear the picons cache when exiting gnus. +Gnus caches every picons it finds while it is running. This saves +some time in the search process but eats some memory. If this +variable is set to nil, Gnus will never clear the cache itself; you +will have to manually call `gnus-picons-clear-cache' to clear it. +Otherwise the cache will be cleared every time you exit Gnus." + :type 'boolean + :group 'picons) + +(defcustom gnus-picons-piconsearch-url nil + "*The url to query for picons. Setting this to nil will disable it. +The only publicly available address currently known is +http://www.cs.indiana.edu:800/piconsearch. If you know of any other, +please tell me so that we can list it." + :type '(choice (const :tag "Disable" :value nil) + (const :tag "www.cs.indiana.edu" + :value "http://www.cs.indiana.edu:800/piconsearch") + (string)) + :group 'picons) + +(defface gnus-picons-xbm-face '((t (:foreground "black" :background "white"))) + "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 + "Picons glyphs cache. +List of pairs (KEY . GLYPH) where KEY is either a filename or an URL.") +(defvar gnus-picons-url-alist nil + "Picons file names cache. +List of pairs (KEY . NAME) where KEY is (USER HOST DBS) and NAME is an URL.") + +(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, +TAG is one of `picon' or `search' indicating that the job should query a +picon or do a search for picons file names, and ARGS is some additionnal +arguments necessary for the job.") + +(defvar gnus-picons-job-already-running nil + "Lock to ensure only one stream of http requests is running.") + +;;; Functions: (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) - (when (bufferp gnus-picons-buffer) - (kill-buffer gnus-picons-buffer))) + (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))) - -(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'." - ;; let drawing catch up - (when gnus-picons-refresh-before-display - (sit-for 0)) - (set-buffer (get-buffer-create - (gnus-get-buffer-name gnus-picons-display-where))) - (gnus-add-current-to-buffer-list) - (goto-char (point-min)) - (if (and (eq gnus-picons-display-where 'article) - gnus-picons-display-article-move-p) - (when (search-forward "\n\n" nil t) - (forward-line -1))) - (gnus-picons-remove annotations)) - -(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) - ;; don't call gnus-picons-prepare-for-annotations, it would reset - ;; gnus-x-face-annotations. - (set-buffer (get-buffer-create - (gnus-get-buffer-name gnus-picons-display-where))) - (gnus-add-current-to-buffer-list) + (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 (gnus-picons-setup-buffer)) (goto-char (point-min)) (if (and (eq gnus-picons-display-where 'article) gnus-picons-display-article-move-p) - (when (search-forward "\n\n" nil t) - (forward-line -1))) - ;; If the process is still in the list, insert this icon - (let ((myself (member process gnus-x-face-annotations))) - (when myself - (setcar myself - (make-annotation gnus-picons-x-face-file-name nil 'text)) - (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 (make-annotation (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) - (process (start-process "gnus-x-face" nil - shell-file-name shell-command-switch - gnus-picons-convert-x-face))) - (process-kill-without-query process) - (setq gnus-x-face-annotations (list process)) - (set-process-sentinel process 'gnus-picons-x-face-sentinel) - (process-send-region process beg end) - (process-send-eof process)))) + (if (search-forward "\n\n" nil t) + (forward-line -1) + (goto-char (point-max))) + (setq buffer-read-only t) + (unless gnus-picons-has-modeline-p + (set-specifier has-modeline-p + (list (list (current-buffer) + (cons nil gnus-picons-has-modeline-p))))))) + +(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-all)) + +(defun gnus-picons-make-annotation (&rest args) + (let ((annot (apply 'make-annotation args))) + (set-extent-property annot 'gnus-picon t) + (set-extent-property annot 'duplicable t) + annot)) (defun gnus-article-display-picons () - "Display faces for an author and his/her domain in gnus-picons-display-where." + "Display faces for an author and her domain in gnus-picons-display-where." (interactive) (let (from at-idx) (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 (mail-extract-address-components + from)) + ""))) (or (setq at-idx (string-match "@" from)) (setq at-idx (length from)))) (save-excursion - (let ((username (substring from 0 at-idx)) + (let ((username (downcase (substring from 0 at-idx))) (addrs (if (eq at-idx (length from)) (if gnus-local-domain - (message-tokenize-header gnus-local-domain ".") - nil) + (message-tokenize-header gnus-local-domain ".")) (message-tokenize-header (substring from (1+ at-idx)) ".")))) - (gnus-picons-prepare-for-annotations 'gnus-article-annotations) - (setq gnus-article-annotations - (nconc gnus-article-annotations - ;; look for domain paths. - (gnus-picons-display-pairs - (gnus-picons-lookup-pairs addrs - gnus-picons-domain-directories) - (not (or gnus-picons-display-as-address - gnus-article-annotations)) - nil "." t) - ;; add an '@' if displaying as address - (if (and gnus-picons-display-as-address addrs) - (list (make-annotation "@" nil 'text nil nil nil t))) - ;; then do user directories, - (gnus-picons-display-picon-or-name - (gnus-picons-lookup-user (downcase username) addrs) - username nil t))) - - (add-hook 'gnus-summary-exit-hook 'gnus-picons-remove-all)))))) + (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) + (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 (point-marker)) + gnus-picons-jobs-alist) + (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))) - (save-excursion - (gnus-picons-prepare-for-annotations 'gnus-group-annotations) - (setq gnus-group-annotations - (gnus-picons-display-pairs - (gnus-picons-lookup-pairs (reverse (message-tokenize-header - gnus-newsgroup-name ".")) - gnus-picons-news-directory) - t nil ".")) - (add-hook 'gnus-summary-exit-hook 'gnus-picons-remove-all)))) - -(defun gnus-picons-make-path (dir subdirs) - "Make a directory name from a base DIR and a list of SUBDIRS. -Returns a directory name build by concatenating DIR and all elements of -SUBDIRS with \"/\" between elements." - (while subdirs - (setq dir (file-name-as-directory (concat dir (pop subdirs))))) - dir) - -(defsubst gnus-picons-try-suffixes (file) - (let ((suffixes gnus-picons-file-suffixes) - f) - (while (and suffixes - (not (file-exists-p (setq f (concat file (pop suffixes)))))) - (setq f nil)) - f)) + (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)))) + (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))))) (defun gnus-picons-lookup (addrs dirs) "Lookup the picon for ADDRS in databases DIRS. Returns the picon filename or NIL if none found." (let (result) (while (and dirs (null result)) - (setq result - (gnus-picons-try-suffixes - (expand-file-name "face." - (gnus-picons-make-path - (file-name-as-directory - (concat - (file-name-as-directory gnus-picons-database) - (pop dirs))) - (reverse addrs)))))) + (setq result (gnus-picons-lookup-internal addrs (pop dirs)))) result)) (defun gnus-picons-lookup-user-internal (user domains) (let ((dirs gnus-picons-user-directories) - picon) + domains-tmp dir picon) (while (and dirs (null picon)) - (let ((dir (list (pop dirs))) - (domains domains)) - (while (and domains (null picon)) - (setq picon (gnus-picons-lookup (cons user domains) dir)) - (pop domains)) - ;; Also make a try MISC subdir - (unless picon - (setq picon (gnus-picons-lookup (list user "MISC") dir))))) - + (setq domains-tmp domains + dir (pop dirs)) + (while (and domains-tmp + (null (setq picon (gnus-picons-lookup-internal + (cons user domains-tmp) dir)))) + (pop domains-tmp)) + ;; Also make a try in MISC subdir + (unless picon + (setq picon (gnus-picons-lookup-internal (list user "MISC") dir)))) picon)) (defun gnus-picons-lookup-user (user domains) @@ -345,92 +382,370 @@ DOMAINS is a list of strings from the fully qualified domain name." Returns a list of PAIRS whose CAR is the picon filename or NIL if none, and whose CDR is the corresponding element of DOMAINS." (let (picons) + (setq directories (if (listp directories) + directories + (list directories))) (while domains - (push (list (gnus-picons-lookup (cons "unknown" domains) - (if (listp directories) - directories - (list directories))) + (push (list (gnus-picons-lookup (cons "unknown" domains) directories) (pop domains)) picons)) picons)) -(defun gnus-picons-display-picon-or-name (picon name &optional xface-p right-p) - (if picon - (gnus-picons-try-to-find-face picon xface-p name right-p) - (list (make-annotation name nil 'text nil nil nil right-p)))) +(defun gnus-picons-display-picon-or-name (picon name &optional right-p) + (cond (picon (gnus-picons-display-glyph picon name right-p)) + (gnus-picons-display-as-address (list (gnus-picons-make-annotation + (vector 'string :data name) + nil 'text + nil nil nil right-p))))) -(defun gnus-picons-display-pairs (pairs &optional bar-p xface-p dot-p right-p) +(defun gnus-picons-display-pairs (pairs &optional bar-p dot-p right-p) "Display picons in list PAIRS." - (let ((bar (and bar-p (or gnus-picons-display-as-address - (annotations-in-region (point) - (min (point-max) (1+ (point))) - (current-buffer))))) - (domain-p (and gnus-picons-display-as-address dot-p)) - picons) - (while pairs - (let ((pair (pop pairs))) - (setq picons (nconc (if (and domain-p picons (not right-p)) - (list (make-annotation - dot-p nil 'text nil nil nil right-p))) - (gnus-picons-display-picon-or-name (car pair) - (cadr pair) - xface-p - right-p) - (if (and domain-p pairs right-p) - (list (make-annotation - dot-p nil 'text nil nil nil right-p))) - (when (and bar domain-p) - (setq bar nil) - (gnus-picons-try-to-find-face - (expand-file-name "bar.xbm" - gnus-xmas-glyph-directory) - nil nil t)) - picons)))) + (let ((domain-p (and gnus-picons-display-as-address dot-p)) + pair picons) + (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 + gnus-xmas-glyph-directory "bar.")) + nil right-p))) + (while (setq pair (pop pairs)) + (setq picons (nconc picons + (gnus-picons-display-picon-or-name + (car pair) (cadr pair) right-p) + (if (and domain-p pairs) + (list (gnus-picons-make-annotation + (vector 'string :data dot-p) + nil 'text nil nil nil right-p)))))) picons)) -(defvar gnus-picons-glyph-alist nil) - -(defun gnus-picons-try-to-find-face (path &optional xface-p part rightp) - "If PATH exists, display it as a bitmap. Returns t if succeeded." - (let ((glyph (and (not xface-p) - (cdr (assoc path gnus-picons-glyph-alist))))) - (when (or glyph (file-exists-p path)) - (unless glyph - (setq glyph (make-glyph path)) - (unless xface-p - (push (cons path glyph) gnus-picons-glyph-alist)) - (set-glyph-face glyph 'default)) - (let ((new (make-annotation glyph (point) 'text nil nil nil rightp))) - (nconc - (list new) - (when (and (eq major-mode 'gnus-article-mode) - (not gnus-picons-display-as-address) - (not part)) - (list (make-annotation " " (point) 'text nil nil nil rightp))) - (when (and part gnus-picons-display-as-address) - (let ((txt (make-annotation part (point) 'text nil nil nil rightp))) - (hide-annotation txt) - (set-extent-property txt 'its-partner new) - (set-extent-property txt 'keymap gnus-picons-map) - (set-extent-property txt 'mouse-face gnus-article-mouse-face) - (set-extent-property new 'its-partner txt) - (set-extent-property new 'keymap gnus-picons-map) - (list txt)))))))) - -(defun gnus-picons-toggle-extent (event) - "Toggle picon glyph at given point" +(defun gnus-picons-try-face (dir &optional filebase) + (let* ((dir (file-name-as-directory dir)) + (filebase (or filebase "face.")) + (key (concat dir filebase)) + (glyph (cdr (assoc key gnus-picons-glyph-alist))) + (suffixes gnus-picons-file-suffixes) + f suf) + (while (setq suf (pop suffixes)) + (when (file-exists-p (setq f (expand-file-name + (concat filebase suf) + dir))) + (setq suffixes nil + glyph (make-glyph f)) + (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) + (set-annotation-data + new (cons new (make-glyph (vector 'string :data part)))) + (set-annotation-action new 'gnus-picons-action-toggle)) + (nconc + (list new) + (if (and (eq major-mode 'gnus-article-mode) + (not gnus-picons-display-as-address) + (not part)) + (list (gnus-picons-make-annotation [string :data " "] (point) + 'text nil nil nil rightp)))))) + +(defun gnus-picons-action-toggle (data) + "Toggle annotation." (interactive "e") - (let* ((ant1 (event-glyph-extent event)) - (ant2 (extent-property ant1 'its-partner))) - (when (and (annotationp ant1) (annotationp ant2)) - (reveal-annotation ant2) - (hide-annotation ant1)))) + (let* ((annot (car data)) + (glyph (annotation-glyph annot))) + (set-annotation-glyph annot (cdr data)) + (set-annotation-data annot (cons annot glyph)))) + +(defun gnus-picons-clear-cache () + "Clear the picons cache." + (interactive) + (setq gnus-picons-glyph-alist nil + gnus-picons-url-alist nil)) (gnus-add-shutdown 'gnus-picons-close 'gnus) (defun gnus-picons-close () "Shut down the picons." - (setq gnus-picons-glyph-alist nil)) + (if gnus-picons-clear-cache-on-shutdown + (gnus-picons-clear-cache))) + +;;; Query a remote DB. This requires some stuff from w3 ! + +(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)) + (url-working-buffer (generate-new-buffer " *picons*")) + (url-package-name "Gnus") + (url-package-version gnus-version-number) + url-request-method) + (setq-default url-be-asynchronous t) + (save-excursion + (set-buffer url-working-buffer) + (setq url-be-asynchronous t + url-current-callback-data arg + url-current-callback-func fn) + (url-retrieve url t)) + (setq-default url-be-asynchronous old-asynch))) + +(defun gnus-picons-make-glyph (type) + "Make a TYPE glyph using current buffer as data. Handles xbm nicely." + (cond ((null type) nil) + ((eq type 'xbm) (let ((fname (make-temp-name "/tmp/picon"))) + (write-region (point-min) (point-max) fname + nil 'quiet) + (prog1 (make-glyph (vector 'xbm :file fname)) + (delete-file fname)))) + (t (make-glyph (vector type :data (buffer-string)))))) + +;;; Parsing of piconsearch result page. + +;; Assumes: +;; 1 - each value field has the form: "key = value" +;; 2 - a "

" separates the keywords from the results +;; 3 - every results begins by the path within the database at the beginning +;; of the line in raw text. +;; 3b - and the href following it is the preferred image type. + +;; if 1 or 2 is not met, it will probably cause an error. The other +;; will go undetected + +(defun gnus-picons-parse-value (name) + (goto-char (point-min)) + (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 cur-db cur-host cur-user types res) + ;; now point will be somewhere in the header. Find beginning of + ;; entries + (when (and user host dbs) + (setq start-re + (concat + ;; dbs + "^\\(" (mapconcat 'regexp-quote dbs "\\|") "\\)/" + ;; host + "\\(\\(" (mapconcat 'regexp-quote + (message-tokenize-header host ".") "/\\|") + "/\\|MISC/\\)*\\)" + ;; user + "\\(" (regexp-quote user) "\\|unknown\\)/" + "face\\.")) + (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 "