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