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/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' hs 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 (defvar gnus-article-annotations nil)
 125 (defvar gnus-x-face-annotations nil)
 126
 127 (defun gnus-picons-remove (plist)
 128   (let ((listitem (car plist)))
 129     (while (setq listitem (car plist))
 130       (when (annotationp listitem)
 131         (delete-annotation listitem))
 132       (setq plist (cdr plist)))))
 133
 134 (defun gnus-picons-remove-all ()
 135   "Removes all picons from the Gnus display(s)."
 136   (interactive)
 137   (gnus-picons-remove gnus-article-annotations)
 138   (gnus-picons-remove gnus-group-annotations)
 139   (gnus-picons-remove gnus-x-face-annotations)
 140   (setq gnus-article-annotations nil
 141         gnus-group-annotations nil
 142         gnus-x-face-annotations nil)
 143   (when (bufferp gnus-picons-buffer)
 144     (kill-buffer gnus-picons-buffer)))
 145
 146 (defun gnus-get-buffer-name (variable)
 147   "Returns the buffer name associated with the contents of a variable."
 148   (cond ((symbolp variable)
 149          (let ((newvar (cdr (assq variable gnus-window-to-buffer))))
 150            (cond ((symbolp newvar)
 151                   (symbol-value newvar))
 152                  ((stringp newvar) newvar))))
 153         ((stringp variable)
 154          variable)))
 155
 156 (defun gnus-picons-article-display-x-face ()
 157   "Display the x-face header bitmap in the 'gnus-picons-display-where buffer."
 158   ;; delete any old ones.
 159   (gnus-picons-remove gnus-x-face-annotations)
 160   (setq gnus-x-face-annotations nil)
 161   ;; display the new one.
 162   (let ((gnus-article-x-face-command 'gnus-picons-display-x-face))
 163     (gnus-article-display-x-face)))
 164
 165 (defun gnus-picons-display-x-face (beg end)
 166   "Function to display the x-face header in the picons window.
 167 To use:  (setq gnus-article-x-face-command 'gnus-picons-display-x-face)"
 168   (interactive)
 169   ;; convert the x-face header to a .xbm file
 170   (let ((process-connection-type nil)
 171         (process nil))
 172     (process-kill-without-query
 173      (setq process (start-process
 174                     "gnus-x-face" nil shell-file-name shell-command-switch
 175                     gnus-picons-convert-x-face)))
 176     (process-send-region "gnus-x-face" beg end)
 177     (process-send-eof "gnus-x-face")
 178     ;; wait for it.
 179     (while (not (equal (process-status process) 'exit))
 180       (sleep-for .1)))
 181   ;; display it
 182   (save-excursion
 183     (set-buffer (get-buffer-create (gnus-get-buffer-name
 184                                     gnus-picons-display-where)))
 185     (gnus-add-current-to-buffer-list)
 186     (goto-char (point-min))
 187     (let (buffer-read-only)
 188       (unless (eolp)
 189         (push (make-annotation "\n" (point) 'text)
 190               gnus-x-face-annotations))
 191       ;; append the annotation to gnus-article-annotations for deletion.
 192       (setq gnus-x-face-annotations
 193             (append
 194              (gnus-picons-try-to-find-face gnus-picons-x-face-file-name t)
 195              gnus-x-face-annotations)))
 196     ;; delete the tmp file
 197     (delete-file gnus-picons-x-face-file-name)))
 198
 199 (defun gnus-article-display-picons ()
 200   "Display faces for an author and his/her domain in gnus-picons-display-where."
 201   (interactive)
 202   ;; let drawing catch up
 203   (when gnus-picons-refresh-before-display
 204     (sit-for 0))
 205   (let ((first t)
 206         from at-idx databases)
 207     (when (and (featurep 'xpm)
 208                (or (not (fboundp 'device-type)) (equal (device-type) 'x))
 209                (setq from (mail-fetch-field "from"))
 210                (setq from (downcase
 211                            (or (cadr (mail-extract-address-components from))
 212                                "")))
 213                (or (setq at-idx (string-match "@" from))
 214                    (setq at-idx (length from))))
 215       (save-excursion
 216         (let ((username (substring from 0 at-idx))
 217               (addrs (if (eq at-idx (length from))
 218                          (if gnus-local-domain
 219                              (nreverse (message-tokenize-header
 220                                         gnus-local-domain "."))
 221                            '("."))
 222                        (nreverse (message-tokenize-header
 223                                   (substring from (1+ at-idx)) ".")))))
 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             (unless (eolp)
 233               (push (make-annotation "\n" (point) 'text)
 234                     gnus-article-annotations)))
 235
 236           (gnus-picons-remove gnus-article-annotations)
 237           (setq gnus-article-annotations nil)
 238
 239           ;; look for domain paths.
 240           (setq databases gnus-picons-domain-directories)
 241           (while databases
 242             (setq gnus-article-annotations
 243                   (nconc (gnus-picons-insert-face-if-exists
 244                           (car databases)
 245                           addrs
 246                           "unknown" (or gnus-picons-display-as-address
 247                                         gnus-article-annotations) t t)
 248                          gnus-article-annotations))
 249             (setq databases (cdr databases)))
 250
 251           ;; add an '@' if displaying as address
 252           (when gnus-picons-display-as-address
 253             (setq gnus-article-annotations
 254                   (nconc gnus-article-annotations
 255                          (list
 256                           (make-annotation "@" (point) 'text nil nil nil t)))))
 257
 258           ;; then do user directories,
 259           (let (found)
 260             (setq databases gnus-picons-user-directories)
 261             (setq username (downcase username))
 262             (while databases
 263               (setq found
 264                     (nconc (gnus-picons-insert-face-if-exists
 265                             (car databases) addrs username
 266                             (or gnus-picons-display-as-address
 267                                 gnus-article-annotations) nil t)
 268                            found))
 269               (setq databases (cdr databases)))
 270             ;; add their name if no face exists
 271             (when (and gnus-picons-display-as-address (not found))
 272               (setq found
 273                     (list
 274                      (make-annotation username (point) 'text nil nil nil t))))
 275             (setq gnus-article-annotations
 276                   (nconc found gnus-article-annotations)))
 277
 278           (add-hook 'gnus-summary-exit-hook 'gnus-picons-remove-all))))))
 279
 280 (defun gnus-group-display-picons ()
 281   "Display icons for the group in the gnus-picons-display-where buffer."
 282   (interactive)
 283   ;; let display catch up so far
 284   (when gnus-picons-refresh-before-display
 285     (sit-for 0))
 286   (when (and (featurep 'xpm)
 287              (or (not (fboundp 'device-type)) (equal (device-type) 'x)))
 288     (save-excursion
 289       (set-buffer (get-buffer-create
 290                    (gnus-get-buffer-name gnus-picons-display-where)))
 291       (gnus-add-current-to-buffer-list)
 292       (goto-char (point-min))
 293       (if (and (eq gnus-picons-display-where 'article)
 294                gnus-picons-display-article-move-p)
 295           (when (search-forward "\n\n" nil t)
 296             (forward-line -1))
 297         (unless (eolp)
 298           (push (make-annotation "\n" (point) 'text)
 299                 gnus-group-annotations)))
 300       (cond
 301        ((listp gnus-group-annotations)
 302         (mapc #'(lambda (ext) (when (extent-live-p ext)
 303                                 (delete-annotation ext)))
 304               gnus-group-annotations)
 305         (setq gnus-group-annotations nil))
 306        ((annotationp gnus-group-annotations)
 307         (delete-annotation gnus-group-annotations)
 308         (setq gnus-group-annotations nil)))
 309       (gnus-picons-remove gnus-group-annotations)
 310       (setq gnus-group-annotations
 311             (gnus-picons-insert-face-if-exists
 312              gnus-picons-news-directory
 313              (message-tokenize-header gnus-newsgroup-name ".")
 314              "unknown" nil t))
 315       (add-hook 'gnus-summary-exit-hook 'gnus-picons-remove-all))))
 316
 317 (defsubst gnus-picons-try-suffixes (file)
 318   (let ((suffixes gnus-picons-file-suffixes)
 319         f)
 320     (while (and suffixes
 321                 (not (file-exists-p (setq f (concat file (pop suffixes))))))
 322       (setq f nil))
 323     f))
 324
 325 (defun gnus-picons-insert-face-if-exists (database addrs filename &optional
 326                                                    nobar-p dots rightp)
 327   "Inserts a face at point if I can find one"
 328   ;; '(gnus-picons-insert-face-if-exists
 329   ;;    "Database" '("edu" "indiana" "cs") "Name")
 330   ;; looks for:
 331   ;;  1. edu/indiana/cs/Name
 332   ;;  2. edu/indiana/Name
 333   ;;  3. edu/Name
 334   ;; '(gnus-picons-insert-face-if-exists
 335   ;;     "Database/MISC" '("edu" "indiana" "cs") "Name")
 336   ;; looks for:
 337   ;;  1. MISC/Name
 338   ;; The special treatment of MISC doesn't conform with the conventions for
 339   ;; picon databases, but otherwise we would always see the MISC/unknown face.
 340   (let ((bar (and (not nobar-p)
 341                   (or gnus-picons-display-as-address
 342                       (annotations-in-region
 343                        (point) (min (point-max) (1+ (point)))
 344                        (current-buffer)))))
 345         (path (concat (file-name-as-directory gnus-picons-database)
 346                       database "/"))
 347         (domainp (and gnus-picons-display-as-address dots))
 348         picons found bar-ann cur first)
 349     (when (string-match "/MISC" database)
 350       (setq addrs '(".")))
 351     (while (and addrs
 352                 (file-accessible-directory-p path))
 353       (setq cur (pop addrs)
 354             path (concat path cur "/"))
 355       (if (setq found
 356                 (gnus-picons-try-suffixes (concat path filename "/face.")))
 357           (progn
 358             (setq picons (nconc (when (and domainp first rightp)
 359                                   (list (make-annotation
 360                                          "." (point) 'text
 361                                          nil nil nil rightp)
 362                                         picons))
 363                                 (gnus-picons-try-to-find-face
 364                                  found nil (if domainp cur filename) rightp)
 365                                 (when (and domainp first (not rightp))
 366                                   (list (make-annotation
 367                                          "." (point) 'text
 368                                          nil nil nil rightp)
 369                                         picons))
 370                                 picons)))
 371         (when domainp
 372           (setq picons
 373                 (nconc (list (make-annotation
 374                               (if first (concat (if (not rightp) ".") cur
 375                                                 (if rightp ".")) cur)
 376                                               (point) 'text nil nil nil rightp))
 377                        picons))))
 378       (when (and bar (or domainp found))
 379         (setq bar-ann (gnus-picons-try-to-find-face
 380                        (concat gnus-xmas-glyph-directory "bar.xbm")
 381                        nil nil t))
 382         (when bar-ann
 383           (setq picons (nconc picons bar-ann))
 384           (setq bar nil)))
 385       (setq first t))
 386     (when (and addrs domainp)
 387       (let ((it (mapconcat 'downcase (nreverse addrs) ".")))
 388         (make-annotation
 389          (if first (concat (if (not rightp) ".") it (if rightp ".")) it)
 390          (point) 'text nil nil nil rightp)))
 391     picons))
 392
 393 (defvar gnus-picons-glyph-alist nil)
 394
 395 (defun gnus-picons-try-to-find-face (path &optional xface-p part rightp)
 396   "If PATH exists, display it as a bitmap.  Returns t if succeeded."
 397   (let ((glyph (and (not xface-p)
 398                     (cdr (assoc path gnus-picons-glyph-alist)))))
 399     (when (or glyph (file-exists-p path))
 400       (unless glyph
 401         (setq glyph (make-glyph path))
 402         (unless xface-p
 403           (push (cons path glyph) gnus-picons-glyph-alist))
 404         (set-glyph-face glyph 'default))
 405       (let ((new (make-annotation glyph (point) 'text nil nil nil rightp)))
 406         (nconc
 407          (list new)
 408          (when (and (eq major-mode 'gnus-article-mode)
 409                     (not gnus-picons-display-as-address)
 410                     (not part))
 411            (list (make-annotation " " (point) 'text nil nil nil rightp)))
 412          (when (and part gnus-picons-display-as-address)
 413            (let ((txt (make-annotation part (point) 'text nil nil nil rightp)))
 414              (hide-annotation txt)
 415              (set-extent-property txt 'its-partner new)
 416              (set-extent-property txt 'keymap gnus-picons-map)
 417              (set-extent-property txt 'mouse-face gnus-article-mouse-face)
 418              (set-extent-property new 'its-partner txt)
 419              (set-extent-property new 'keymap gnus-picons-map))))))))
 420
 421 (defun gnus-picons-reverse-domain-path (str)
 422   "a/b/c/d -> d/c/b/a"
 423   (mapconcat 'downcase (nreverse (message-tokenize-header str "/")) "/"))
 424
 425 (defun gnus-picons-toggle-extent (event)
 426   "Toggle picon glyph at given point"
 427   (interactive "e")
 428   (let* ((ant1 (event-glyph-extent event))
 429          (ant2 (extent-property ant1 'its-partner)))
 430     (when (and (annotationp ant1) (annotationp ant2))
 431       (reveal-annotation ant2)
 432       (hide-annotation ant1))))
 433
 434 (gnus-add-shutdown 'gnus-picons-close 'gnus)
 435
 436 (defun gnus-picons-close ()
 437   "Shut down the picons."
 438   (setq gnus-picons-glyph-alist nil))
 439
 440 (provide 'gnus-picon)
 441
 442 ;;; gnus-picon.el ends here