X-Git-Url: https://cgit.sxemacs.org/?a=blobdiff_plain;f=lisp%2Fgnus-picon.el;h=7f046508321d20459b9e8b9a9bb9816cf95bbf42;hb=754a007c9c67f3506008dab6e7e8943eb51848f2;hp=bbfca304b014d38568f0eba91c3a6f010725a822;hpb=1dfcb46ad59cb63dc4dfe2083bdc6b4d4348fc9c;p=gnus diff --git a/lisp/gnus-picon.el b/lisp/gnus-picon.el index bbfca304b..7f0465083 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 Free Software Foundation, Inc. +;; Copyright (C) 1996,97,98 Free Software Foundation, Inc. ;; Author: Wes Hardaker ;; Keywords: news xpm annotation glyph faces @@ -23,94 +23,89 @@ ;;; Commentary: -;; Usage: -;; - You must have XEmacs (19.12 or above I think) to use this. -;; - Read the variable descriptions below. -;; -;; - chose a setup: -;; -;; 1) display the icons in its own buffer: -;; -;; (add-hook 'gnus-article-display-hook 'gnus-article-display-picons t) -;; (add-hook 'gnus-summary-prepare-hook 'gnus-group-display-picons t) -;; (setq gnus-picons-display-where 'picons) -;; -;; Then add the picons buffer to your display configuration: -;; The picons buffer needs to be at least 48 pixels high, -;; which for me is 5 lines: -;; -;; (gnus-add-configuration -;; '(article (vertical 1.0 -;; (group 6) -;; (picons 5) -;; (summary .25 point) -;; (article 1.0)))) -;; -;; (gnus-add-configuration -;; '(summary (vertical 1.0 (group 6) -;; (picons 5) -;; (summary 1.0 point)))) -;; -;; 2) display the icons in the summary buffer -;; -;; (add-hook 'gnus-article-display-hook 'gnus-article-display-picons t) -;; (add-hook 'gnus-summary-prepare-hook 'gnus-group-display-picons t) -;; (setq gnus-picons-display-where 'summary) -;; -;; 3) display the icons in the article buffer -;; -;; (add-hook 'gnus-article-display-hook 'gnus-article-display-picons t) -;; (add-hook 'gnus-article-prepare-hook 'gnus-group-display-picons t) -;; (setq gnus-picons-display-where 'article) -;; -;; -;; Warnings: -;; - I'm not even close to being a lisp expert. -;; - The 't' (append) flag MUST be in the add-hook line -;; -;; TODO: -;; - Remove the TODO section in the headers. -;; - ;;; Code: +(require 'gnus) (require 'xpm) (require 'annotations) -(eval-when-compile (require 'cl)) - -(defvar gnus-picons-buffer "*Icon Buffer*" - "Buffer name to display the icons in if gnus-picons-display-where is 'picons.") - -(defvar gnus-picons-display-where 'picons - "Where to display the group and article icons.") - -(defvar gnus-picons-database "/usr/local/faces" - "Defines the location of the faces database. +(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." + :group 'gnus-visual) + +(defcustom gnus-picons-display-where 'picons + "Where to display the group and article icons. +Legal 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. For information on obtaining this database of pretty pictures, please -see http://www.cs.indiana.edu/picons/ftp/index.html" ) - -(defvar gnus-picons-news-directory "news" - "Sub-directory of the faces database containing the icons for newsgroups." -) +see http://www.cs.indiana.edu/picons/ftp/index.html" + :type 'directory + :group 'picons) + +(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." + :type '(repeat string) + :group 'picons) + +(defcustom gnus-picons-domain-directories '("domains") + "*List of directories to search for domain faces. +Some people may want to add \"unknown\" to this list." + :type '(repeat string) + :group 'picons) -(defvar gnus-picons-user-directories '("local" "users" "usenix" "misc/MISC") - "List of directories to search for user faces." -) +(defcustom gnus-picons-refresh-before-display nil + "*If non-nil, display the article buffer before computing the picons." + :type 'boolean + :group 'picons) -(defvar gnus-picons-domain-directories '("domains") - "List of directories to search for domain faces. -Some people may want to add \"unknown\" to this list." -) +(defcustom gnus-picons-group-excluded-groups nil + "*If this regexp matches the group name, group picons will be disabled." + :type 'regexp + :group 'picons) -(defvar gnus-picons-x-face-file-name +(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.") + "*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) -(defvar 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." -) +(defcustom gnus-picons-display-as-address t + "*If t display textual email addresses along with pictures." + :type 'boolean + :group 'picons) -(defvar gnus-picons-file-suffixes +(defcustom gnus-picons-file-suffixes (when (featurep 'x) (let ((types (list "xbm"))) (when (featurep 'gif) @@ -118,230 +113,596 @@ 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.") - -;;; Internal variables. - -(defvar gnus-group-annotations nil) -(defvar gnus-article-annotations nil) -(defvar gnus-x-face-annotations nil) - -(defun gnus-picons-remove (plist) - (let ((listitem (car plist))) - (while (setq listitem (car plist)) - (if (annotationp listitem) - (delete-annotation listitem)) - (setq plist (cdr plist)))) - ) + "*List of suffixes on picon file names to try." + :type '(repeat string) + :group 'picons) + +(defcustom gnus-picons-display-article-move-p t + "*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) + +(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 X face" + :group 'picons) + +;;; Internal variables: + +(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) - (setq gnus-article-annotations nil - gnus-group-annotations nil - gnus-x-face-annotations nil) - (if (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))) + (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-set-buffer () + (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) + (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-picons-article-display-x-face () "Display the x-face header bitmap in the 'gnus-picons-display-where buffer." - ;; delete any old ones. - (gnus-picons-remove gnus-x-face-annotations) - (setq gnus-x-face-annotations nil) - ;; 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) + (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) + (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) - ;; convert the x-face header to a .xbm file - (let ((process-connection-type nil) - (process nil)) - (process-kill-without-query - (setq process (start-process - "gnus-x-face" nil shell-file-name shell-command-switch - gnus-picons-convert-x-face))) - (process-send-region "gnus-x-face" beg end) - (process-send-eof "gnus-x-face") - ;; wait for it. - (while (not (equal (process-status process) 'exit)) - (sleep-for .1))) - ;; display it - (save-excursion - (set-buffer (get-buffer-create (gnus-get-buffer-name - gnus-picons-display-where))) - (gnus-add-current-to-buffer-list) - (goto-char (point-min)) - (let (buffer-read-only) - (unless (looking-at "$") - (open-line 1)) - ;; append the annotation to gnus-article-annotations for deletion. - (setq gnus-x-face-annotations - (append - (gnus-picons-try-to-find-face gnus-picons-x-face-file-name) - gnus-x-face-annotations))) - ;; delete the tmp file - (delete-file gnus-picons-x-face-file-name))) + (if (featurep 'xface) + ;; Use builtin support + (save-excursion + (gnus-picons-set-buffer) + (gnus-picons-make-annotation + (vector 'xface + :data (concat "X-Face: " (buffer-substring beg end))) + nil 'text)) + ;; 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 his/her domain in gnus-picons-display-where." + "Display faces for an author and her domain in gnus-picons-display-where." (interactive) - (if (and (featurep 'xpm) - (or (not (fboundp 'device-type)) (equal (device-type) 'x)) - (mail-fetch-field "from")) + (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)) + ""))) + (or (setq at-idx (string-match "@" from)) + (setq at-idx (length from)))) (save-excursion - (let* ((from (mail-fetch-field "from")) - (username - (progn - (string-match "\\([-_a-zA-Z0-9]+\\)@" from) - (match-string 1 from))) - (hostpath - (concat - (gnus-picons-reverse-domain-path - (replace-in-string - (replace-in-string - (cadr (mail-extract-address-components from)) - ".*@\\(.*\\)\\'" "\\1") - "\\." "/")) "/"))) - (set-buffer (get-buffer-create - (gnus-get-buffer-name gnus-picons-display-where))) - (gnus-add-current-to-buffer-list) - (goto-char (point-min)) - (if (eq gnus-picons-display-where 'article) - (and (search-forward "\n\n" nil t) - (forward-line -1)) - (unless (eolp) - (open-line 1))) - - (gnus-picons-remove gnus-article-annotations) - (setq gnus-article-annotations nil) - (if (equal username from) - (setq username (progn - (string-match "<\\([_a-zA-Z0-9-.]+\\)>" from) - (match-string 1 from)))) - (mapcar (lambda (pathpart) - (setq gnus-article-annotations - (append - (gnus-picons-insert-face-if-exists - (concat - (file-name-as-directory - gnus-picons-database) pathpart) - (concat hostpath username)) - gnus-article-annotations))) - gnus-picons-user-directories) - (mapcar (lambda (pathpart) - (setq gnus-article-annotations - (append - (gnus-picons-insert-face-if-exists - (concat (file-name-as-directory - gnus-picons-database) pathpart) - (concat hostpath)) - gnus-article-annotations))) - gnus-picons-domain-directories) - (add-hook 'gnus-summary-exit-hook 'gnus-picons-remove-all))))) + (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 ".")) + (message-tokenize-header (substring from (1+ at-idx)) + ".")))) + (gnus-picons-prepare-for-annotations) + (gnus-group-display-picons) + (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) + 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))) + (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 - (set-buffer (get-buffer-create - (gnus-get-buffer-name gnus-picons-display-where))) - (gnus-add-current-to-buffer-list) - (goto-char (point-min)) - (if (eq gnus-picons-display-where 'article) - (and (search-forward "\n\n" nil t) - (forward-line -1) - ) - (unless (eolp) - (open-line 1))) - (cond - ((listp gnus-group-annotations) - (mapcar 'delete-annotation gnus-group-annotations) - (setq gnus-group-annotations nil)) - ((annotationp gnus-group-annotations) - (delete-annotation gnus-group-annotations) - (setq gnus-group-annotations nil))) - (gnus-picons-remove gnus-group-annotations) - (setq gnus-group-annotations - (gnus-picons-insert-face-if-exists - (concat (file-name-as-directory gnus-picons-database) - gnus-picons-news-directory) - (replace-in-string gnus-newsgroup-name "\\." "/") - t t)) + (gnus-picons-prepare-for-annotations) + (if (null gnus-picons-piconsearch-url) + (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-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)) - -(defun gnus-picons-insert-face-if-exists (path filename &optional rev bar) - "Inserts a face at point if I can find one" - (let ((files (message-tokenize-header filename "/")) - picons found) -; (when rev -; (setq files (nreverse files))) - (while (and files - (file-exists-p path)) - (setq path (concat path "/" (pop files))) - (when (setq found - (or - (gnus-picons-try-suffixes (concat path "/face.")) - (gnus-picons-try-suffixes (concat path "/unknown/face.")))) - (when bar - (setq picons - (nconc picons - (gnus-picons-try-to-find-face - (concat gnus-xmas-glyph-directory "bar.xbm"))))) - (setq picons (nconc (gnus-picons-try-to-find-face found) - picons)))) - (nreverse picons))) - -(defvar gnus-picons-glyph-alist nil) - -(defun gnus-picons-try-to-find-face (path) - "If PATH exists, display it as a bitmap. Returns t if succedded." - (let ((glyph (cdr (assoc path gnus-picons-glyph-alist)))) - (when (or glyph (file-exists-p path)) - (unless glyph - (push (cons path (setq glyph (make-glyph path))) - gnus-picons-glyph-alist) - (set-glyph-face glyph 'default)) - (nconc - (list (make-annotation glyph (point) 'text)) - (when (eq major-mode 'gnus-article-mode) - (list (make-annotation " " (point) 'text))))))) - -(defun gnus-picons-reverse-domain-path (str) - "a/b/c/d -> d/c/b/a" - (mapconcat 'identity (nreverse (message-tokenize-header str "/")) "/")) +(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-lookup-internal addrs (pop dirs)))) + result)) + +(defun gnus-picons-lookup-user-internal (user domains) + (let ((dirs gnus-picons-user-directories) + domains-tmp dir picon) + (while (and dirs (null picon)) + (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) + "Lookup the picon for USER at DOMAINS. +USER is a string containing a name. +DOMAINS is a list of strings from the fully qualified domain name." + (or (gnus-picons-lookup-user-internal user domains) + (gnus-picons-lookup-user-internal "unknown" domains))) + +(defun gnus-picons-lookup-pairs (domains directories) + "Lookup picons for DOMAINS and all its parents in DIRECTORIES. +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) directories) + (pop domains)) + picons)) + picons)) + +(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 dot-p right-p) + "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) + (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)) + +(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)) + (when (equal suf "xbm") + (set-glyph-face glyph 'gnus-picons-xbm-face)) + (push (cons key glyph) gnus-picons-glyph-alist))) + glyph)) + +(defun gnus-picons-display-glyph (glyph &optional part rightp) + (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* ((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 ! + +(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)) + (re-search-forward (concat "" + (regexp-quote name) + " *= * *\\([^ <][^<]*\\) *")) + (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) + ;; 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 "