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