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

   1 ;;; gnus-picon.el --- displaying pretty icons in Gnus
   2 ;; Copyright (C) 1996 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 ;; Usage:
  27 ;;     - You must have XEmacs (19.12 or above I think) to use this.
  28 ;;     - Read the variable descriptions below.
  29 ;;
  30 ;;     - chose a setup:
  31 ;;
  32 ;;       1) display the icons in its own buffer:
  33 ;;
  34 ;;          (add-hook 'gnus-article-display-hook 'gnus-article-display-picons t)
  35 ;;          (add-hook 'gnus-summary-prepare-hook 'gnus-group-display-picons t)
  36 ;;          (setq gnus-picons-display-where 'picons)
  37 ;;
  38 ;;          Then add the picons buffer to your display configuration:
  39 ;;          The picons buffer needs to be at least 48 pixels high,
  40 ;;          which for me is 5 lines:
  41 ;;
  42 ;;          (gnus-add-configuration
  43 ;;           '(article (vertical 1.0
  44 ;;                             (group 6)
  45 ;;                             (picons 5)
  46 ;;                             (summary .25 point)
  47 ;;                             (article 1.0))))
  48 ;;
  49 ;;          (gnus-add-configuration
  50 ;;           '(summary (vertical 1.0 (group 6)
  51 ;;                      (picons 5)
  52 ;;                      (summary 1.0 point))))
  53 ;;
  54 ;;       2) display the icons in the summary buffer
  55 ;;
  56 ;;          (add-hook 'gnus-article-display-hook 'gnus-article-display-picons t)
  57 ;;          (add-hook 'gnus-summary-prepare-hook 'gnus-group-display-picons t)
  58 ;;          (setq gnus-picons-display-where 'summary)
  59 ;;
  60 ;;       3) display the icons in the article buffer
  61 ;;
  62 ;;          (add-hook 'gnus-article-display-hook 'gnus-article-display-picons t)
  63 ;;          (add-hook 'gnus-article-prepare-hook 'gnus-group-display-picons t)
  64 ;;          (setq gnus-picons-display-where 'article)
  65 ;;
  66 ;;
  67 ;; Warnings:
  68 ;;     - I'm not even close to being a lisp expert.
  69 ;;     - The 't' (append) flag MUST be in the add-hook line
  70 ;;
  71 ;; TODO:
  72 ;;     - Remove the TODO section in the headers.
  73 ;;
  74
  75 ;;; Code:
  76
  77 (require 'gnus-load)
  78 (require 'xpm)
  79 (require 'annotations)
  80
  81 (defvar gnus-picons-buffer "*Icon Buffer*"
  82   "Buffer name to display the icons in if gnus-picons-display-where is 'picons.")
  83
  84 (defvar gnus-picons-display-where 'picons
  85   "Where to display the group and article icons.")
  86
  87 (defvar gnus-picons-database "/usr/local/faces"
  88   "Defines the location of the faces database.
  89 For information on obtaining this database of pretty pictures, please
  90 see http://www.cs.indiana.edu/picons/ftp/index.html" )
  91
  92 (defvar gnus-picons-news-directory "news"
  93   "Sub-directory of the faces database containing the icons for newsgroups."
  94 )
  95
  96 (defvar gnus-picons-user-directories '("local" "users" "usenix" "misc/MISC")
  97   "List of directories to search for user faces."
  98 )
  99
 100 (defvar gnus-picons-domain-directories '("domains")
 101   "List of directories to search for domain faces.
 102 Some people may want to add \"unknown\" to this list."
 103 )
 104
 105 (defvar gnus-picons-x-face-file-name
 106   (format "/tmp/picon-xface.%s.xbm" (user-login-name))
 107   "The name of the file in which to store the converted X-face header.")
 108
 109 (defvar gnus-picons-convert-x-face (format "{ echo '/* Width=48, Height=48 */'; uncompface; } | icontopbm | pbmtoxbm > %s" gnus-picons-x-face-file-name)
 110   "Command to convert the x-face header into a xbm file."
 111 )
 112
 113 (defvar gnus-picons-file-suffixes
 114   (when (featurep 'x)
 115     (let ((types (list "xbm")))
 116       (when (featurep 'gif)
 117         (push "gif" types))
 118       (when (featurep 'xpm)
 119         (push "xpm" types))
 120       types))
 121   "List of suffixes on picon file names to try.")
 122
 123 (defvar gnus-picons-display-article-move-p t
 124   "*Whether to move point to first empty line when displaying picons.
 125 This has only an effect if `gnus-picons-display-where' hs value article.")
 126
 127 ;;; Internal variables.
 128
 129 (defvar gnus-group-annotations nil)
 130 (defvar gnus-article-annotations nil)
 131 (defvar gnus-x-face-annotations nil)
 132
 133 (defun gnus-picons-remove (plist)
 134   (let ((listitem (car plist)))
 135     (while (setq listitem (car plist))
 136       (if (annotationp listitem)
 137           (delete-annotation listitem))
 138       (setq plist (cdr plist))))
 139   )
 140
 141 (defun gnus-picons-remove-all ()
 142   "Removes all picons from the Gnus display(s)."
 143   (interactive)
 144   (gnus-picons-remove gnus-article-annotations)
 145   (gnus-picons-remove gnus-group-annotations)
 146   (gnus-picons-remove gnus-x-face-annotations)
 147   (setq gnus-article-annotations nil
 148         gnus-group-annotations nil
 149         gnus-x-face-annotations nil)
 150   (if (bufferp gnus-picons-buffer)
 151       (kill-buffer gnus-picons-buffer))
 152   )
 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-article-display-x-face ()
 165   "Display the x-face header bitmap in the 'gnus-picons-display-where buffer."
 166   ;; delete any old ones.
 167   (gnus-picons-remove gnus-x-face-annotations)
 168   (setq gnus-x-face-annotations nil)
 169   ;; display the new one.
 170   (let ((gnus-article-x-face-command 'gnus-picons-display-x-face))
 171     (gnus-article-display-x-face)))
 172
 173 (defun gnus-picons-display-x-face (beg end)
 174   "Function to display the x-face header in the picons window.
 175 To use:  (setq gnus-article-x-face-command 'gnus-picons-display-x-face)"
 176   (interactive)
 177   ;; convert the x-face header to a .xbm file
 178   (let ((process-connection-type nil)
 179         (process nil))
 180     (process-kill-without-query
 181      (setq process (start-process
 182                     "gnus-x-face" nil shell-file-name shell-command-switch
 183                     gnus-picons-convert-x-face)))
 184     (process-send-region "gnus-x-face" beg end)
 185     (process-send-eof "gnus-x-face")
 186     ;; wait for it.
 187     (while (not (equal (process-status process) 'exit))
 188       (sleep-for .1)))
 189   ;; display it
 190   (save-excursion
 191     (set-buffer (get-buffer-create (gnus-get-buffer-name
 192                                     gnus-picons-display-where)))
 193     (gnus-add-current-to-buffer-list)
 194     (goto-char (point-min))
 195     (let (buffer-read-only)
 196       (unless (eolp)
 197         (push (make-annotation "\n" (point) 'text)
 198               gnus-x-face-annotations))
 199       ;; append the annotation to gnus-article-annotations for deletion.
 200       (setq gnus-x-face-annotations
 201             (append
 202              (gnus-picons-try-to-find-face gnus-picons-x-face-file-name t)
 203              gnus-x-face-annotations)))
 204     ;; delete the tmp file
 205     (delete-file gnus-picons-x-face-file-name)))
 206
 207 (defun gnus-article-display-picons ()
 208   "Display faces for an author and his/her domain in gnus-picons-display-where."
 209   (interactive)
 210   (let (from at-idx databases)
 211     (when (and (featurep 'xpm)
 212                (or (not (fboundp 'device-type)) (equal (device-type) 'x))
 213                (setq from (mail-fetch-field "from"))
 214                (setq from (downcase (or (cadr (mail-extract-address-components
 215                                                from))
 216                                         "")))
 217                (or (setq at-idx (string-match "@" from))
 218                    (setq at-idx (length from))))
 219       (save-excursion
 220         (let ((username (substring from 0 at-idx))
 221               (addrs (if (eq at-idx (length from))
 222                          (if gnus-local-domain
 223                              (nreverse (message-tokenize-header
 224                                         gnus-local-domain "."))
 225                            '(""))
 226                        (nreverse (message-tokenize-header
 227                                   (substring from (1+ at-idx)) ".")))))
 228           (set-buffer (get-buffer-create
 229                        (gnus-get-buffer-name gnus-picons-display-where)))
 230           (gnus-add-current-to-buffer-list)
 231           (goto-char (point-min))
 232           (if (and (eq gnus-picons-display-where 'article)
 233                    gnus-picons-display-article-move-p)
 234               (when (search-forward "\n\n" nil t)
 235                 (forward-line -1))
 236             (unless (eolp)
 237               (push (make-annotation "\n" (point) 'text)
 238                     gnus-article-annotations)))
 239
 240           (gnus-picons-remove gnus-article-annotations)
 241           (setq gnus-article-annotations nil)
 242
 243           (setq databases (append gnus-picons-user-directories
 244                                   gnus-picons-domain-directories))
 245           (while databases
 246             (setq gnus-article-annotations
 247                   (nconc (gnus-picons-insert-face-if-exists
 248                           (car databases)
 249                           addrs
 250                           "unknown")
 251                          (gnus-picons-insert-face-if-exists
 252                           (car databases)
 253                           addrs
 254                           (downcase username) t)
 255                          gnus-article-annotations))
 256             (setq databases (cdr databases)))
 257           (add-hook 'gnus-summary-exit-hook 'gnus-picons-remove-all))))))
 258
 259 (defun gnus-group-display-picons ()
 260   "Display icons for the group in the gnus-picons-display-where buffer."
 261   (interactive)
 262   (when (and (featurep 'xpm)
 263              (or (not (fboundp 'device-type)) (equal (device-type) 'x)))
 264     (save-excursion
 265       (set-buffer (get-buffer-create
 266                    (gnus-get-buffer-name gnus-picons-display-where)))
 267       (gnus-add-current-to-buffer-list)
 268       (goto-char (point-min))
 269       (if (and (eq gnus-picons-display-where 'article)
 270                gnus-picons-display-article-move-p)
 271           (if (search-forward "\n\n" nil t)
 272               (forward-line -1))
 273         (unless (eolp)
 274           (push (make-annotation "\n" (point) 'text)
 275                 gnus-group-annotations)))
 276       (cond
 277        ((listp gnus-group-annotations)
 278         (mapc #'(lambda (ext) (if (extent-live-p ext) (delete-annotation ext)))
 279               gnus-group-annotations)
 280         (setq gnus-group-annotations nil))
 281        ((annotationp gnus-group-annotations)
 282         (delete-annotation gnus-group-annotations)
 283         (setq gnus-group-annotations nil)))
 284       (gnus-picons-remove gnus-group-annotations)
 285       (setq gnus-group-annotations
 286             (gnus-picons-insert-face-if-exists
 287              gnus-picons-news-directory
 288              (message-tokenize-header gnus-newsgroup-name ".")
 289              "unknown"))
 290       (add-hook 'gnus-summary-exit-hook 'gnus-picons-remove-all))))
 291
 292 (defsubst gnus-picons-try-suffixes (file)
 293   (let ((suffixes gnus-picons-file-suffixes)
 294         f)
 295     (while (and suffixes
 296                 (not (file-exists-p (setq f (concat file (pop suffixes))))))
 297       (setq f nil))
 298     f))
 299
 300 (defun gnus-picons-insert-face-if-exists (database addrs filename &optional
 301                                                    nobar-p)
 302   "Inserts a face at point if I can find one"
 303   ;; '(gnus-picons-insert-face-if-exists
 304   ;     "Database" '("edu" "indiana" "cs") "Name")
 305   ;; looks for:
 306   ;;  1. edu/indiana/cs/Name
 307   ;;  2. edu/indiana/Name
 308   ;;  3. edu/Name
 309   ;; '(gnus-picons-insert-face-if-exists
 310   ;;     "Database/MISC" '("edu" "indiana" "cs") "Name")
 311   ;; looks for:
 312   ;;  1. MISC/Name
 313   ;; The special treatment of MISC doesn't conform with the conventions for
 314   ;; picon databases, but otherwise we would always see the MISC/unknown face.
 315   (let ((bar (and (not nobar-p)
 316                   (annotations-in-region
 317                    (point) (min (point-max) (1+ (point)))
 318                    (current-buffer))))
 319         (path (concat (file-name-as-directory gnus-picons-database)
 320                       database "/"))
 321         picons found bar-ann)
 322     (if (string-match "/MISC" database)
 323         (setq addrs '("")))
 324     (while (and addrs
 325                 (file-accessible-directory-p path))
 326       (setq path (concat path (pop addrs) "/"))
 327       (when (setq found
 328                   (gnus-picons-try-suffixes
 329                    (concat path filename "/face.")))
 330         (when bar
 331           (setq bar-ann (gnus-picons-try-to-find-face
 332                          (concat gnus-xmas-glyph-directory "bar.xbm")))
 333           (when bar-ann
 334             (setq picons (nconc picons bar-ann))
 335             (setq bar nil)))
 336         (setq picons (nconc (gnus-picons-try-to-find-face found)
 337                             picons))))
 338     (nreverse picons)))
 339
 340 (defvar gnus-picons-glyph-alist nil)
 341
 342 (defun gnus-picons-try-to-find-face (path &optional xface-p)
 343   "If PATH exists, display it as a bitmap.  Returns t if succedded."
 344   (let ((glyph (and (not xface-p)
 345                     (cdr (assoc path gnus-picons-glyph-alist)))))
 346     (when (or glyph (file-exists-p path))
 347       (unless glyph
 348         (setq glyph (make-glyph path))
 349         (unless xface-p
 350           (push (cons path glyph) gnus-picons-glyph-alist))
 351         (set-glyph-face glyph 'default))
 352       (nconc
 353        (list (make-annotation glyph (point) 'text))
 354        (when (eq major-mode 'gnus-article-mode)
 355          (list (make-annotation " " (point) 'text)))))))
 356
 357 (defun gnus-picons-reverse-domain-path (str)
 358   "a/b/c/d -> d/c/b/a"
 359   (mapconcat 'downcase (nreverse (message-tokenize-header str "/")) "/"))
 360
 361 (gnus-add-shutdown 'gnus-picons-close 'gnus)
 362
 363 (defun gnus-picons-close ()
 364   "Shut down the picons."
 365   (setq gnus-picons-glyph-alist nil))
 366
 367 (provide 'gnus-picon)
 368
 369 ;;; gnus-picon.el ends here