cgit.sxemacs.org Git - gnus/blob - lisp/gnus-picon.el

   1 ;; gnus-picon.el:  Copyright (C) 1995 Wes Hardaker
   2 ;; Icon hacks for displaying pretty icons in Gnus.
   3 ;;
   4 ;; Author:  Wes hardaker
   5 ;;          hardaker@ece.ucdavis.edu
   6 ;;
   7 ;; Usage:
   8 ;;     - You must have XEmacs to use this.
   9 ;;     - (add-hook 'gnus-article-display-hook 'gnus-article-display-picons t)
  10 ;;       This HAS to have the 't' flag above to make sure it appends the hook.
  11 ;;     - Read the variable descriptions below.
  12 ;;
  13 ;; Warnings:
  14 ;;     - I'm not even close to being a lisp expert.
  15 ;;
  16 ;; TODO:
  17 ;;     - Following the Gnus motto: We've got to build him bigger,
  18 ;;       better, stronger, faster than before...  errr....  sorry.
  19 ;;     - Create a seperate frame to store icons in so icons are
  20 ;;       visibile immediately upon entering a group rather than just
  21 ;;       at the top of the article buffer.
  22 ;;
  23 ;;
  24
  25 (require 'xpm)
  26 (require 'annotations)
  27
  28 (defvar gnus-picons-database "/usr/local/faces"
  29   "defines the location of the faces database.  For information on
  30   obtaining this database of pretty pictures, please see
  31   http://www.cs.indiana.edu/picons/ftp/index.html"
  32 )
  33
  34 (defvar gnus-picons-news-directory "news"
  35   "Sub-directory of the faces database containing the icons for
  36   newsgroups."
  37 )
  38
  39 (defvar gnus-picons-user-directories '("local" "users" "usenix" "misc/MISC")
  40   "List of directories to search for user faces."
  41 )
  42
  43 (defvar gnus-picons-domain-directories '("domains")
  44   "List of directories to search for domain faces.  Some people may
  45   want to add \"unknown\" to this list."
  46 )
  47
  48 (defun gnus-article-display-picons ()
  49   "prepare article buffer with pretty pictures"
  50   (interactive)
  51   (if (featurep 'xpm)
  52       (save-excursion
  53         (beginning-of-buffer)
  54         (open-line 1)
  55         (let* ((iconpoint (point)) (from (mail-fetch-field "from"))
  56           (username
  57            (progn
  58              (string-match "\\([-_a-zA-Z0-9]+\\)@" from)
  59              (match-string 1 from)))
  60            (hostpath
  61             (gnus-picons-reverse-domain-path
  62              (replace-in-string
  63               (replace-in-string from ".*@\\([_a-zA-Z0-9-.]+\\).*" "\\1")
  64               "\\." "/"))))
  65           (if (equal username from)
  66                 (setq username (replace-in-string from
  67                                                   ".*<\\([_a-zA-Z0-9-.]+\\)>.*"
  68                                                   "\\1")))
  69           (insert username)
  70           (gnus-picons-insert-face-if-exists
  71            (concat gnus-picons-database "/" gnus-picons-news-directory)
  72            (concat (replace-in-string gnus-newsgroup-name "\\." "/") "/unknown")
  73            iconpoint)
  74           (mapcar '(lambda (pathpart)
  75                      (gnus-picons-insert-face-if-exists
  76                       (concat gnus-picons-database "/" pathpart)
  77                       (concat hostpath "/" username)
  78                       iconpoint))
  79                   gnus-picons-user-directories)
  80           (mapcar '(lambda (pathpart)
  81                      (gnus-picons-insert-face-if-exists
  82                       (concat gnus-picons-database "/" pathpart)
  83                       (concat hostpath "/" "unknown")
  84                       iconpoint))
  85                   gnus-picons-domain-directories)
  86           ))))
  87
  88 (defun gnus-picons-insert-face-if-exists (path filename ipoint)
  89   "inserts a face at point if I can find one"
  90   (let ((pathfile (concat path "/" filename "/face")))
  91     (let ((newfilename
  92            (replace-in-string filename
  93                               "[_a-zA-Z0-9-]+/\\([_A-Za-z0-9-]+\\)$" "\\1")))
  94       (if (not (equal filename newfilename))
  95           (gnus-picons-insert-face-if-exists path newfilename ipoint)))
  96     (if (not (gnus-picons-try-to-find-face (concat pathfile ".xpm") ipoint))
  97         (gnus-picons-try-to-find-face (concat pathfile ".xbm") ipoint))
  98     )
  99   )
 100
 101
 102 (defun gnus-picons-try-to-find-face (path ipoint)
 103   "if path exists, display it as a bitmap.  Returns t if succedded."
 104     (if (file-exists-p path)
 105         (progn
 106           (setq gl (make-glyph path))
 107           (set-glyph-face gl 'default)
 108           (setq annot (make-annotation gl ipoint 'text))
 109           t)
 110 ;      (insert (format "no:  %s\n" path))
 111       nil))
 112
 113 (defun gnus-picons-reverse-domain-path (str)
 114   "a/b/c/d -> d/c/b/a"
 115   (if (equal (replace-in-string str "^[^/]*$" "") "")
 116       str
 117     (concat (replace-in-string str "^.*/\\([_a-zA-Z0-9-]+\\)$" "\\1") "/"
 118             (gnus-picons-reverse-domain-path
 119              (replace-in-string str "^\\(.*\\)/[_a-zA-Z0-9-]+$" "\\1")))))
 120
 121