cgit.sxemacs.org Git - gnus/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 (require 'gnus-win)
  45
  46 ;;; User variables:
  47
  48 (defgroup picon nil
  49   "Show pictures of people, domains, and newsgroups.
  50 For this to work, you must switch on the `gnus-treat-display-picon'
  51 variable."
  52   :group 'gnus-visual)
  53
  54 (defcustom gnus-picon-databases '("/usr/lib/picon" "/usr/local/faces")
  55   "*Defines the location of the faces database.
  56 For information on obtaining this database of pretty pictures, please
  57 see http://www.cs.indiana.edu/picons/ftp/index.html"
  58   :type 'directory
  59   :group 'picon)
  60
  61 (defcustom gnus-picon-news-directories '("news")
  62   "*List of directories to search for newsgroups faces."
  63   :type '(repeat string)
  64   :group 'picon)
  65
  66 (defcustom gnus-picon-user-directories '("users" "usenix" "local" "misc")
  67   "*List of directories to search for user faces."
  68   :type '(repeat string)
  69   :group 'picon)
  70
  71 (defcustom gnus-picon-domain-directories '("domains")
  72   "*List of directories to search for domain faces.
  73 Some people may want to add \"unknown\" to this list."
  74   :type '(repeat string)
  75   :group 'picon)
  76
  77 (defcustom gnus-picon-file-types
  78   (let ((types (list "xbm")))
  79     (when (gnus-image-type-available-p 'gif)
  80       (push "gif" types))
  81     (when (gnus-image-type-available-p 'xpm)
  82       (push "xpm" types))
  83     types)
  84   "*List of suffixes on picon file names to try."
  85   :type '(repeat string)
  86   :group 'picon)
  87
  88 (defface gnus-picon-xbm-face '((t (:foreground "black" :background "white")))
  89   "Face to show xbm picon in."
  90   :group 'picon)
  91
  92 (defface gnus-picon-face '((t (:foreground "black" :background "white")))
  93   "Face to show picon in."
  94   :group 'picon)
  95
  96 ;;; Internal variables:
  97
  98 (defvar gnus-picon-setup-p nil)
  99 (defvar gnus-picon-glyph-alist nil
 100   "Picon glyphs cache.
 101 List of pairs (KEY . GLYPH) where KEY is either a filename or an URL.")
 102
 103 ;;; Functions:
 104
 105 (defun gnus-picon-find-face (address directories &optional exact)
 106   (let* ((databases gnus-picon-databases)
 107          (address (split-string address "[.@]"))
 108          (user (pop address))
 109          database directory found instance base)
 110     (while (and (not found)
 111                 (setq database (pop databases)))
 112       (while (and (not found)
 113                   (setq directory (pop directories)))
 114         (setq base (expand-file-name directory database))
 115         (while (and (not found)
 116                     address)
 117           (setq found (gnus-picon-find-image
 118                        (concat base "/" (mapconcat 'identity
 119                                                    (reverse address)
 120                                                    "/")
 121                                "/" user "/")))
 122           (if exact
 123               (setq address nil)
 124             (pop address)))))
 125     found))
 126
 127 (defun gnus-picon-find-image (directory)
 128   (let ((types gnus-picon-file-types)
 129         found type file)
 130     (while (and (not found)
 131                 (setq type (pop types)))
 132       (setq found (file-exists-p (setq file (concat directory "face." type)))))
 133     (if found
 134         file
 135       nil)))
 136
 137 (defun gnus-picon-insert-glyph (glyph)
 138   "Insert GLYPH into the buffer.
 139 GLYPH can be either a glyph or a string."
 140   (if (stringp glyph)
 141       (insert glyph)
 142     (gnus-put-image glyph)))
 143
 144 (defun gnus-picon-create-glyph (file)
 145   (gnus-create-image file))
 146
 147 ;;; Functions that does picon transformations:
 148
 149 (defun gnus-picon-transform-address (header)
 150   (interactive)
 151   (gnus-with-article-headers
 152     (let ((addresses
 153            (mail-header-parse-addresses (mail-fetch-field header)))
 154           (first t)
 155           spec file)
 156       (dolist (address addresses)
 157         (setq address (car address))
 158         (setq spec (split-string address "[.@]"))
 159         (when (setq file (gnus-picon-find-face
 160                           address gnus-picon-user-directories))
 161           (setcar spec (gnus-picon-create-glyph file)))
 162         (dotimes (i (1- (length spec)))
 163           (when (setq file (gnus-picon-find-face
 164                             (concat "unknown@"
 165                                     (mapconcat
 166                                      'identity (nthcdr (1+ i) spec) "."))
 167                             gnus-picon-domain-directories t))
 168             (setcar (nthcdr (1+ i) spec) (gnus-picon-create-glyph file))))
 169
 170         (gnus-article-goto-header header)
 171         (mail-header-narrow-to-field)
 172         (when (search-forward address nil t)
 173           (delete-region (match-beginning 0) (match-end 0))
 174           (while spec
 175             (gnus-picon-insert-glyph (pop spec))
 176             (when spec
 177               (if (not first)
 178                   (insert ".")
 179                 (insert "@")
 180                 (setq first nil)))))))))
 181
 182 (defun gnus-picon-transform-newsgroups (header)
 183   (interactive)
 184   (gnus-with-article-headers
 185     (let ((groups
 186            (sort
 187             (message-tokenize-header (mail-fetch-field header))
 188             (lambda (g1 g2) (> (length g1) (length g2)))))
 189           spec file)
 190       (dolist (group groups)
 191         (setq spec (nreverse (split-string group "[.]")))
 192         (dotimes (i (length spec))
 193           (when (setq file (gnus-picon-find-face
 194                             (concat "unknown@"
 195                                     (mapconcat
 196                                      'identity (nthcdr i spec) "."))
 197                             gnus-picon-news-directories t))
 198             (setcar (nthcdr i spec) (gnus-picon-create-glyph file))))
 199
 200         (gnus-article-goto-header header)
 201         (mail-header-narrow-to-field)
 202         (when (search-forward group nil t)
 203           (delete-region (match-beginning 0) (match-end 0))
 204           (setq spec (nreverse spec))
 205           (while spec
 206             (gnus-picon-insert-glyph (pop spec))
 207             (when spec
 208               (insert "."))))))))
 209
 210 ;;; Commands:
 211
 212 (defun gnus-treat-from-picon ()
 213   (interactive)
 214   (gnus-picon-transform-address "from"))
 215
 216 (defun gnus-treat-mail-picon ()
 217   (interactive)
 218   (gnus-picon-transform-address "cc")
 219   (gnus-picon-transform-address "to"))
 220
 221 (defun gnus-treat-newsgroups-picon ()
 222   (interactive)
 223   (gnus-picon-transform-newsgroups "newsgroups")
 224   (gnus-picon-transform-newsgroups "followup-to"))
 225
 226 (provide 'gnus-picon)
 227
 228 ;;; gnus-picon.el ends here