cgit.sxemacs.org Git - gnus/blob - lisp/gnus-picon.el

   1 ;;; gnus-picon.el --- displaying pretty icons in Gnus
   2 ;; Copyright (C) 1996,97 Free Software Foundation, Inc.
   3
   4 ;; Author: Wes Hardaker <hardaker@ece.ucdavis.edu>
   5 ;; Keywords: news xpm annotation glyph faces
   6
   7 ;; This file is part of GNU Emacs.
   8
   9 ;; GNU Emacs is free software; you can redistribute it and/or modify
  10 ;; it under the terms of the GNU General Public License as published by
  11 ;; the Free Software Foundation; either version 2, or (at your option)
  12 ;; any later version.
  13
  14 ;; GNU Emacs is distributed in the hope that it will be useful,
  15 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  16 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  17 ;; GNU General Public License for more details.
  18
  19 ;; You should have received a copy of the GNU General Public License
  20 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  21 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  22 ;; Boston, MA 02111-1307, USA.
  23
  24 ;;; Commentary:
  25
  26 ;;; TODO:
  27 ;; See the comment in gnus-picons-remove
  28
  29 ;;; Code:
  30
  31 (require 'gnus)
  32 (require 'xpm)
  33 (require 'annotations)
  34 (require 'custom)
  35 (require 'gnus-art)
  36 (require 'gnus-win)
  37
  38 ;;; User variables:
  39
  40 (defgroup picons nil
  41   "Show pictures of people, domains, and newsgroups (XEmacs).
  42 For this to work, you must add gnus-group-display-picons to the
  43 gnus-summary-display-hook or to the gnus-article-display-hook
  44 depending on what gnus-picons-display-where is set to.  You must
  45 also add gnus-article-display-picons to gnus-article-display-hook."
  46   :group 'gnus-visual)
  47
  48 (defcustom gnus-picons-buffer "*Icon Buffer*"
  49   "Buffer name to display the icons in if gnus-picons-display-where is 'picons."
  50   :type 'string
  51   :group 'picons)
  52
  53 (defcustom gnus-picons-display-where 'picons
  54   "Where to display the group and article icons.
  55 Legal values are `article' and `picons'."
  56   :type '(choice symbol string)
  57   :group 'picons)
  58
  59 (defcustom gnus-picons-database "/usr/local/faces"
  60   "Defines the location of the faces database.
  61 For information on obtaining this database of pretty pictures, please
  62 see http://www.cs.indiana.edu/picons/ftp/index.html"
  63   :type 'directory
  64   :group 'picons)
  65
  66 (defcustom gnus-picons-news-directory "news"
  67   "Sub-directory of the faces database containing the icons for newsgroups."
  68   :type 'string
  69   :group 'picons)
  70
  71 (defcustom gnus-picons-user-directories '("local" "users" "usenix" "misc")
  72   "List of directories to search for user faces."
  73   :type '(repeat string)
  74   :group 'picons)
  75
  76 (defcustom gnus-picons-domain-directories '("domains")
  77   "List of directories to search for domain faces.
  78 Some people may want to add \"unknown\" to this list."
  79   :type '(repeat string)
  80   :group 'picons)
  81
  82 (defcustom gnus-picons-refresh-before-display nil
  83   "If non-nil, display the article buffer before computing the picons."
  84   :type 'boolean
  85   :group 'picons)
  86
  87 (defcustom gnus-picons-x-face-file-name
  88   (format "/tmp/picon-xface.%s.xbm" (user-login-name))
  89   "The name of the file in which to store the converted X-face header."
  90   :type 'string
  91   :group 'picons)
  92
  93 (defcustom gnus-picons-convert-x-face (format "{ echo '/* Width=48, Height=48 */'; uncompface; } | icontopbm | pbmtoxbm > %s" gnus-picons-x-face-file-name)
  94   "Command to convert the x-face header into a xbm file."
  95   :type 'string
  96   :group 'picons)
  97
  98 (defcustom gnus-picons-display-as-address t
  99   "*If t display textual email addresses along with pictures."
 100   :type 'boolean
 101   :group 'picons)
 102
 103 (defcustom gnus-picons-file-suffixes
 104   (when (featurep 'x)
 105     (let ((types (list "xbm")))
 106       (when (featurep 'gif)
 107         (push "gif" types))
 108       (when (featurep 'xpm)
 109         (push "xpm" types))
 110       types))
 111   "List of suffixes on picon file names to try."
 112   :type '(repeat string)
 113   :group 'picons)
 114
 115 (defcustom gnus-picons-display-article-move-p t
 116   "*Whether to move point to first empty line when displaying picons.
 117 This has only an effect if `gnus-picons-display-where' has value `article'."
 118   :type 'boolean
 119   :group 'picons)
 120
 121 (defcustom gnus-picons-clear-cache-on-shutdown t
 122   "*Whether to clear the picons cache when exiting gnus.
 123 Gnus caches every picons it finds while it is running.  This saves
 124 some time in the search process but eats some memory.  If this
 125 variable is set to nil, Gnus will never clear the cache itself; you
 126 will have to manually call `gnus-picons-clear-cache' to clear it.
 127 Otherwise the cache will be cleared every time you exit Gnus."
 128   :type 'boolean
 129   :group 'picons)
 130
 131 (defcustom gnus-picons-piconsearch-url nil
 132   "*The url to query for picons.  Setting this to nil will disable it.
 133 The only plublicly available address currently known is
 134 http://www.cs.indiana.edu:800/piconsearch.  If you know of any other,
 135 please tell me so that we can list it."
 136   :type '(choice (const :tag "Disable" :value nil)
 137                  (const :tag "www.cs.indiana.edu"
 138                         :value "http://www.cs.indiana.edu:800/piconsearch")
 139                  (string))
 140   :group 'picons)
 141
 142 ;;; Internal variables:
 143
 144 (defvar gnus-picons-processes-alist nil
 145   "Picons processes currently running and their environment.")
 146 (defvar gnus-picons-glyph-alist nil
 147   "Picons glyphs cache.
 148 List of pairs (KEY . GLYPH) where KEY is either a filename or an URL.")
 149 (defvar gnus-picons-url-alist nil
 150   "Picons file names cache.
 151 List of pairs (KEY . NAME) where KEY is (USER HOST DBS) and NAME is an URL.")
 152
 153 (defvar gnus-group-annotations nil
 154   "List of annotations added/removed when selecting/exiting a group")
 155 (defvar gnus-group-annotations-lock nil)
 156 (defvar gnus-article-annotations nil
 157   "List of annotations added/removed when selecting an article")
 158 (defvar gnus-article-annotations-lock nil)
 159 (defvar gnus-x-face-annotations nil
 160   "List of annotations added/removed when selecting an article with an
 161 X-Face.")
 162 (defvar gnus-x-face-annotations-lock nil)
 163
 164 (defvar gnus-picons-jobs-alist nil
 165   "List of jobs that still need be done.
 166 This is a list of (SYM-ANN TAG ARGS...) where SYM-ANN three annotations list,
 167 TAG is one of `picon' or `search' indicating that the job should query a
 168 picon or do a search for picons file names, and ARGS is some additionnal
 169 arguments necessary for the job.")
 170
 171 (defvar gnus-picons-job-already-running nil
 172   "Lock to ensure only one stream of http requests is running.")
 173
 174 ;;; Functions:
 175
 176 (defsubst gnus-picons-lock (symbol)
 177   (intern (concat (symbol-name symbol) "-lock")))
 178
 179 (defun gnus-picons-remove (symbol)
 180   "Remove all annotations in variable named SYMBOL.
 181 This function is careful to set it to nil before removing anything so that
 182 asynchronous process don't get crazy."
 183   ;; clear the lock
 184   (set (gnus-picons-lock symbol) nil)
 185   ;; clear all annotations
 186   (mapc (function (lambda (item)
 187                     (if (annotationp item)
 188                         (delete-annotation item))))
 189         (prog1 (symbol-value symbol)
 190           (set symbol nil)))
 191   ;; FIXME: there's a race condition here.  If a job is already
 192   ;; running, it has already removed itself from this queue...  But
 193   ;; will still display its picon.
 194   ;; TODO: push a request to clear an annotation.  Then
 195   ;; gnus-picons-next-job will be able to clean up when it gets the
 196   ;; hand
 197   (setq gnus-picons-jobs-alist (remassq symbol gnus-picons-jobs-alist)))
 198
 199 (defun gnus-picons-remove-all ()
 200   "Removes all picons from the Gnus display(s)."
 201   (interactive)
 202   (gnus-picons-remove 'gnus-article-annotations)
 203   (gnus-picons-remove 'gnus-group-annotations)
 204   (gnus-picons-remove 'gnus-x-face-annotations)
 205   (when (bufferp gnus-picons-buffer)
 206     (kill-buffer gnus-picons-buffer)))
 207
 208 (defun gnus-get-buffer-name (variable)
 209   "Returns the buffer name associated with the contents of a variable."
 210   (cond ((symbolp variable) (let ((newvar (cdr (assq variable
 211                                                      gnus-window-to-buffer))))
 212                               (cond ((symbolp newvar)
 213                                      (symbol-value newvar))
 214                                     ((stringp newvar) newvar))))
 215         ((stringp variable) variable)))
 216
 217 (defun gnus-picons-prepare-for-annotations (annotations)
 218   "Prepare picons buffer for puting annotations memorized in ANNOTATIONS.
 219 ANNOTATIONS should be a symbol naming a variable wich contains a list of
 220 annotations.  Sets buffer to `gnus-picons-display-where'."
 221   ;; let drawing catch up
 222   (when gnus-picons-refresh-before-display
 223     (sit-for 0))
 224   (set-buffer (get-buffer-create
 225                (gnus-get-buffer-name gnus-picons-display-where)))
 226   (gnus-add-current-to-buffer-list)
 227   (goto-char (point-min))
 228   (if (and (eq gnus-picons-display-where 'article)
 229            gnus-picons-display-article-move-p)
 230       (when (search-forward "\n\n" nil t)
 231         (forward-line -1))
 232     (make-local-variable 'inhibit-read-only)
 233     (setq buffer-read-only t
 234           inhibit-read-only nil))
 235   (gnus-picons-remove annotations))
 236
 237 (defun gnus-picons-article-display-x-face ()
 238   "Display the x-face header bitmap in the 'gnus-picons-display-where buffer."
 239   ;; delete any old ones.
 240   ;; This is needed here because gnus-picons-display-x-face will not
 241   ;; be called if there is no X-Face header
 242   (gnus-picons-remove 'gnus-x-face-annotations)
 243   ;; display the new one.
 244   (let ((gnus-article-x-face-command 'gnus-picons-display-x-face))
 245     (gnus-article-display-x-face)))
 246
 247 (defun gnus-picons-x-face-sentinel (process event)
 248   (let* ((env (assq process gnus-picons-processes-alist))
 249          (annot (cdr env)))
 250     (setq gnus-picons-processes-alist (remassq process
 251                                                gnus-picons-processes-alist))
 252     (when annot
 253       (set-annotation-glyph annot
 254                             (make-glyph gnus-picons-x-face-file-name))
 255       (if (memq annot gnus-x-face-annotations)
 256           (delete-file gnus-picons-x-face-file-name)))))
 257
 258 (defun gnus-picons-display-x-face (beg end)
 259   "Function to display the x-face header in the picons window.
 260 To use:  (setq gnus-article-x-face-command 'gnus-picons-display-x-face)"
 261   (interactive)
 262   (if (featurep 'xface)
 263       ;; Use builtin support
 264       (let ((buf (current-buffer)))
 265         (save-excursion
 266           (gnus-picons-prepare-for-annotations 'gnus-x-face-annotations)
 267           (setq gnus-x-face-annotations
 268                 (cons (make-annotation
 269                        (vector 'xface
 270                                :data (concat "X-Face: "
 271                                              (buffer-substring beg end buf)))
 272                                        nil 'text)
 273                       gnus-x-face-annotations))))
 274     ;; convert the x-face header to a .xbm file
 275     (let* ((process-connection-type nil)
 276            (annot (save-excursion
 277                     (gnus-picons-prepare-for-annotations
 278                      'gnus-x-face-annotations)
 279                     (make-annotation nil nil 'text)))
 280            (process (start-process-shell-command "gnus-x-face" nil
 281                                                  gnus-picons-convert-x-face)))
 282       (push annot gnus-x-face-annotations)
 283       (push (cons process annot) gnus-picons-processes-alist)
 284       (process-kill-without-query process)
 285       (set-process-sentinel process 'gnus-picons-x-face-sentinel)
 286       (process-send-region process beg end)
 287       (process-send-eof process))))
 288
 289 (defun gnus-article-display-picons ()
 290   "Display faces for an author and his/her domain in gnus-picons-display-where."
 291   (interactive)
 292   (let (from at-idx)
 293     (when (and (featurep 'xpm)
 294                (or (not (fboundp 'device-type)) (equal (device-type) 'x))
 295                (setq from (mail-fetch-field "from"))
 296                (setq from (downcase (or (cadr (mail-extract-address-components
 297                                                from))
 298                                         "")))
 299                (or (setq at-idx (string-match "@" from))
 300                    (setq at-idx (length from))))
 301       (save-excursion
 302         (let ((username (downcase (substring from 0 at-idx)))
 303               (addrs (if (eq at-idx (length from))
 304                          (if gnus-local-domain
 305                              (message-tokenize-header gnus-local-domain "."))
 306                        (message-tokenize-header (substring from (1+ at-idx))
 307                                                 "."))))
 308           (gnus-picons-prepare-for-annotations 'gnus-article-annotations)
 309           (if (null gnus-picons-piconsearch-url)
 310               (setq gnus-article-annotations
 311                     (nconc gnus-article-annotations
 312                            (gnus-picons-display-pairs
 313                             (gnus-picons-lookup-pairs
 314                              addrs gnus-picons-domain-directories)
 315                             (not (or gnus-picons-display-as-address
 316                                      gnus-article-annotations))
 317                             "." t)
 318                            (if (and gnus-picons-display-as-address addrs)
 319                                (list (make-annotation [string :data "@"] nil
 320                                                       'text nil nil nil t)))
 321                            (gnus-picons-display-picon-or-name
 322                             (gnus-picons-lookup-user username addrs)
 323                             username t)))
 324             (push (list 'gnus-article-annotations 'search username addrs
 325                         gnus-picons-domain-directories t)
 326                   gnus-picons-jobs-alist)
 327             (gnus-picons-next-job))
 328
 329           (add-hook 'gnus-summary-exit-hook 'gnus-picons-remove-all))))))
 330
 331 (defun gnus-group-display-picons ()
 332   "Display icons for the group in the gnus-picons-display-where buffer."
 333   (interactive)
 334   (when (and (featurep 'xpm)
 335              (or (not (fboundp 'device-type)) (equal (device-type) 'x)))
 336     (save-excursion
 337       (gnus-picons-prepare-for-annotations 'gnus-group-annotations)
 338       (if (null gnus-picons-piconsearch-url)
 339           (setq gnus-group-annotations
 340                 (gnus-picons-display-pairs
 341                  (gnus-picons-lookup-pairs (reverse (message-tokenize-header
 342                                                      gnus-newsgroup-name "."))
 343                                            gnus-picons-news-directory)
 344                  t "."))
 345         (push (list 'gnus-group-annotations 'search nil
 346                     (message-tokenize-header gnus-newsgroup-name ".")
 347                     (if (listp gnus-picons-news-directory)
 348                         gnus-picons-news-directory
 349                       (list gnus-picons-news-directory))
 350                     nil)
 351               gnus-picons-jobs-alist)
 352         (gnus-picons-next-job))
 353
 354       (add-hook 'gnus-summary-exit-hook 'gnus-picons-remove-all))))
 355
 356 (defsubst gnus-picons-lookup-internal (addrs dir)
 357   (setq dir (expand-file-name dir gnus-picons-database))
 358   (gnus-picons-try-face (dolist (part (reverse addrs) dir)
 359                           (setq dir (expand-file-name part dir)))))
 360
 361 (defun gnus-picons-lookup (addrs dirs)
 362   "Lookup the picon for ADDRS in databases DIRS.
 363 Returns the picon filename or NIL if none found."
 364   (let (result)
 365     (while (and dirs (null result))
 366       (setq result (gnus-picons-lookup-internal addrs (pop dirs))))
 367     result))
 368
 369 (defun gnus-picons-lookup-user-internal (user domains)
 370   (let ((dirs gnus-picons-user-directories)
 371         domains-tmp dir picon)
 372     (while (and dirs (null picon))
 373       (setq domains-tmp domains
 374             dir (pop dirs))
 375       (while (and domains-tmp
 376                   (null (setq picon (gnus-picons-lookup-internal
 377                                      (cons user domains-tmp) dir))))
 378         (pop domains-tmp))
 379       ;; Also make a try in MISC subdir
 380       (unless picon
 381         (setq picon (gnus-picons-lookup-internal (list user "MISC") dir))))
 382     picon))
 383
 384 (defun gnus-picons-lookup-user (user domains)
 385   "Lookup the picon for USER at DOMAINS.
 386 USER is a string containing a name.
 387 DOMAINS is a list of strings from the fully qualified domain name."
 388   (or (gnus-picons-lookup-user-internal user domains)
 389       (gnus-picons-lookup-user-internal "unknown" domains)))
 390
 391 (defun gnus-picons-lookup-pairs (domains directories)
 392   "Lookup picons for DOMAINS and all its parents in DIRECTORIES.
 393 Returns a list of PAIRS whose CAR is the picon filename or NIL if
 394 none, and whose CDR is the corresponding element of DOMAINS."
 395   (let (picons)
 396     (setq directories (if (listp directories)
 397                           directories
 398                         (list directories)))
 399     (while domains
 400       (push (list (gnus-picons-lookup (cons "unknown" domains) directories)
 401                   (pop domains))
 402             picons))
 403     picons))
 404
 405 (defun gnus-picons-display-picon-or-name (picon name &optional right-p)
 406   (cond (picon (gnus-picons-display-glyph picon name right-p))
 407         (gnus-picons-display-as-address (list (make-annotation
 408                                                (vector 'string :data name)
 409                                                nil 'text
 410                                                nil nil nil right-p)))))
 411
 412 (defun gnus-picons-display-pairs (pairs &optional bar-p dot-p right-p)
 413   "Display picons in list PAIRS."
 414   (let ((bar (and bar-p (or gnus-picons-display-as-address
 415                             (annotations-in-region (point)
 416                                                    (min (point-max)
 417                                                         (1+ (point)))
 418                                                    (current-buffer)))))
 419         (domain-p (and gnus-picons-display-as-address dot-p))
 420         pair picons)
 421     (while pairs
 422       (setq pair (pop pairs)
 423             picons (nconc (if (and domain-p picons (not right-p))
 424                               (list (make-annotation
 425                                      (vector 'string :data dot-p)
 426                                      nil 'text nil nil nil right-p)))
 427                           (gnus-picons-display-picon-or-name (car pair)
 428                                                              (cadr pair)
 429                                                              right-p)
 430                           (if (and domain-p pairs right-p)
 431                               (list (make-annotation
 432                                      (vector 'string :data dot-p)
 433                                      nil 'text nil nil nil right-p)))
 434                           (when (and bar domain-p)
 435                             (setq bar nil)
 436                             (gnus-picons-display-glyph
 437                              (gnus-picons-try-face gnus-xmas-glyph-directory
 438                                                    "bar.")
 439                              nil t))
 440                           picons)))
 441     picons))
 442
 443 (defun gnus-picons-try-face (dir &optional filebase)
 444   (let* ((dir (file-name-as-directory dir))
 445          (filebase (or filebase "face."))
 446          (key (concat dir filebase))
 447          (glyph (cdr (assoc key gnus-picons-glyph-alist)))
 448          (suffixes gnus-picons-file-suffixes)
 449          f)
 450     (while (and suffixes (null glyph))
 451       (when (file-exists-p (setq f (expand-file-name (concat filebase
 452                                                                  (pop suffixes))
 453                                                          dir)))
 454         (setq glyph (make-glyph f))
 455         (push (cons key glyph) gnus-picons-glyph-alist)))
 456     glyph))
 457
 458 (defun gnus-picons-display-glyph (glyph &optional part rightp)
 459   (let ((new (make-annotation glyph (point) 'text nil nil nil rightp)))
 460     (when (and part gnus-picons-display-as-address)
 461       (set-annotation-data new (cons new
 462                                      (make-glyph (vector 'string :data part))))
 463       (set-annotation-action new 'gnus-picons-action-toggle))
 464     (nconc
 465      (list new)
 466      (if (and (eq major-mode 'gnus-article-mode)
 467               (not gnus-picons-display-as-address)
 468               (not part))
 469          (list (make-annotation [string :data " "]
 470                                 (point) 'text nil nil nil rightp))))))
 471
 472 (defun gnus-picons-action-toggle (data)
 473   "Toggle annotation"
 474   (interactive "e")
 475   (let* ((annot (car data))
 476          (glyph (annotation-glyph annot)))
 477     (set-annotation-glyph annot (cdr data))
 478     (set-annotation-data annot (cons annot glyph))))
 479
 480 (defun gnus-picons-clear-cache ()
 481   "Clear the picons cache"
 482   (interactive)
 483   (setq gnus-picons-glyph-alist nil))
 484
 485 (gnus-add-shutdown 'gnus-picons-close 'gnus)
 486
 487 (defun gnus-picons-close ()
 488   "Shut down the picons."
 489   (if gnus-picons-clear-cache-on-shutdown
 490       (gnus-picons-clear-cache)))
 491
 492 ;;; Query a remote DB.  This requires some stuff from w3 !
 493
 494 (require 'url)
 495 (require 'w3-forms)
 496
 497 (defun gnus-picons-url-retrieve (url fn arg)
 498   (let ((old-asynch (default-value 'url-be-asynchronous))
 499         (url-working-buffer (generate-new-buffer " *picons*"))
 500         (url-request-method nil)
 501         (url-package-name "Gnus")
 502         (url-package-version gnus-version-number))
 503     (setq-default url-be-asynchronous t)
 504     (save-excursion
 505       (set-buffer url-working-buffer)
 506       (setq url-be-asynchronous t
 507             url-show-status nil
 508             url-current-callback-data arg
 509             url-current-callback-func fn)
 510       (url-retrieve url t))
 511     (setq-default url-be-asynchronous old-asynch)))
 512
 513 (defun gnus-picons-make-glyph (type)
 514   "Make a TYPE glyph using current buffer as data.  Handles xbm nicely."
 515   (cond ((null type) nil)
 516         ((eq type 'xbm) (let ((fname (make-temp-name "/tmp/picon")))
 517                           (write-region (point-min) (point-max) fname
 518                                         nil 'quiet)
 519                           (prog1 (make-glyph (vector 'xbm :file fname))
 520                             (delete-file fname))))
 521         (t (make-glyph (vector type :data (buffer-string))))))
 522
 523 ;;; Parsing of piconsearch result page.
 524
 525 ;; Assumes:
 526 ;; 1 - each value field has the form: "<strong>key</strong> = <kbd>value</kbd>"
 527 ;; 2 - a "<p>" separates the keywords from the results
 528 ;; 3 - every results begins by the path within the database at the beginning
 529 ;;     of the line in raw text.
 530 ;; 3b - and the href following it is the preferred image type.
 531
 532 ;; if 1 or 2 is not met, it will probably cause an error.  The other
 533 ;; will go undetected
 534
 535 (defun gnus-picons-parse-value (name)
 536   (goto-char (point-min))
 537   (re-search-forward (concat "<strong>"
 538                              (regexp-quote name)
 539                              "</strong> *= *<kbd> *\\([^ <][^<]*\\) *</kbd>"))
 540   (buffer-substring (match-beginning 1) (match-end 1)))
 541
 542 (defun gnus-picons-parse-filenames ()
 543   ;; returns an alist of ((USER ADDRS DB) . URL)
 544   (let* ((case-fold-search t)
 545          (user (gnus-picons-parse-value "user"))
 546          (host (gnus-picons-parse-value "host"))
 547          (dbs (message-tokenize-header (gnus-picons-parse-value "db") " "))
 548          (start-re
 549           (concat
 550            ;; dbs
 551            "^\\(" (mapconcat 'identity dbs "\\|") "\\)/"
 552            ;; host
 553            "\\(\\(" (replace-in-string host "\\." "/\\|" t) "/\\|MISC/\\)*\\)"
 554            ;; user
 555            "\\(" (regexp-quote user) "\\|unknown\\)/"
 556            "face\\."))
 557          cur-db cur-host cur-user types res)
 558     ;; now point will be somewhere in the header.  Find beginning of
 559     ;; entries
 560     (re-search-forward "<p>[ \t\n]*")
 561     (while (re-search-forward start-re nil t)
 562       (setq cur-db (buffer-substring (match-beginning 1) (match-end 1))
 563             cur-host (buffer-substring (match-beginning 2) (match-end 2))
 564             cur-user (buffer-substring (match-beginning 4) (match-end 4))
 565             cur-host (nreverse (message-tokenize-header cur-host "/")))
 566       ;; XXX - KLUDGE: there is a blank picon in news/MISC/unknown
 567       (unless (and (string-equal cur-db "news")
 568                    (string-equal cur-user "unknown")
 569                    (equal cur-host '("MISC")))
 570         ;; ok now we have found an entry (USER HOST DB), find the
 571         ;; corresponding picon URL
 572         (save-restriction
 573           ;; restrict region to this entry
 574           (narrow-to-region (point) (search-forward "<br>"))
 575           (goto-char (point-min))
 576           (setq types gnus-picons-file-suffixes)
 577           (while (and types
 578                       (not (re-search-forward
 579                             (concat "<a[ \t\n]+href=\"\\([^\"]*\\."
 580                                     (regexp-quote (car types)) "\\)\"")
 581                             nil t)))
 582             (pop types))
 583           (push (cons (list cur-user cur-host cur-db)
 584                       (buffer-substring (match-beginning 1) (match-end 1)))
 585                 res))))
 586     (nreverse res)))
 587
 588 ;;; picon network display functions :
 589
 590 (defun gnus-picons-network-display-internal (sym-ann glyph part right-p)
 591   (set-buffer
 592    (get-buffer-create (gnus-get-buffer-name gnus-picons-display-where)))
 593   (set sym-ann (nconc (symbol-value sym-ann)
 594                       (gnus-picons-display-picon-or-name glyph part right-p)))
 595   (gnus-picons-next-job-internal))
 596
 597 (defun gnus-picons-network-display-callback (url part sym-ann right-p)
 598   (let ((glyph (gnus-picons-make-glyph (cdr (assoc url-current-mime-type
 599                                                    w3-image-mappings)))))
 600     (kill-buffer (current-buffer))
 601     (push (cons url glyph) gnus-picons-glyph-alist)
 602     (gnus-picons-network-display-internal sym-ann glyph part right-p)))
 603
 604 (defun gnus-picons-network-display (url part sym-ann right-p)
 605   (let ((cache (assoc url gnus-picons-glyph-alist)))
 606     (if (or cache (null url))
 607         (gnus-picons-network-display-internal sym-ann (cdr cache) part right-p)
 608       (gnus-picons-url-retrieve url 'gnus-picons-network-display-callback
 609                                 (list url part sym-ann right-p)))))
 610
 611 ;;; search job functions
 612
 613 (defun gnus-picons-network-search-internal (user addrs dbs sym-ann right-p
 614                                                  &optional fnames)
 615   (let (curkey dom pfx url dbs-tmp cache new-jobs)
 616     ;; First do the domain search
 617     (dolist (part (if right-p
 618                       (reverse addrs)
 619                     addrs))
 620       (setq pfx (nconc (list part) pfx)
 621             dom (cond ((and dom right-p) (concat part "." dom))
 622                       (dom (concat dom "." part))
 623                       (t part))
 624             curkey (list "unknown" dom dbs))
 625       (when (null (setq cache (assoc curkey gnus-picons-url-alist)))
 626         ;; This one is not yet in the cache, create a new entry
 627         ;; Search for an entry
 628         (setq dbs-tmp dbs
 629               url nil)
 630         (while (and dbs-tmp (null url))
 631           (setq url (or (cdr (assoc (list "unknown" pfx (car dbs-tmp)) fnames))
 632                         (and (eq dom part)
 633                              ;; This is the first component.  Try the
 634                              ;; catch-all MISC component
 635                              (cdr (assoc (list "unknown"
 636                                                '("MISC")
 637                                                (car dbs-tmp))
 638                                          fnames)))))
 639           (pop dbs-tmp))
 640         (push (setq cache (cons curkey url)) gnus-picons-url-alist))
 641       ;; Put this glyph in the job list
 642       (if (and (not (eq dom part)) gnus-picons-display-as-address)
 643           (push (list sym-ann "." right-p) new-jobs))
 644       (push (list sym-ann 'picon (cdr cache) part right-p) new-jobs))
 645     ;; next, the user search
 646     (when user
 647       (setq curkey (list user dom gnus-picons-user-directories))
 648       (if (null (setq cache (assoc curkey gnus-picons-url-alist)))
 649           (let ((users (list user "unknown"))
 650                 dirs usr domains-tmp dir picon)
 651             (while (and users (null picon))
 652               (setq dirs gnus-picons-user-directories
 653                     usr (pop users))
 654               (while (and dirs (null picon))
 655                 (setq domains-tmp addrs
 656                       dir (pop dirs))
 657                 (while (and domains-tmp
 658                             (null (setq picon (assoc (list usr domains-tmp dir)
 659                                                      fnames))))
 660                   (pop domains-tmp))
 661                 (unless picon
 662                   (setq picon (assoc (list usr '("MISC") dir) fnames)))))
 663             (push (setq cache (cons curkey (cdr picon)))
 664                   gnus-picons-url-alist)))
 665       (if (and gnus-picons-display-as-address new-jobs)
 666           (push (list sym-ann "@" right-p) new-jobs))
 667       (push (list sym-ann 'picon (cdr cache) user right-p) new-jobs))
 668     (setq gnus-picons-jobs-alist (nconc (nreverse new-jobs)
 669                                         gnus-picons-jobs-alist))
 670     (gnus-picons-next-job-internal)))
 671
 672 (defun gnus-picons-network-search-callback (user addrs dbs sym-ann right-p)
 673   (gnus-picons-network-search-internal user addrs dbs sym-ann right-p
 674                                        (prog1 (gnus-picons-parse-filenames)
 675                                          (kill-buffer (current-buffer)))))
 676
 677 (defun gnus-picons-network-search (user addrs dbs sym-ann right-p)
 678   (let* ((host (mapconcat 'identity addrs "."))
 679          (key (list (or user "unknown") host (if user
 680                                                   gnus-picons-user-directories
 681                                                 dbs)))
 682          (cache (assoc key gnus-picons-url-alist)))
 683     (if (null cache)
 684         (gnus-picons-url-retrieve
 685          (concat gnus-picons-piconsearch-url
 686                  "?user=" (w3-form-encode-xwfu (or user "unknown"))
 687                  "&host=" (w3-form-encode-xwfu host)
 688                  "&db=" (mapconcat 'w3-form-encode-xwfu
 689                                    (if user
 690                                        (append dbs
 691                                                gnus-picons-user-directories)
 692                                      dbs)
 693                                    "+"))
 694          'gnus-picons-network-search-callback
 695          (list user addrs dbs sym-ann right-p))
 696       (gnus-picons-network-search-internal user addrs dbs sym-ann right-p))))
 697
 698 ;;; Main jobs dispatcher function
 699 ;; Given that XEmacs is not really multi threaded, this locking should
 700 ;; be sufficient
 701
 702 (defun gnus-picons-next-job-internal ()
 703   (if gnus-picons-jobs-alist
 704       (let* ((job (pop gnus-picons-jobs-alist))
 705              (sym-ann (pop job))
 706              (tag (pop job)))
 707         (if tag
 708             (cond ((stringp tag);; (SYM-ANN "..." RIGHT-P)
 709                    (gnus-picons-network-display-internal sym-ann nil tag
 710                                                          (pop job)))
 711                   ((eq 'search tag);; (SYM-ANN 'search USER ADDRS DBS RIGHT-P)
 712                    (gnus-picons-network-search
 713                     (pop job) (pop job) (pop job) sym-ann (pop job)))
 714                   ((eq 'picon tag);; (SYM-ANN 'picon URL PART RIGHT-P)
 715                    (gnus-picons-network-display
 716                     (pop job) (pop job) sym-ann (pop job)))
 717                   (t (error "Unknown picon job tag %s" tag)))))
 718     (setq gnus-picons-job-already-running nil)))
 719
 720 (defun gnus-picons-next-job ()
 721   "Start processing the job queue."
 722   (unless gnus-picons-job-already-running
 723     (setq gnus-picons-job-already-running t)
 724     (gnus-picons-next-job-internal)))
 725
 726 (provide 'gnus-picon)
 727
 728 ;;; gnus-picon.el ends here