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