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 'xpm)
  78 (require 'annotations)
  79 (eval-when-compile (require 'cl))
  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-file-suffixes
 114   (when (featurep 'x)
 115     (let ((types (list "xbm")))
 116       (when (featurep 'gif)
 117         (push "gif" types))
 118       (when (featurep 'xpm)
 119         (push "xpm" types))
 120       types))
 121   "List of suffixes on picon file names to try.")
 122
 123 ;;; Internal variables.
 124
 125 (defvar gnus-group-annotations nil)
 126 (defvar gnus-article-annotations nil)
 127 (defvar gnus-x-face-annotations nil)
 128
 129 (defun gnus-picons-remove (plist)
 130   (let ((listitem (car plist)))
 131     (while (setq listitem (car plist))
 132       (if (annotationp listitem)
 133           (delete-annotation listitem))
 134       (setq plist (cdr plist))))
 135   )
 136
 137 (defun gnus-picons-remove-all ()
 138   "Removes all picons from the Gnus display(s)."
 139   (interactive)
 140   (gnus-picons-remove gnus-article-annotations)
 141   (gnus-picons-remove gnus-group-annotations)
 142   (gnus-picons-remove gnus-x-face-annotations)
 143   (setq gnus-article-annotations nil
 144         gnus-group-annotations nil
 145         gnus-x-face-annotations nil)
 146   (if (bufferp gnus-picons-buffer)
 147       (kill-buffer gnus-picons-buffer))
 148   )
 149
 150 (defun gnus-get-buffer-name (variable)
 151   "Returns the buffer name associated with the contents of a variable."
 152   (cond ((symbolp variable)
 153          (let ((newvar (cdr (assq variable gnus-window-to-buffer))))
 154            (cond ((symbolp newvar)
 155                   (symbol-value newvar))
 156                  ((stringp newvar) newvar))))
 157         ((stringp variable)
 158          variable)))
 159
 160 (defun gnus-picons-article-display-x-face ()
 161   "Display the x-face header bitmap in the 'gnus-picons-display-where buffer."
 162   ;; delete any old ones.
 163   (gnus-picons-remove gnus-x-face-annotations)
 164   (setq gnus-x-face-annotations nil)
 165   ;; display the new one.
 166   (let ((gnus-article-x-face-command 'gnus-picons-display-x-face))
 167     (gnus-article-display-x-face)))
 168
 169 (defun gnus-picons-display-x-face (beg end)
 170   "Function to display the x-face header in the picons window.
 171 To use:  (setq gnus-article-x-face-command 'gnus-picons-display-x-face)"
 172   (interactive)
 173   ;; convert the x-face header to a .xbm file
 174   (let ((process-connection-type nil)
 175         (process nil))
 176     (process-kill-without-query
 177      (setq process (start-process
 178                     "gnus-x-face" nil shell-file-name shell-command-switch
 179                     gnus-picons-convert-x-face)))
 180     (process-send-region "gnus-x-face" beg end)
 181     (process-send-eof "gnus-x-face")
 182     ;; wait for it.
 183     (while (not (equal (process-status process) 'exit))
 184       (sleep-for .1)))
 185   ;; display it
 186   (save-excursion
 187     (set-buffer (get-buffer-create (gnus-get-buffer-name
 188                                     gnus-picons-display-where)))
 189     (gnus-add-current-to-buffer-list)
 190     (goto-char (point-min))
 191     (let (buffer-read-only)
 192       (unless (looking-at "$")
 193         (open-line 1))
 194       ;; append the annotation to gnus-article-annotations for deletion.
 195       (setq gnus-x-face-annotations
 196             (append
 197              (gnus-picons-try-to-find-face gnus-picons-x-face-file-name)
 198              gnus-x-face-annotations)))
 199     ;; delete the tmp file
 200     (delete-file gnus-picons-x-face-file-name)))
 201
 202 (defun gnus-article-display-picons ()
 203   "Display faces for an author and his/her domain in gnus-picons-display-where."
 204   (interactive)
 205   (if (and (featurep 'xpm)
 206            (or (not (fboundp 'device-type)) (equal (device-type) 'x))
 207            (mail-fetch-field "from"))
 208       (save-excursion
 209         (let* ((from (mail-fetch-field "from"))
 210                (username
 211                 (progn
 212                   (string-match "\\([-_a-zA-Z0-9]+\\)@" from)
 213                   (match-string 1 from)))
 214                (hostpath
 215                 (concat
 216                  (gnus-picons-reverse-domain-path
 217                   (replace-in-string
 218                    (replace-in-string
 219                     (cadr (mail-extract-address-components from))
 220                     ".*@\\(.*\\)\\'" "\\1")
 221                    "\\." "/")) "/")))
 222           (set-buffer (gnus-get-buffer-name gnus-picons-display-where))
 223           (gnus-add-current-to-buffer-list)
 224           (goto-char (point-min))
 225           (if (eq gnus-picons-display-where 'article)
 226               (and (search-forward "\n\n" nil t)
 227                    (forward-line -1))
 228             (unless (eolp)
 229               (open-line 1)))
 230
 231           (gnus-picons-remove gnus-article-annotations)
 232           (setq gnus-article-annotations nil)
 233           (if (equal username from)
 234               (setq username (progn
 235                                (string-match "<\\([_a-zA-Z0-9-.]+\\)>" from)
 236                                (match-string 1 from))))
 237           (mapcar (lambda (pathpart)
 238                     (setq gnus-article-annotations
 239                           (append
 240                            (gnus-picons-insert-face-if-exists
 241                             (concat
 242                              (file-name-as-directory
 243                               gnus-picons-database) pathpart)
 244                             (concat hostpath username))
 245                            gnus-article-annotations)))
 246                   gnus-picons-user-directories)
 247           (mapcar (lambda (pathpart)
 248                     (setq gnus-article-annotations
 249                           (append
 250                            (gnus-picons-insert-face-if-exists
 251                             (concat (file-name-as-directory
 252                                      gnus-picons-database) pathpart)
 253                             (concat hostpath))
 254                            gnus-article-annotations)))
 255                   gnus-picons-domain-directories)
 256           (add-hook 'gnus-summary-exit-hook 'gnus-picons-remove-all)))))
 257
 258 (defun gnus-group-display-picons ()
 259   "Display icons for the group in the gnus-picons-display-where buffer."
 260   (interactive)
 261   (when (and (featurep 'xpm)
 262              (or (not (fboundp 'device-type)) (equal (device-type) 'x)))
 263     (save-excursion
 264       (set-buffer (get-buffer-create
 265                    (gnus-get-buffer-name gnus-picons-display-where)))
 266       (gnus-add-current-to-buffer-list)
 267       (goto-char (point-min))
 268       (if (eq gnus-picons-display-where 'article)
 269           (and (search-forward "\n\n" nil t)
 270                (forward-line -1)
 271                )
 272         (unless (eolp)
 273           (open-line 1)))
 274       (cond
 275        ((listp gnus-group-annotations)
 276         (mapcar 'delete-annotation gnus-group-annotations)
 277         (setq gnus-group-annotations nil))
 278        ((annotationp gnus-group-annotations)
 279         (delete-annotation gnus-group-annotations)
 280         (setq gnus-group-annotations nil)))
 281       (gnus-picons-remove gnus-group-annotations)
 282       (setq gnus-group-annotations nil)
 283       (setq gnus-group-annotations
 284             (gnus-picons-insert-face-if-exists
 285              (concat (file-name-as-directory gnus-picons-database)
 286                      gnus-picons-news-directory)
 287              (concat (replace-in-string gnus-newsgroup-name "\\." "/")
 288                      "/unknown")
 289              t))
 290       (add-hook 'gnus-summary-exit-hook 'gnus-picons-remove-all))))
 291
 292 (defsubst gnus-picons-try-suffixes (file)
 293   (let ((suffixes gnus-picons-file-suffixes)
 294         f)
 295     (while (and suffixes
 296                 (not (file-exists-p (setq f (concat file (pop suffixes))))))
 297       (setq f nil))
 298     f))
 299
 300 (defun gnus-picons-insert-face-if-exists (path filename &optional rev)
 301   "Inserts a face at point if I can find one"
 302   (let ((files (message-tokenize-header filename "/"))
 303         picons found)
 304     (while (and files
 305                 (file-exists-p path))
 306       (setq path (concat path "/" (pop files)))
 307       (when (setq found
 308                   (or
 309                    (gnus-picons-try-suffixes (concat path "/face."))
 310                    (gnus-picons-try-suffixes (concat path "/unknown/face."))))
 311         (setq picons (nconc (gnus-picons-try-to-find-face found)
 312                             picons))))
 313     (nreverse picons)))
 314
 315 (defvar gnus-picons-glyph-alist nil)
 316
 317 (defun gnus-picons-try-to-find-face (path)
 318   "If PATH exists, display it as a bitmap.  Returns t if succedded."
 319   (let ((glyph (cdr (assoc path gnus-picons-glyph-alist))))
 320     (when (or glyph (file-exists-p path))
 321       (unless glyph
 322         (push (cons path (setq glyph (make-glyph path)))
 323               gnus-picons-glyph-alist)
 324         (set-glyph-face glyph 'default))
 325       (nconc
 326        (list (make-annotation glyph (point) 'text))
 327        (when (eq major-mode 'gnus-article-mode)
 328          (list (make-annotation " " (point) 'text)))))))
 329
 330 (defun gnus-picons-reverse-domain-path (str)
 331   "a/b/c/d -> d/c/b/a"
 332   (mapconcat 'identity (nreverse (message-tokenize-header str "/")) "/"))
 333
 334 (gnus-add-shutdown 'gnus-picons-close 'gnus)
 335
 336 (defun gnus-picons-close ()
 337   "Shut down the picons."
 338   (setq gnus-picons-glyph-alist nil))
 339
 340 (provide 'gnus-picon)
 341
 342 ;;; gnus-picon.el ends here