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 ;;; Code:
  27
  28 (require 'gnus)
  29 (require 'xpm)
  30 (require 'annotations)
  31 (require 'custom)
  32 (require 'gnus-art)
  33 (require 'gnus-win)
  34
  35 (defgroup picons nil
  36   "Show pictures of people, domains, and newsgroups (XEmacs).
  37 For this to work, you must add gnus-group-display-picons to the
  38 gnus-summary-display-hook or to the gnus-article-display-hook
  39 depending on what gnus-picons-display-where is set to.  You must
  40 also add gnus-article-display-picons to gnus-article-display-hook."
  41   :group 'gnus-visual)
  42
  43 (defcustom gnus-picons-buffer "*Icon Buffer*"
  44   "Buffer name to display the icons in if gnus-picons-display-where is 'picons."
  45   :type 'string
  46   :group 'picons)
  47
  48 (defcustom gnus-picons-display-where 'picons
  49   "Where to display the group and article icons.
  50 Legal values are `article' and `picons'."
  51   :type '(choice symbol string)
  52   :group 'picons)
  53
  54 (defcustom gnus-picons-database "/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 'picons)
  60
  61 (defcustom gnus-picons-news-directory "news"
  62   "Sub-directory of the faces database containing the icons for newsgroups."
  63   :type 'string
  64   :group 'picons)
  65
  66 (defcustom gnus-picons-user-directories '("local" "users" "usenix" "misc")
  67   "List of directories to search for user faces."
  68   :type '(repeat string)
  69   :group 'picons)
  70
  71 (defcustom gnus-picons-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 'picons)
  76
  77 (defcustom gnus-picons-refresh-before-display nil
  78   "If non-nil, display the article buffer before computing the picons."
  79   :type 'boolean
  80   :group 'picons)
  81
  82 (defcustom gnus-picons-x-face-file-name
  83   (format "/tmp/picon-xface.%s.xbm" (user-login-name))
  84   "The name of the file in which to store the converted X-face header."
  85   :type 'string
  86   :group 'picons)
  87
  88 (defcustom gnus-picons-convert-x-face (format "{ echo '/* Width=48, Height=48 */'; uncompface; } | icontopbm | pbmtoxbm > %s" gnus-picons-x-face-file-name)
  89   "Command to convert the x-face header into a xbm file."
  90   :type 'string
  91   :group 'picons)
  92
  93 (defcustom gnus-picons-display-as-address t
  94   "*If t display textual email addresses along with pictures."
  95   :type 'boolean
  96   :group 'picons)
  97
  98 (defcustom gnus-picons-file-suffixes
  99   (when (featurep 'x)
 100     (let ((types (list "xbm")))
 101       (when (featurep 'gif)
 102         (push "gif" types))
 103       (when (featurep 'xpm)
 104         (push "xpm" types))
 105       types))
 106   "List of suffixes on picon file names to try."
 107   :type '(repeat string)
 108   :group 'picons)
 109
 110 (defcustom gnus-picons-display-article-move-p t
 111   "*Whether to move point to first empty line when displaying picons.
 112 This has only an effect if `gnus-picons-display-where' has value `article'."
 113   :type 'boolean
 114   :group 'picons)
 115
 116 (defvar gnus-picons-map (make-sparse-keymap "gnus-picons-keys")
 117  "keymap to hide/show picon glyphs")
 118
 119 (define-key gnus-picons-map [(button2)] 'gnus-picons-toggle-extent)
 120
 121 ;;; Internal variables.
 122
 123 (defvar gnus-group-annotations nil
 124   "List of annotations added/removed when selecting/exiting a group")
 125 (defvar gnus-article-annotations nil
 126   "List of annotations added/removed when selecting an article")
 127 (defvar gnus-x-face-annotations nil
 128   "List of annotations added/removed when selecting an article with an X-Face.")
 129
 130 (defun gnus-picons-remove (symbol)
 131   "Remove all annotations/processes in variable named SYMBOL.
 132 This function is careful to set it to nil before removing anything so that
 133 asynchronous process don't get crazy."
 134   (let ((listitems (symbol-value symbol)))
 135     (set symbol nil)
 136     (while listitems
 137       (let ((item (pop listitems)))
 138         (cond ((annotationp item)
 139                (delete-annotation item))
 140               ((processp item)
 141                ;; kill the process, ignore any output.
 142                (set-process-sentinel item (function (lambda (p e))))
 143                (delete-process item)))))))
 144
 145 (defun gnus-picons-remove-all ()
 146   "Removes all picons from the Gnus display(s)."
 147   (interactive)
 148   (gnus-picons-remove 'gnus-article-annotations)
 149   (gnus-picons-remove 'gnus-group-annotations)
 150   (gnus-picons-remove 'gnus-x-face-annotations)
 151   (when (bufferp gnus-picons-buffer)
 152     (kill-buffer gnus-picons-buffer)))
 153
 154 (defun gnus-get-buffer-name (variable)
 155   "Returns the buffer name associated with the contents of a variable."
 156   (cond ((symbolp variable)
 157          (let ((newvar (cdr (assq variable gnus-window-to-buffer))))
 158            (cond ((symbolp newvar)
 159                   (symbol-value newvar))
 160                  ((stringp newvar) newvar))))
 161         ((stringp variable)
 162          variable)))
 163
 164 (defun gnus-picons-prepare-for-annotations (annotations)
 165   "Prepare picons buffer for puting annotations memorized in ANNOTATIONS.
 166 ANNOTATIONS should be a symbol naming a variable wich contains a list of
 167 annotations.  Sets buffer to `gnus-picons-display-where'."
 168   ;; let drawing catch up
 169   (when gnus-picons-refresh-before-display
 170     (sit-for 0))
 171   (set-buffer (get-buffer-create
 172                (gnus-get-buffer-name gnus-picons-display-where)))
 173   (gnus-add-current-to-buffer-list)
 174   (goto-char (point-min))
 175   (if (and (eq gnus-picons-display-where 'article)
 176            gnus-picons-display-article-move-p)
 177       (when (search-forward "\n\n" nil t)
 178         (forward-line -1)))
 179   (gnus-picons-remove annotations))
 180
 181 (defun gnus-picons-article-display-x-face ()
 182   "Display the x-face header bitmap in the 'gnus-picons-display-where buffer."
 183   ;; delete any old ones.
 184   ;; This is needed here because gnus-picons-display-x-face will not
 185   ;; be called if there is no X-Face header
 186   (gnus-picons-remove 'gnus-x-face-annotations)
 187   ;; display the new one.
 188   (let ((gnus-article-x-face-command 'gnus-picons-display-x-face))
 189     (gnus-article-display-x-face)))
 190
 191 (defun gnus-picons-x-face-sentinel (process event)
 192   ;; don't call gnus-picons-prepare-for-annotations, it would reset
 193   ;; gnus-x-face-annotations.
 194   (set-buffer (get-buffer-create
 195                (gnus-get-buffer-name gnus-picons-display-where)))
 196   (gnus-add-current-to-buffer-list)
 197   (goto-char (point-min))
 198   (if (and (eq gnus-picons-display-where 'article)
 199            gnus-picons-display-article-move-p)
 200       (when (search-forward "\n\n" nil t)
 201         (forward-line -1)))
 202   ;; If the process is still in the list, insert this icon
 203   (let ((myself (member process gnus-x-face-annotations)))
 204     (when myself
 205       (setcar myself
 206               (make-annotation gnus-picons-x-face-file-name nil 'text))
 207       (delete-file gnus-picons-x-face-file-name))))
 208
 209 (defun gnus-picons-display-x-face (beg end)
 210   "Function to display the x-face header in the picons window.
 211 To use:  (setq gnus-article-x-face-command 'gnus-picons-display-x-face)"
 212   (interactive)
 213   (if (featurep 'xface)
 214       ;; Use builtin support
 215       (let ((buf (current-buffer)))
 216         (save-excursion
 217           (gnus-picons-prepare-for-annotations 'gnus-x-face-annotations)
 218           (setq gnus-x-face-annotations
 219                 (cons (make-annotation (concat "X-Face: "
 220                                                (buffer-substring beg end buf))
 221                                        nil 'text)
 222                       gnus-x-face-annotations))))
 223     ;; convert the x-face header to a .xbm file
 224     (let* ((process-connection-type nil)
 225            (process (start-process "gnus-x-face" nil
 226                                    shell-file-name shell-command-switch
 227                                    gnus-picons-convert-x-face)))
 228       (process-kill-without-query process)
 229       (setq gnus-x-face-annotations (list process))
 230       (set-process-sentinel process 'gnus-picons-x-face-sentinel)
 231       (process-send-region process beg end)
 232       (process-send-eof process))))
 233
 234 (defun gnus-article-display-picons ()
 235   "Display faces for an author and his/her domain in gnus-picons-display-where."
 236   (interactive)
 237   (let (from at-idx)
 238     (when (and (featurep 'xpm)
 239                (or (not (fboundp 'device-type)) (equal (device-type) 'x))
 240                (setq from (mail-fetch-field "from"))
 241                (setq from (downcase
 242                            (or (cadr (mail-extract-address-components from))
 243                                "")))
 244                (or (setq at-idx (string-match "@" from))
 245                    (setq at-idx (length from))))
 246       (save-excursion
 247         (let ((username (substring from 0 at-idx))
 248               (addrs (if (eq at-idx (length from))
 249                          (if gnus-local-domain
 250                              (message-tokenize-header gnus-local-domain ".")
 251                            nil)
 252                        (message-tokenize-header (substring from (1+ at-idx))
 253                                                 "."))))
 254           (gnus-picons-prepare-for-annotations 'gnus-article-annotations)
 255           (setq gnus-article-annotations
 256                 (nconc gnus-article-annotations
 257                        ;; look for domain paths.
 258                        (gnus-picons-display-pairs
 259                         (gnus-picons-lookup-pairs addrs
 260                                                gnus-picons-domain-directories)
 261                         (not (or gnus-picons-display-as-address
 262                                  gnus-article-annotations))
 263                         nil "." t)
 264                        ;; add an '@' if displaying as address
 265                        (if  (and gnus-picons-display-as-address addrs)
 266                          (list (make-annotation "@" nil 'text nil nil nil t)))
 267                        ;; then do user directories,
 268                        (gnus-picons-display-picon-or-name
 269                         (gnus-picons-lookup-user (downcase username) addrs)
 270                         username nil t)))
 271
 272           (add-hook 'gnus-summary-exit-hook 'gnus-picons-remove-all))))))
 273
 274 (defun gnus-group-display-picons ()
 275   "Display icons for the group in the gnus-picons-display-where buffer."
 276   (interactive)
 277   (when (and (featurep 'xpm)
 278              (or (not (fboundp 'device-type)) (equal (device-type) 'x)))
 279     (save-excursion
 280       (gnus-picons-prepare-for-annotations 'gnus-group-annotations)
 281       (setq gnus-group-annotations
 282             (gnus-picons-display-pairs
 283              (gnus-picons-lookup-pairs (reverse (message-tokenize-header
 284                                               gnus-newsgroup-name "."))
 285                                     gnus-picons-news-directory)
 286              t nil "."))
 287       (add-hook 'gnus-summary-exit-hook 'gnus-picons-remove-all))))
 288
 289 (defun gnus-picons-make-path (dir subdirs)
 290   "Make a directory name from a base DIR and a list of SUBDIRS.
 291 Returns a directory name build by concatenating DIR and all elements of
 292 SUBDIRS with \"/\" between elements."
 293   (while subdirs
 294     (setq dir (file-name-as-directory (concat dir (pop subdirs)))))
 295   dir)
 296
 297 (defsubst gnus-picons-try-suffixes (file)
 298   (let ((suffixes gnus-picons-file-suffixes)
 299         f)
 300     (while (and suffixes
 301                 (not (file-exists-p (setq f (concat file (pop suffixes))))))
 302       (setq f nil))
 303     f))
 304
 305 (defun gnus-picons-lookup (addrs dirs)
 306   "Lookup the picon for ADDRS in databases DIRS.
 307 Returns the picon filename or NIL if none found."
 308   (let (result)
 309     (while (and dirs (null result))
 310       (setq result
 311             (gnus-picons-try-suffixes
 312              (expand-file-name "face."
 313                                (gnus-picons-make-path
 314                                 (file-name-as-directory
 315                                  (concat
 316                                   (file-name-as-directory gnus-picons-database)
 317                                   (pop dirs)))
 318                                 (reverse addrs))))))
 319     result))
 320
 321 (defun gnus-picons-lookup-user-internal (user domains)
 322   (let ((dirs gnus-picons-user-directories)
 323         picon)
 324     (while (and dirs (null picon))
 325       (let ((dir (list (pop dirs)))
 326             (domains domains))
 327         (while (and domains (null picon))
 328           (setq picon (gnus-picons-lookup (cons user domains) dir))
 329           (pop domains))
 330         ;; Also make a try MISC subdir
 331         (unless picon
 332           (setq picon (gnus-picons-lookup (list user "MISC") dir)))))
 333
 334     picon))
 335
 336 (defun gnus-picons-lookup-user (user domains)
 337   "Lookup the picon for USER at DOMAINS.
 338 USER is a string containing a name.
 339 DOMAINS is a list of strings from the fully qualified domain name."
 340   (or (gnus-picons-lookup-user-internal user domains)
 341       (gnus-picons-lookup-user-internal "unknown" domains)))
 342
 343 (defun gnus-picons-lookup-pairs (domains directories)
 344   "Lookup picons for DOMAINS and all its parents in DIRECTORIES.
 345 Returns a list of PAIRS whose CAR is the picon filename or NIL if
 346 none, and whose CDR is the corresponding element of DOMAINS."
 347   (let (picons)
 348     (while domains
 349       (push (list (gnus-picons-lookup (cons "unknown" domains)
 350                                       (if (listp directories)
 351                                           directories
 352                                         (list directories)))
 353                   (pop domains))
 354             picons))
 355     picons))
 356
 357 (defun gnus-picons-display-picon-or-name (picon name &optional xface-p right-p)
 358   (if picon
 359       (gnus-picons-try-to-find-face picon xface-p name right-p)
 360     (list (make-annotation name nil 'text nil nil nil right-p))))
 361
 362 (defun gnus-picons-display-pairs (pairs &optional bar-p xface-p dot-p right-p)
 363   "Display picons in list PAIRS."
 364   (let ((bar (and bar-p (or gnus-picons-display-as-address
 365                           (annotations-in-region (point)
 366                                                  (min (point-max) (1+ (point)))
 367                                                  (current-buffer)))))
 368         (domain-p (and gnus-picons-display-as-address dot-p))
 369         picons)
 370     (while pairs
 371       (let ((pair (pop pairs)))
 372         (setq picons (nconc (if (and domain-p picons (not right-p))
 373                                 (list (make-annotation
 374                                        dot-p nil 'text nil nil nil right-p)))
 375                             (gnus-picons-display-picon-or-name (car pair)
 376                                                                (cadr pair)
 377                                                                xface-p
 378                                                                right-p)
 379                             (if (and domain-p pairs right-p)
 380                                 (list (make-annotation
 381                                        dot-p nil 'text nil nil nil right-p)))
 382                             (when (and bar domain-p)
 383                               (setq bar nil)
 384                               (gnus-picons-try-to-find-face
 385                                (expand-file-name "bar.xbm"
 386                                                  gnus-xmas-glyph-directory)
 387                                nil nil t))
 388                             picons))))
 389     picons))
 390
 391 (defvar gnus-picons-glyph-alist nil)
 392
 393 (defun gnus-picons-try-to-find-face (path &optional xface-p part rightp)
 394   "If PATH exists, display it as a bitmap.  Returns t if succeeded."
 395   (let ((glyph (and (not xface-p)
 396                     (cdr (assoc path gnus-picons-glyph-alist)))))
 397     (when (or glyph (file-exists-p path))
 398       (unless glyph
 399         (setq glyph (make-glyph path))
 400         (unless xface-p
 401           (push (cons path glyph) gnus-picons-glyph-alist))
 402         (set-glyph-face glyph 'default))
 403       (let ((new (make-annotation glyph (point) 'text nil nil nil rightp)))
 404         (nconc
 405          (list new)
 406          (when (and (eq major-mode 'gnus-article-mode)
 407                     (not gnus-picons-display-as-address)
 408                     (not part))
 409            (list (make-annotation " " (point) 'text nil nil nil rightp)))
 410          (when (and part gnus-picons-display-as-address)
 411            (let ((txt (make-annotation part (point) 'text nil nil nil rightp)))
 412              (hide-annotation txt)
 413              (set-extent-property txt 'its-partner new)
 414              (set-extent-property txt 'keymap gnus-picons-map)
 415              (set-extent-property txt 'mouse-face gnus-article-mouse-face)
 416              (set-extent-property new 'its-partner txt)
 417              (set-extent-property new 'keymap gnus-picons-map)
 418              (list txt))))))))
 419
 420 (defun gnus-picons-toggle-extent (event)
 421   "Toggle picon glyph at given point"
 422   (interactive "e")
 423   (let* ((ant1 (event-glyph-extent event))
 424          (ant2 (extent-property ant1 'its-partner)))
 425     (when (and (annotationp ant1) (annotationp ant2))
 426       (reveal-annotation ant2)
 427       (hide-annotation ant1))))
 428
 429 (gnus-add-shutdown 'gnus-picons-close 'gnus)
 430
 431 (defun gnus-picons-close ()
 432   "Shut down the picons."
 433   (setq gnus-picons-glyph-alist nil))
 434
 435 (provide 'gnus-picon)
 436
 437 ;;; gnus-picon.el ends here