git.chise.org Git - elisp/gnus.git-/blob - lisp/gnus-picon.el

   1 ;;; gnus-picon.el --- displaying pretty icons in Gnus
   2
   3 ;; Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001
   4 ;;      Free Software Foundation, Inc.
   5
   6 ;; Author: Wes Hardaker <hardaker@ece.ucdavis.edu>
   7 ;; Keywords: news xpm annotation glyph faces
   8
   9 ;; This file is part of GNU Emacs.
  10
  11 ;; GNU Emacs is free software; you can redistribute it and/or modify
  12 ;; it under the terms of the GNU General Public License as published by
  13 ;; the Free Software Foundation; either version 2, or (at your option)
  14 ;; any later version.
  15
  16 ;; GNU Emacs is distributed in the hope that it will be useful,
  17 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  19 ;; GNU General Public License for more details.
  20
  21 ;; You should have received a copy of the GNU General Public License
  22 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  23 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  24 ;; Boston, MA 02111-1307, USA.
  25
  26 ;;; Commentary:
  27
  28 ;; There are three picon types relevant to Gnus:
  29 ;;
  30 ;; Persons: person@subdomain.dom
  31 ;;          users/dom/subdomain/person/face.gif
  32 ;;          usenix/dom/subdomain/person/face.gif
  33 ;;          misc/MISC/person/face.gif
  34 ;; Domains: subdomain.dom
  35 ;;          domain/dom/subdomain/unknown/face.gif
  36 ;; Groups:  comp.lang.lisp
  37 ;;          news/comp/lang/lisp/unknown/face.gif
  38
  39 ;;; Code:
  40
  41 (require 'gnus)
  42 (require 'custom)
  43 (require 'gnus-art)
  44
  45 ;;; User variables:
  46
  47 (defgroup picon nil
  48   "Show pictures of people, domains, and newsgroups."
  49   :group 'gnus-visual)
  50
  51 (defcustom gnus-picon-databases '("/usr/lib/picon" "/usr/local/faces")
  52   "*Defines the location of the faces database.
  53 For information on obtaining this database of pretty pictures, please
  54 see http://www.cs.indiana.edu/picons/ftp/index.html"
  55   :type 'directory
  56   :group 'picon)
  57
  58 (defcustom gnus-picon-news-directories '("news")
  59   "*List of directories to search for newsgroups faces."
  60   :type '(repeat string)
  61   :group 'picon)
  62
  63 (defcustom gnus-picon-user-directories '("users" "usenix" "local" "misc")
  64   "*List of directories to search for user faces."
  65   :type '(repeat string)
  66   :group 'picon)
  67
  68 (defcustom gnus-picon-domain-directories '("domains")
  69   "*List of directories to search for domain faces.
  70 Some people may want to add \"unknown\" to this list."
  71   :type '(repeat string)
  72   :group 'picon)
  73
  74 (defcustom gnus-picon-file-types
  75   (let ((types (list "xbm")))
  76     (when (gnus-image-type-available-p 'gif)
  77       (push "gif" types))
  78     (when (gnus-image-type-available-p 'xpm)
  79       (push "xpm" types))
  80     types)
  81   "*List of suffixes on picon file names to try."
  82   :type '(repeat string)
  83   :group 'picon)
  84
  85 (defface gnus-picon-xbm-face '((t (:foreground "black" :background "white")))
  86   "Face to show xbm picon in."
  87   :group 'picon)
  88
  89 (defface gnus-picon-face '((t (:foreground "black" :background "white")))
  90   "Face to show picon in."
  91   :group 'picon)
  92
  93 ;;; Internal variables:
  94
  95 (defvar gnus-picon-setup-p nil)
  96 (defvar gnus-picon-glyph-alist nil
  97   "Picon glyphs cache.
  98 List of pairs (KEY . GLYPH) where KEY is either a filename or an URL.")
  99
 100 ;;; Functions:
 101
 102 (defsubst gnus-picon-split-address (address)
 103   (setq address (split-string address "@"))
 104   (if (stringp (cadr address))
 105       (cons (car address) (split-string (cadr address) "\\."))
 106     (if (stringp (car address))
 107         (split-string (car address) "\\."))))
 108
 109 (defun gnus-picon-find-face (address directories &optional exact)
 110   (let* ((databases gnus-picon-databases)
 111          (address (gnus-picon-split-address address))
 112          (user (pop address))
 113          database directory found instance base)
 114     (while (and (not found)
 115                 (setq database (pop databases)))
 116       (while (and (not found)
 117                   (setq directory (pop directories)))
 118         (setq base (expand-file-name directory database))
 119         ;; Kludge to search misc/MISC for users.
 120         (when (string= directory "misc")
 121           (setq address '("MISC")))
 122         (while (and (not found)
 123                     address)
 124           (setq found (gnus-picon-find-image
 125                        (concat base "/" (mapconcat 'identity
 126                                                    (reverse address)
 127                                                    "/")
 128                                "/" user "/")))
 129           (if exact
 130               (setq address nil)
 131             (pop address)))))
 132     found))
 133
 134 (defun gnus-picon-find-image (directory)
 135   (let ((types gnus-picon-file-types)
 136         found type file)
 137     (while (and (not found)
 138                 (setq type (pop types)))
 139       (setq found (file-exists-p (setq file (concat directory "face." type)))))
 140     (if found
 141         file
 142       nil)))
 143
 144 (defun gnus-picon-insert-glyph (glyph category)
 145   "Insert GLYPH into the buffer.
 146 GLYPH can be either a glyph or a string."
 147   (if (stringp glyph)
 148       (insert glyph)
 149     (gnus-add-wash-type category)
 150     (gnus-add-image category (car glyph))
 151     (gnus-put-image (car glyph) (cdr glyph))))
 152
 153 (defun gnus-picon-create-glyph (file)
 154   (or (cdr (assoc file gnus-picon-glyph-alist))
 155       (cdar (push (cons file (gnus-create-image file))
 156                   gnus-picon-glyph-alist))))
 157
 158 ;;; Functions that does picon transformations:
 159
 160 (defun gnus-picon-transform-address (header category)
 161   (gnus-with-article-headers
 162     (let ((addresses
 163            (mail-header-parse-addresses (mail-fetch-field header)))
 164           first spec file)
 165       (dolist (address addresses)
 166         (setq address (car address)
 167               first t)
 168         (when (and (stringp address)
 169                    (setq spec (gnus-picon-split-address address)))
 170           (when (setq file (gnus-picon-find-face
 171                             address gnus-picon-user-directories))
 172             (setcar spec (cons (gnus-picon-create-glyph file)
 173                                (car spec))))
 174           (dotimes (i (1- (length spec)))
 175             (when (setq file (gnus-picon-find-face
 176                               (concat "unknown@"
 177                                       (mapconcat
 178                                        'identity (nthcdr (1+ i) spec) "."))
 179                               gnus-picon-domain-directories t))
 180               (setcar (nthcdr (1+ i) spec)
 181                       (cons (gnus-picon-create-glyph file)
 182                             (nth (1+ i) spec)))))
 183
 184           (gnus-article-goto-header header)
 185           (mail-header-narrow-to-field)
 186           (when (search-forward address nil t)
 187             (delete-region (match-beginning 0) (match-end 0))
 188             (while spec
 189               (gnus-picon-insert-glyph (pop spec) category)
 190               (when spec
 191                 (if (not first)
 192                     (insert ".")
 193                   (insert "@")
 194                   (setq first nil))))))))))
 195
 196 (defun gnus-picon-transform-newsgroups (header)
 197   (interactive)
 198   (gnus-with-article-headers
 199     (let ((groups
 200            (sort
 201             (message-tokenize-header (mail-fetch-field header))
 202             (lambda (g1 g2) (> (length g1) (length g2)))))
 203           spec file)
 204       (dolist (group groups)
 205         (setq spec (nreverse (split-string group "[.]")))
 206         (dotimes (i (length spec))
 207           (when (setq file (gnus-picon-find-face
 208                             (concat "unknown@"
 209                                     (mapconcat
 210                                      'identity (nthcdr i spec) "."))
 211                             gnus-picon-news-directories t))
 212             (setcar (nthcdr i spec)
 213                     (cons (gnus-picon-create-glyph file)
 214                           (nth i spec)))))
 215
 216         (gnus-article-goto-header header)
 217         (mail-header-narrow-to-field)
 218         (when (search-forward group nil t)
 219           (delete-region (match-beginning 0) (match-end 0))
 220           (setq spec (nreverse spec))
 221           (while spec
 222             (gnus-picon-insert-glyph (pop spec) 'newsgroups-picon)
 223             (when spec
 224               (insert "."))))))))
 225
 226 ;;; Commands:
 227
 228 ;;;###autoload
 229 (defun gnus-treat-from-picon ()
 230   "Display picons in the From header.
 231 If picons are already displayed, remove them."
 232   (interactive)
 233   (gnus-with-article-buffer
 234     (if (memq 'from-picon gnus-article-wash-types)
 235         (gnus-delete-images 'from-picon)
 236       (gnus-picon-transform-address "from" 'from-picon))))
 237
 238 ;;;###autoload
 239 (defun gnus-treat-mail-picon ()
 240   "Display picons in the Cc and To headers.
 241 If picons are already displayed, remove them."
 242   (interactive)
 243   (gnus-with-article-buffer
 244     (if (memq 'mail-picon gnus-article-wash-types)
 245         (gnus-delete-images 'mail-picon)
 246       (gnus-picon-transform-address "cc" 'mail-picon)
 247       (gnus-picon-transform-address "to" 'mail-picon))))
 248
 249 ;;;###autoload
 250 (defun gnus-treat-newsgroups-picon ()
 251   "Display picons in the Newsgroups and Followup-To headers.
 252 If picons are already displayed, remove them."
 253   (interactive)
 254   (gnus-with-article-buffer
 255     (if (memq 'newsgroups-picon gnus-article-wash-types)
 256         (gnus-delete-images 'newsgroups-picon)
 257       (gnus-picon-transform-newsgroups "newsgroups")
 258       (gnus-picon-transform-newsgroups "followup-to"))))
 259
 260 (provide 'gnus-picon)
 261
 262 ;;; gnus-picon.el ends here