1 ;; gnus-picon.el: Copyright (C) 1995 Wes Hardaker
2 ;; Icon hacks for displaying pretty icons in Gnus.
4 ;; Author: Wes hardaker
5 ;; hardaker@ece.ucdavis.edu
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.
14 ;; - I'm not even close to being a lisp expert.
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.
26 (require 'annotations)
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"
34 (defvar gnus-picons-news-directory "news"
35 "Sub-directory of the faces database containing the icons for
39 (defvar gnus-picons-user-directories '("local" "users" "usenix" "misc/MISC")
40 "List of directories to search for user faces."
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."
48 (defun gnus-article-display-picons ()
49 "prepare article buffer with pretty pictures"
55 (let* ((iconpoint (point)) (from (mail-fetch-field "from"))
58 (string-match "\\([-_a-zA-Z0-9]+\\)@" from)
59 (match-string 1 from)))
61 (gnus-picons-reverse-domain-path
63 (replace-in-string from ".*@\\([_a-zA-Z0-9-.]+\\).*" "\\1")
65 (if (equal username from)
66 (setq username (replace-in-string from
67 ".*<\\([_a-zA-Z0-9-.]+\\)>.*"
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")
74 (mapcar '(lambda (pathpart)
75 (gnus-picons-insert-face-if-exists
76 (concat gnus-picons-database "/" pathpart)
77 (concat hostpath "/" username)
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")
85 gnus-picons-domain-directories)
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")))
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))
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)
106 (setq gl (make-glyph path))
107 (set-glyph-face gl 'default)
108 (setq annot (make-annotation gl ipoint 'text))
110 ; (insert (format "no: %s\n" path))
113 (defun gnus-picons-reverse-domain-path (str)
115 (if (equal (replace-in-string 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")))))