1 ;;; gnus-picon.el --- displaying pretty icons in Gnus
2 ;; Copyright (C) 1996 Free Software Foundation, Inc.
4 ;; Author: Wes Hardaker <hardaker@ece.ucdavis.edu>
5 ;; Keywords: news xpm annotation glyph faces
7 ;; This file is part of GNU Emacs.
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)
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.
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.
27 ;; - You must have XEmacs (19.12 or above I think) to use this.
28 ;; - Read the variable descriptions below.
32 ;; 1) display the icons in its own buffer:
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)
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:
42 ;; (gnus-add-configuration
43 ;; '(article (vertical 1.0
46 ;; (summary .25 point)
49 ;; (gnus-add-configuration
50 ;; '(summary (vertical 1.0 (group 6)
52 ;; (summary 1.0 point))))
54 ;; 2) display the icons in the summary buffer
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)
60 ;; 3) display the icons in the article buffer
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)
68 ;; - I'm not even close to being a lisp expert.
69 ;; - The 't' (append) flag MUST be in the add-hook line
72 ;; - Remove the TODO section in the headers.
79 (require 'annotations)
81 (defvar gnus-picons-buffer "*Icon Buffer*"
82 "Buffer name to display the icons in if gnus-picons-display-where is 'picons.")
84 (defvar gnus-picons-display-where 'picons
85 "Where to display the group and article icons.")
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" )
92 (defvar gnus-picons-news-directory "news"
93 "Sub-directory of the faces database containing the icons for newsgroups."
96 (defvar gnus-picons-user-directories '("local" "users" "usenix" "misc/MISC")
97 "List of directories to search for user faces."
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."
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.")
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."
113 (defvar gnus-picons-display-as-address t
114 "*If t display textual email addresses along with pictures.")
116 (defvar gnus-picons-file-suffixes
118 (let ((types (list "xbm")))
119 (when (featurep 'gif)
121 (when (featurep 'xpm)
124 "List of suffixes on picon file names to try.")
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.")
130 (defvar gnus-picons-map (make-sparse-keymap "gnus-picons-keys")
131 "keymap to hide/show picon glpyhs")
133 (define-key gnus-picons-map [(button2)] 'gnus-picons-toggle-extent)
135 ;;; Internal variables.
137 (defvar gnus-group-annotations nil)
138 (defvar gnus-article-annotations nil)
139 (defvar gnus-x-face-annotations nil)
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))))
149 (defun gnus-picons-remove-all ()
150 "Removes all picons from the Gnus display(s)."
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))
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))))
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)))
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)"
185 ;; convert the x-face header to a .xbm file
186 (let ((process-connection-type 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")
195 (while (not (equal (process-status process) 'exit))
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)
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
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)))
215 (defun gnus-article-display-picons ()
216 "Display faces for an author and his/her domain in gnus-picons-display-where."
218 ;; let drawing catch up
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
227 (or (setq at-idx (string-match "@" from))
228 (setq at-idx (length from))))
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 "."))
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)
247 (push (make-annotation "\n" (point) 'text)
248 gnus-article-annotations)))
250 (gnus-picons-remove gnus-article-annotations)
251 (setq gnus-article-annotations nil)
253 ;; look for domain paths.
254 (setq databases gnus-picons-domain-directories)
256 (setq gnus-article-annotations
257 (nconc (gnus-picons-insert-face-if-exists
261 gnus-article-annotations))
262 (setq databases (cdr databases)))
264 ;; add an '@' if displaying as address
265 (when gnus-picons-display-as-address
266 (setq gnus-article-annotations
267 (nconc gnus-article-annotations
269 (make-annotation "@" (point) 'text nil nil nil t)))))
271 ;; then do user directories,
273 (setq databases gnus-picons-user-directories)
274 (setq username (downcase username))
277 (nconc (gnus-picons-insert-face-if-exists
282 (setq databases (cdr databases)))
283 ;; add their name if no face exists
284 (when (and gnus-picons-display-as-address (not found))
287 (make-annotation username (point) 'text nil nil nil t))))
288 (setq gnus-article-annotations
289 (nconc found gnus-article-annotations)))
291 (add-hook 'gnus-summary-exit-hook 'gnus-picons-remove-all))))))
293 (defun gnus-group-display-picons ()
294 "Display icons for the group in the gnus-picons-display-where buffer."
296 ;; let display catch up so far
298 (when (and (featurep 'xpm)
299 (or (not (fboundp 'device-type)) (equal (device-type) 'x)))
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)
310 (push (make-annotation "\n" (point) 'text)
311 gnus-group-annotations)))
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 ".")
326 (add-hook 'gnus-summary-exit-hook 'gnus-picons-remove-all))))
328 (defsubst gnus-picons-try-suffixes (file)
329 (let ((suffixes gnus-picons-file-suffixes)
332 (not (file-exists-p (setq f (concat file (pop suffixes))))))
336 (defun gnus-picons-insert-face-if-exists (database addrs filename &optional
338 "Inserts a face at point if I can find one"
339 ;; '(gnus-picons-insert-face-if-exists
340 ; "Database" '("edu" "indiana" "cs") "Name")
342 ;; 1. edu/indiana/cs/Name
343 ;; 2. edu/indiana/Name
345 ;; '(gnus-picons-insert-face-if-exists
346 ;; "Database/MISC" '("edu" "indiana" "cs") "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)
353 (annotations-in-region
354 (point) (min (point-max) (1+ (point)))
356 (path (concat (file-name-as-directory gnus-picons-database)
358 (domainp (and gnus-picons-display-as-address nobar-p))
359 picons found bar-ann cur first)
360 (if (string-match "/MISC" database)
363 (file-accessible-directory-p path))
364 (setq cur (pop addrs)
365 path (concat path cur "/"))
367 (gnus-picons-try-suffixes (concat path filename "/face.")))
370 (setq bar-ann (gnus-picons-try-to-find-face
371 (concat gnus-xmas-glyph-directory "bar.xbm")))
373 (setq picons (nconc picons bar-ann))
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))
383 (nconc (list (make-annotation (if first (concat cur ".") cur)
384 (point) 'text nil nil nil t))
387 (when (and addrs domainp)
388 (let ((it (mapconcat 'downcase addrs ".")))
390 (if first (concat it ".") it) (point) 'text nil nil nil t)))
393 (defvar gnus-picons-glyph-alist nil)
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))
401 (setq glyph (make-glyph path))
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)))
408 (when (and (eq major-mode 'gnus-article-mode)
409 (not gnus-picons-display-as-address)
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))))))))
421 (defun gnus-picons-reverse-domain-path (str)
423 (mapconcat 'downcase (nreverse (message-tokenize-header str "/")) "/"))
425 (defun gnus-picons-toggle-extent (event)
426 "Toggle picon glyph at given point"
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))))
434 (gnus-add-shutdown 'gnus-picons-close 'gnus)
436 (defun gnus-picons-close ()
437 "Shut down the picons."
438 (setq gnus-picons-glyph-alist nil))
440 (provide 'gnus-picon)
442 ;;; gnus-picon.el ends here