1 ;;; gnus-picon.el --- displaying pretty icons in Gnus
2 ;; Copyright (C) 1996,97 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.
30 (require 'annotations)
36 "Show pictures of people, domains, and newsgroups (XEmacs).
37 For this to work, you must add gnus-group-display-picons to the
38 gnus-summary-display-hook or to the gnus-article-display-hook
39 depending on what gnus-picons-display-where is set to. You must
40 also add gnus-article-display-picons to gnus-article-display-hook."
43 (defcustom gnus-picons-buffer "*Icon Buffer*"
44 "Buffer name to display the icons in if gnus-picons-display-where is 'picons."
48 (defcustom gnus-picons-display-where 'picons
49 "Where to display the group and article icons.
50 Legal values are `article' and `picons'."
51 :type '(choice symbol string)
54 (defcustom gnus-picons-database "/usr/local/faces"
55 "Defines the location of the faces database.
56 For information on obtaining this database of pretty pictures, please
57 see http://www.cs.indiana.edu/picons/ftp/index.html"
61 (defcustom gnus-picons-news-directory "news"
62 "Sub-directory of the faces database containing the icons for newsgroups."
66 (defcustom gnus-picons-user-directories '("local" "users" "usenix" "misc")
67 "List of directories to search for user faces."
68 :type '(repeat string)
71 (defcustom gnus-picons-domain-directories '("domains")
72 "List of directories to search for domain faces.
73 Some people may want to add \"unknown\" to this list."
74 :type '(repeat string)
77 (defcustom gnus-picons-refresh-before-display nil
78 "If non-nil, display the article buffer before computing the picons."
82 (defcustom gnus-picons-x-face-file-name
83 (format "/tmp/picon-xface.%s.xbm" (user-login-name))
84 "The name of the file in which to store the converted X-face header."
88 (defcustom gnus-picons-convert-x-face (format "{ echo '/* Width=48, Height=48 */'; uncompface; } | icontopbm | pbmtoxbm > %s" gnus-picons-x-face-file-name)
89 "Command to convert the x-face header into a xbm file."
93 (defcustom gnus-picons-display-as-address t
94 "*If t display textual email addresses along with pictures."
98 (defcustom gnus-picons-file-suffixes
100 (let ((types (list "xbm")))
101 (when (featurep 'gif)
103 (when (featurep 'xpm)
106 "List of suffixes on picon file names to try."
107 :type '(repeat string)
110 (defcustom gnus-picons-display-article-move-p t
111 "*Whether to move point to first empty line when displaying picons.
112 This has only an effect if `gnus-picons-display-where' has value `article'."
116 (defvar gnus-picons-map (make-sparse-keymap "gnus-picons-keys")
117 "keymap to hide/show picon glyphs")
119 (define-key gnus-picons-map [(button2)] 'gnus-picons-toggle-extent)
121 ;;; Internal variables.
123 (defvar gnus-group-annotations nil
124 "List of annotations added/removed when selecting/exiting a group")
125 (defvar gnus-article-annotations nil
126 "List of annotations added/removed when selecting an article")
127 (defvar gnus-x-face-annotations nil
128 "List of annotations added/removed when selecting an article with an X-Face.")
130 (defun gnus-picons-remove (symbol)
131 "Remove all annotations/processes in variable named SYMBOL.
132 This function is careful to set it to nil before removing anything so that
133 asynchronous process don't get crazy."
134 (let ((listitems (symbol-value symbol)))
137 (let ((item (pop listitems)))
138 (cond ((annotationp item)
139 (delete-annotation item))
141 ;; kill the process, ignore any output.
142 (set-process-sentinel item (function (lambda (p e))))
143 (delete-process item)))))))
145 (defun gnus-picons-remove-all ()
146 "Removes all picons from the Gnus display(s)."
148 (gnus-picons-remove 'gnus-article-annotations)
149 (gnus-picons-remove 'gnus-group-annotations)
150 (gnus-picons-remove 'gnus-x-face-annotations)
151 (when (bufferp gnus-picons-buffer)
152 (kill-buffer gnus-picons-buffer)))
154 (defun gnus-get-buffer-name (variable)
155 "Returns the buffer name associated with the contents of a variable."
156 (cond ((symbolp variable)
157 (let ((newvar (cdr (assq variable gnus-window-to-buffer))))
158 (cond ((symbolp newvar)
159 (symbol-value newvar))
160 ((stringp newvar) newvar))))
164 (defun gnus-picons-prepare-for-annotations (annotations)
165 "Prepare picons buffer for puting annotations memorized in ANNOTATIONS.
166 ANNOTATIONS should be a symbol naming a variable wich contains a list of
167 annotations. Sets buffer to `gnus-picons-display-where'."
168 ;; let drawing catch up
169 (when gnus-picons-refresh-before-display
171 (set-buffer (get-buffer-create
172 (gnus-get-buffer-name gnus-picons-display-where)))
173 (gnus-add-current-to-buffer-list)
174 (goto-char (point-min))
175 (if (and (eq gnus-picons-display-where 'article)
176 gnus-picons-display-article-move-p)
177 (when (search-forward "\n\n" nil t)
179 (gnus-picons-remove annotations))
181 (defun gnus-picons-article-display-x-face ()
182 "Display the x-face header bitmap in the 'gnus-picons-display-where buffer."
183 ;; delete any old ones.
184 ;; This is needed here because gnus-picons-display-x-face will not
185 ;; be called if there is no X-Face header
186 (gnus-picons-remove 'gnus-x-face-annotations)
187 ;; display the new one.
188 (let ((gnus-article-x-face-command 'gnus-picons-display-x-face))
189 (gnus-article-display-x-face)))
191 (defun gnus-picons-x-face-sentinel (process event)
192 ;; don't call gnus-picons-prepare-for-annotations, it would reset
193 ;; gnus-x-face-annotations.
194 (set-buffer (get-buffer-create
195 (gnus-get-buffer-name gnus-picons-display-where)))
196 (gnus-add-current-to-buffer-list)
197 (goto-char (point-min))
198 (if (and (eq gnus-picons-display-where 'article)
199 gnus-picons-display-article-move-p)
200 (when (search-forward "\n\n" nil t)
202 ;; If the process is still in the list, insert this icon
203 (let ((myself (member process gnus-x-face-annotations)))
206 (make-annotation gnus-picons-x-face-file-name nil 'text))
207 (delete-file gnus-picons-x-face-file-name))))
209 (defun gnus-picons-display-x-face (beg end)
210 "Function to display the x-face header in the picons window.
211 To use: (setq gnus-article-x-face-command 'gnus-picons-display-x-face)"
213 (if (featurep 'xface)
214 ;; Use builtin support
215 (let ((buf (current-buffer)))
217 (gnus-picons-prepare-for-annotations 'gnus-x-face-annotations)
218 (setq gnus-x-face-annotations
219 (cons (make-annotation (concat "X-Face: "
220 (buffer-substring beg end buf))
222 gnus-x-face-annotations))))
223 ;; convert the x-face header to a .xbm file
224 (let* ((process-connection-type nil)
225 (process (start-process "gnus-x-face" nil
226 shell-file-name shell-command-switch
227 gnus-picons-convert-x-face)))
228 (process-kill-without-query process)
229 (setq gnus-x-face-annotations (list process))
230 (set-process-sentinel process 'gnus-picons-x-face-sentinel)
231 (process-send-region process beg end)
232 (process-send-eof process))))
234 (defun gnus-article-display-picons ()
235 "Display faces for an author and his/her domain in gnus-picons-display-where."
238 (when (and (featurep 'xpm)
239 (or (not (fboundp 'device-type)) (equal (device-type) 'x))
240 (setq from (mail-fetch-field "from"))
242 (or (cadr (mail-extract-address-components from))
244 (or (setq at-idx (string-match "@" from))
245 (setq at-idx (length from))))
247 (let ((username (substring from 0 at-idx))
248 (addrs (if (eq at-idx (length from))
249 (if gnus-local-domain
250 (message-tokenize-header gnus-local-domain ".")
252 (message-tokenize-header (substring from (1+ at-idx))
254 (gnus-picons-prepare-for-annotations 'gnus-article-annotations)
255 (setq gnus-article-annotations
256 (nconc gnus-article-annotations
257 ;; look for domain paths.
258 (gnus-picons-display-pairs
259 (gnus-picons-lookup-pairs addrs
260 gnus-picons-domain-directories)
261 (not (or gnus-picons-display-as-address
262 gnus-article-annotations))
264 ;; add an '@' if displaying as address
265 (if (and gnus-picons-display-as-address addrs)
266 (list (make-annotation "@" nil 'text nil nil nil t)))
267 ;; then do user directories,
268 (gnus-picons-display-picon-or-name
269 (gnus-picons-lookup-user (downcase username) addrs)
272 (add-hook 'gnus-summary-exit-hook 'gnus-picons-remove-all))))))
274 (defun gnus-group-display-picons ()
275 "Display icons for the group in the gnus-picons-display-where buffer."
277 (when (and (featurep 'xpm)
278 (or (not (fboundp 'device-type)) (equal (device-type) 'x)))
280 (gnus-picons-prepare-for-annotations 'gnus-group-annotations)
281 (setq gnus-group-annotations
282 (gnus-picons-display-pairs
283 (gnus-picons-lookup-pairs (reverse (message-tokenize-header
284 gnus-newsgroup-name "."))
285 gnus-picons-news-directory)
287 (add-hook 'gnus-summary-exit-hook 'gnus-picons-remove-all))))
289 (defun gnus-picons-make-path (dir subdirs)
290 "Make a directory name from a base DIR and a list of SUBDIRS.
291 Returns a directory name build by concatenating DIR and all elements of
292 SUBDIRS with \"/\" between elements."
294 (setq dir (file-name-as-directory (concat dir (pop subdirs)))))
297 (defsubst gnus-picons-try-suffixes (file)
298 (let ((suffixes gnus-picons-file-suffixes)
301 (not (file-exists-p (setq f (concat file (pop suffixes))))))
305 (defun gnus-picons-lookup (addrs dirs)
306 "Lookup the picon for ADDRS in databases DIRS.
307 Returns the picon filename or NIL if none found."
309 (while (and dirs (null result))
311 (gnus-picons-try-suffixes
312 (expand-file-name "face."
313 (gnus-picons-make-path
314 (file-name-as-directory
316 (file-name-as-directory gnus-picons-database)
321 (defun gnus-picons-lookup-user-internal (user domains)
322 (let ((dirs gnus-picons-user-directories)
324 (while (and dirs (null picon))
325 (let ((dir (list (pop dirs)))
327 (while (and domains (null picon))
328 (setq picon (gnus-picons-lookup (cons user domains) dir))
330 ;; Also make a try MISC subdir
332 (setq picon (gnus-picons-lookup (list user "MISC") dir)))))
336 (defun gnus-picons-lookup-user (user domains)
337 "Lookup the picon for USER at DOMAINS.
338 USER is a string containing a name.
339 DOMAINS is a list of strings from the fully qualified domain name."
340 (or (gnus-picons-lookup-user-internal user domains)
341 (gnus-picons-lookup-user-internal "unknown" domains)))
343 (defun gnus-picons-lookup-pairs (domains directories)
344 "Lookup picons for DOMAINS and all its parents in DIRECTORIES.
345 Returns a list of PAIRS whose CAR is the picon filename or NIL if
346 none, and whose CDR is the corresponding element of DOMAINS."
349 (push (list (gnus-picons-lookup (cons "unknown" domains)
350 (if (listp directories)
357 (defun gnus-picons-display-picon-or-name (picon name &optional xface-p right-p)
359 (gnus-picons-try-to-find-face picon xface-p name right-p)
360 (list (make-annotation name nil 'text nil nil nil right-p))))
362 (defun gnus-picons-display-pairs (pairs &optional bar-p xface-p dot-p right-p)
363 "Display picons in list PAIRS."
364 (let ((bar (and bar-p (or gnus-picons-display-as-address
365 (annotations-in-region (point)
366 (min (point-max) (1+ (point)))
368 (domain-p (and gnus-picons-display-as-address dot-p))
371 (let ((pair (pop pairs)))
372 (setq picons (nconc (if (and domain-p picons (not right-p))
373 (list (make-annotation
374 dot-p nil 'text nil nil nil right-p)))
375 (gnus-picons-display-picon-or-name (car pair)
379 (if (and domain-p pairs right-p)
380 (list (make-annotation
381 dot-p nil 'text nil nil nil right-p)))
382 (when (and bar domain-p)
384 (gnus-picons-try-to-find-face
385 (expand-file-name "bar.xbm"
386 gnus-xmas-glyph-directory)
391 (defvar gnus-picons-glyph-alist nil)
393 (defun gnus-picons-try-to-find-face (path &optional xface-p part rightp)
394 "If PATH exists, display it as a bitmap. Returns t if succeeded."
395 (let ((glyph (and (not xface-p)
396 (cdr (assoc path gnus-picons-glyph-alist)))))
397 (when (or glyph (file-exists-p path))
399 (setq glyph (make-glyph path))
401 (push (cons path glyph) gnus-picons-glyph-alist))
402 (set-glyph-face glyph 'default))
403 (let ((new (make-annotation glyph (point) 'text nil nil nil rightp)))
406 (when (and (eq major-mode 'gnus-article-mode)
407 (not gnus-picons-display-as-address)
409 (list (make-annotation " " (point) 'text nil nil nil rightp)))
410 (when (and part gnus-picons-display-as-address)
411 (let ((txt (make-annotation part (point) 'text nil nil nil rightp)))
412 (hide-annotation txt)
413 (set-extent-property txt 'its-partner new)
414 (set-extent-property txt 'keymap gnus-picons-map)
415 (set-extent-property txt 'mouse-face gnus-article-mouse-face)
416 (set-extent-property new 'its-partner txt)
417 (set-extent-property new 'keymap gnus-picons-map)
420 (defun gnus-picons-toggle-extent (event)
421 "Toggle picon glyph at given point"
423 (let* ((ant1 (event-glyph-extent event))
424 (ant2 (extent-property ant1 'its-partner)))
425 (when (and (annotationp ant1) (annotationp ant2))
426 (reveal-annotation ant2)
427 (hide-annotation ant1))))
429 (gnus-add-shutdown 'gnus-picons-close 'gnus)
431 (defun gnus-picons-close ()
432 "Shut down the picons."
433 (setq gnus-picons-glyph-alist nil))
435 (provide 'gnus-picon)
437 ;;; gnus-picon.el ends here