Mercurial > hg > xemacs-beta

comparison lisp/gnus/gnus-picon.el @ 0:376386a54a3c r19-14

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r19-14
author cvs
date Mon, 13 Aug 2007 08:45:50 +0200
parents
children ac2d302a0011
comparison
equal deleted inserted replaced
-1:000000000000 0:376386a54a3c
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 (defvar gnus-picons-display-article-move-p t
124 "*Whether to move point to first empty line when displaying picons.
125 This has only an effect if `gnus-picons-display-where' hs value article.")
126
127 ;;; Internal variables.
128
129 (defvar gnus-group-annotations nil)
130 (defvar gnus-article-annotations nil)
131 (defvar gnus-x-face-annotations nil)
132
133 (defun gnus-picons-remove (plist)
134 (let ((listitem (car plist)))
135 (while (setq listitem (car plist))
136 (if (annotationp listitem)
137 (delete-annotation listitem))
138 (setq plist (cdr plist))))
139 )
140
141 (defun gnus-picons-remove-all ()
142 "Removes all picons from the Gnus display(s)."
143 (interactive)
144 (gnus-picons-remove gnus-article-annotations)
145 (gnus-picons-remove gnus-group-annotations)
146 (gnus-picons-remove gnus-x-face-annotations)
147 (setq gnus-article-annotations nil
148 gnus-group-annotations nil
149 gnus-x-face-annotations nil)
150 (if (bufferp gnus-picons-buffer)
151 (kill-buffer gnus-picons-buffer))
152 )
153
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))))
161 ((stringp variable)
162 variable)))
163
164 (defun gnus-picons-article-display-x-face ()
165 "Display the x-face header bitmap in the 'gnus-picons-display-where buffer."
166 ;; delete any old ones.
167 (gnus-picons-remove gnus-x-face-annotations)
168 (setq gnus-x-face-annotations nil)
169 ;; display the new one.
170 (let ((gnus-article-x-face-command 'gnus-picons-display-x-face))
171 (gnus-article-display-x-face)))
172
173 (defun gnus-picons-display-x-face (beg end)
174 "Function to display the x-face header in the picons window.
175 To use: (setq gnus-article-x-face-command 'gnus-picons-display-x-face)"
176 (interactive)
177 ;; convert the x-face header to a .xbm file
178 (let ((process-connection-type nil)
179 (process nil))
180 (process-kill-without-query
181 (setq process (start-process
182 "gnus-x-face" nil shell-file-name shell-command-switch
183 gnus-picons-convert-x-face)))
184 (process-send-region "gnus-x-face" beg end)
185 (process-send-eof "gnus-x-face")
186 ;; wait for it.
187 (while (not (equal (process-status process) 'exit))
188 (sleep-for .1)))
189 ;; display it
190 (save-excursion
191 (set-buffer (get-buffer-create (gnus-get-buffer-name
192 gnus-picons-display-where)))
193 (gnus-add-current-to-buffer-list)
194 (goto-char (point-min))
195 (let (buffer-read-only)
196 (unless (eolp)
197 (push (make-annotation "\n" (point) 'text)
198 gnus-x-face-annotations))
199 ;; append the annotation to gnus-article-annotations for deletion.
200 (setq gnus-x-face-annotations
201 (append
202 (gnus-picons-try-to-find-face gnus-picons-x-face-file-name t)
203 gnus-x-face-annotations)))
204 ;; delete the tmp file
205 (delete-file gnus-picons-x-face-file-name)))
206
207 (defun gnus-article-display-picons ()
208 "Display faces for an author and his/her domain in gnus-picons-display-where."
209 (interactive)
210 (let (from at-idx databases)
211 (when (and (featurep 'xpm)
212 (or (not (fboundp 'device-type)) (equal (device-type) 'x))
213 (setq from (mail-fetch-field "from"))
214 (setq from (downcase (cadr (mail-extract-address-components
215 from)))
216 at-idx (string-match "@" from)))
217 (save-excursion
218 (let ((username (substring from 0 at-idx))
219 (addrs (nreverse
220 (message-tokenize-header (substring from (1+ at-idx))
221 "."))))
222 (set-buffer (get-buffer-create
223 (gnus-get-buffer-name gnus-picons-display-where)))
224 (gnus-add-current-to-buffer-list)
225 (goto-char (point-min))
226 (if (and (eq gnus-picons-display-where 'article)
227 gnus-picons-display-article-move-p)
228 (when (search-forward "\n\n" nil t)
229 (forward-line -1))
230 (unless (eolp)
231 (push (make-annotation "\n" (point) 'text)
232 gnus-article-annotations)))
233
234 (gnus-picons-remove gnus-article-annotations)
235 (setq gnus-article-annotations nil)
236
237 (setq databases (append gnus-picons-user-directories
238 gnus-picons-domain-directories))
239 (while databases
240 (setq gnus-article-annotations
241 (nconc (gnus-picons-insert-face-if-exists
242 (car databases)
243 addrs
244 "unknown")
245 (gnus-picons-insert-face-if-exists
246 (car databases)
247 addrs
248 (downcase username) t)
249 gnus-article-annotations))
250 (setq databases (cdr databases)))
251 (add-hook 'gnus-summary-exit-hook 'gnus-picons-remove-all))))))
252
253 (defun gnus-group-display-picons ()
254 "Display icons for the group in the gnus-picons-display-where buffer."
255 (interactive)
256 (when (and (featurep 'xpm)
257 (or (not (fboundp 'device-type)) (equal (device-type) 'x)))
258 (save-excursion
259 (set-buffer (get-buffer-create
260 (gnus-get-buffer-name gnus-picons-display-where)))
261 (gnus-add-current-to-buffer-list)
262 (goto-char (point-min))
263 (if (and (eq gnus-picons-display-where 'article)
264 gnus-picons-display-article-move-p)
265 (if (search-forward "\n\n" nil t)
266 (forward-line -1))
267 (unless (eolp)
268 (push (make-annotation "\n" (point) 'text)
269 gnus-group-annotations)))
270 (cond
271 ((listp gnus-group-annotations)
272 (mapcar 'delete-annotation gnus-group-annotations)
273 (setq gnus-group-annotations nil))
274 ((annotationp gnus-group-annotations)
275 (delete-annotation gnus-group-annotations)
276 (setq gnus-group-annotations nil)))
277 (gnus-picons-remove gnus-group-annotations)
278 (setq gnus-group-annotations
279 (gnus-picons-insert-face-if-exists
280 gnus-picons-news-directory
281 (message-tokenize-header gnus-newsgroup-name ".")
282 "unknown"))
283 (add-hook 'gnus-summary-exit-hook 'gnus-picons-remove-all))))
284
285 (defsubst gnus-picons-try-suffixes (file)
286 (let ((suffixes gnus-picons-file-suffixes)
287 f)
288 (while (and suffixes
289 (not (file-exists-p (setq f (concat file (pop suffixes))))))
290 (setq f nil))
291 f))
292
293 (defun gnus-picons-insert-face-if-exists (database addrs filename &optional
294 nobar-p)
295 "Inserts a face at point if I can find one"
296 ;; '(gnus-picons-insert-face-if-exists
297 ; "Database" '("edu" "indiana" "cs") "Name")
298 ;; looks for:
299 ;; 1. edu/indiana/cs/Name
300 ;; 2. edu/indiana/Name
301 ;; 3. edu/Name
302 ;; '(gnus-picons-insert-face-if-exists
303 ;; "Database/MISC" '("edu" "indiana" "cs") "Name")
304 ;; looks for:
305 ;; 1. MISC/Name
306 ;; The special treatment of MISC doesn't conform with the conventions for
307 ;; picon databases, but otherwise we would always see the MISC/unknown face.
308 (let ((bar (and (not nobar-p)
309 (annotations-in-region
310 (point) (min (point-max) (1+ (point)))
311 (current-buffer))))
312 (path (concat (file-name-as-directory gnus-picons-database)
313 database "/"))
314 picons found bar-ann)
315 (if (string-match "/MISC" database)
316 (setq addrs '("")))
317 (while (and addrs
318 (file-accessible-directory-p path))
319 (setq path (concat path (pop addrs) "/"))
320 (when (setq found
321 (gnus-picons-try-suffixes
322 (concat path filename "/face.")))
323 (when bar
324 (setq bar-ann (gnus-picons-try-to-find-face
325 (concat gnus-xmas-glyph-directory "bar.xbm")))
326 (when bar-ann
327 (setq picons (nconc picons bar-ann))
328 (setq bar nil)))
329 (setq picons (nconc (gnus-picons-try-to-find-face found)
330 picons))))
331 (nreverse picons)))
332
333 (defvar gnus-picons-glyph-alist nil)
334
335 (defun gnus-picons-try-to-find-face (path &optional xface-p)
336 "If PATH exists, display it as a bitmap. Returns t if succedded."
337 (let ((glyph (and (not xface-p)
338 (cdr (assoc path gnus-picons-glyph-alist)))))
339 (when (or glyph (file-exists-p path))
340 (unless glyph
341 (setq glyph (make-glyph path))
342 (unless xface-p
343 (push (cons path glyph) gnus-picons-glyph-alist))
344 (set-glyph-face glyph 'default))
345 (nconc
346 (list (make-annotation glyph (point) 'text))
347 (when (eq major-mode 'gnus-article-mode)
348 (list (make-annotation " " (point) 'text)))))))
349
350 (defun gnus-picons-reverse-domain-path (str)
351 "a/b/c/d -> d/c/b/a"
352 (mapconcat 'downcase (nreverse (message-tokenize-header str "/")) "/"))
353
354 (gnus-add-shutdown 'gnus-picons-close 'gnus)
355
356 (defun gnus-picons-close ()
357 "Shut down the picons."
358 (setq gnus-picons-glyph-alist nil))
359
360 (provide 'gnus-picon)
361
362 ;;; gnus-picon.el ends here