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