Mercurial > hg > xemacs-beta

comparison lisp/gnus/gnus-picon.el @ 30:ec9a17fef872 r19-15b98

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r19-15b98
author cvs
date Mon, 13 Aug 2007 08:52:29 +0200
parents 441bb1e64a06
children 131b0175ea99
comparison
equal deleted inserted replaced
29:7976500f47f9 30:ec9a17fef872
27 27
28 (require 'gnus) 28 (require 'gnus)
29 (require 'xpm) 29 (require 'xpm)
30 (require 'annotations) 30 (require 'annotations)
31 (require 'custom) 31 (require 'custom)
32 (require 'gnus-art)
33 (require 'gnus-win)
32 34
33 (defgroup picons nil 35 (defgroup picons nil
34 "Show pictures of people, domains, and newsgroups (XEmacs). 36 "Show pictures of people, domains, and newsgroups (XEmacs).
35 For this to work, you must add gnus-group-display-picons to the 37 For this to work, you must add gnus-group-display-picons to the
36 gnus-summary-display-hook or to the gnus-article-display-hook 38 gnus-summary-display-hook or to the gnus-article-display-hook
48 Legal values are `article' and `picons'." 50 Legal values are `article' and `picons'."
49 :type '(choice symbol string) 51 :type '(choice symbol string)
50 :group 'picons) 52 :group 'picons)
51 53
52 (defcustom gnus-picons-database "/usr/local/faces" 54 (defcustom gnus-picons-database "/usr/local/faces"
53 "Defines the location of the faces database. 55 "Defines the location of the faces database.
54 For information on obtaining this database of pretty pictures, please 56 For information on obtaining this database of pretty pictures, please
55 see http://www.cs.indiana.edu/picons/ftp/index.html" 57 see http://www.cs.indiana.edu/picons/ftp/index.html"
56 :type 'directory 58 :type 'directory
57 :group 'picons) 59 :group 'picons)
58 60
65 "List of directories to search for user faces." 67 "List of directories to search for user faces."
66 :type '(repeat string) 68 :type '(repeat string)
67 :group 'picons) 69 :group 'picons)
68 70
69 (defcustom gnus-picons-domain-directories '("domains") 71 (defcustom gnus-picons-domain-directories '("domains")
70 "List of directories to search for domain faces. 72 "List of directories to search for domain faces.
71 Some people may want to add \"unknown\" to this list." 73 Some people may want to add \"unknown\" to this list."
72 :type '(repeat string) 74 :type '(repeat string)
73 :group 'picons) 75 :group 'picons)
74 76
75 (defcustom gnus-picons-refresh-before-display nil 77 (defcustom gnus-picons-refresh-before-display nil
76 "If non-nil, display the article buffer before computing the picons." 78 "If non-nil, display the article buffer before computing the picons."
77 :type 'boolean 79 :type 'boolean
78 :group 'picons) 80 :group 'picons)
79 81
80 (defcustom gnus-picons-x-face-file-name 82 (defcustom gnus-picons-x-face-file-name
81 (format "/tmp/picon-xface.%s.xbm" (user-login-name)) 83 (format "/tmp/picon-xface.%s.xbm" (user-login-name))
82 "The name of the file in which to store the converted X-face header." 84 "The name of the file in which to store the converted X-face header."
83 :type 'string 85 :type 'string
84 :group 'picons) 86 :group 'picons)
85 87
115 "keymap to hide/show picon glyphs") 117 "keymap to hide/show picon glyphs")
116 118
117 (define-key gnus-picons-map [(button2)] 'gnus-picons-toggle-extent) 119 (define-key gnus-picons-map [(button2)] 'gnus-picons-toggle-extent)
118 120
119 ;;; Internal variables. 121 ;;; Internal variables.
120 122
121 (defvar gnus-group-annotations nil) 123 (defvar gnus-group-annotations nil)
122 (defvar gnus-article-annotations nil) 124 (defvar gnus-article-annotations nil)
123 (defvar gnus-x-face-annotations nil) 125 (defvar gnus-x-face-annotations nil)
124 126
125 (defun gnus-picons-remove (plist) 127 (defun gnus-picons-remove (plist)
176 ;; wait for it. 178 ;; wait for it.
177 (while (not (equal (process-status process) 'exit)) 179 (while (not (equal (process-status process) 'exit))
178 (sleep-for .1))) 180 (sleep-for .1)))
179 ;; display it 181 ;; display it
180 (save-excursion 182 (save-excursion
181 (set-buffer (get-buffer-create (gnus-get-buffer-name 183 (set-buffer (get-buffer-create (gnus-get-buffer-name
182 gnus-picons-display-where))) 184 gnus-picons-display-where)))
183 (gnus-add-current-to-buffer-list) 185 (gnus-add-current-to-buffer-list)
184 (goto-char (point-min)) 186 (goto-char (point-min))
185 (let (buffer-read-only) 187 (let (buffer-read-only)
186 (unless (eolp) 188 (unless (eolp)
187 (push (make-annotation "\n" (point) 'text) 189 (push (make-annotation "\n" (point) 'text)
188 gnus-x-face-annotations)) 190 gnus-x-face-annotations))
189 ;; append the annotation to gnus-article-annotations for deletion. 191 ;; append the annotation to gnus-article-annotations for deletion.
190 (setq gnus-x-face-annotations 192 (setq gnus-x-face-annotations
191 (append 193 (append
192 (gnus-picons-try-to-find-face gnus-picons-x-face-file-name t) 194 (gnus-picons-try-to-find-face gnus-picons-x-face-file-name t)
193 gnus-x-face-annotations))) 195 gnus-x-face-annotations)))
194 ;; delete the tmp file 196 ;; delete the tmp file
195 (delete-file gnus-picons-x-face-file-name))) 197 (delete-file gnus-picons-x-face-file-name)))
203 (let ((first t) 205 (let ((first t)
204 from at-idx databases) 206 from at-idx databases)
205 (when (and (featurep 'xpm) 207 (when (and (featurep 'xpm)
206 (or (not (fboundp 'device-type)) (equal (device-type) 'x)) 208 (or (not (fboundp 'device-type)) (equal (device-type) 'x))
207 (setq from (mail-fetch-field "from")) 209 (setq from (mail-fetch-field "from"))
208 (setq from (downcase 210 (setq from (downcase
209 (or (cadr (mail-extract-address-components from)) 211 (or (cadr (mail-extract-address-components from))
210 ""))) 212 "")))
211 (or (setq at-idx (string-match "@" from)) 213 (or (setq at-idx (string-match "@" from))
212 (setq at-idx (length from)))) 214 (setq at-idx (length from))))
213 (save-excursion 215 (save-excursion
215 (addrs (if (eq at-idx (length from)) 217 (addrs (if (eq at-idx (length from))
216 (if gnus-local-domain 218 (if gnus-local-domain
217 (nreverse (message-tokenize-header 219 (nreverse (message-tokenize-header
218 gnus-local-domain ".")) 220 gnus-local-domain "."))
219 '("")) 221 '(""))
220 (nreverse (message-tokenize-header 222 (nreverse (message-tokenize-header
221 (substring from (1+ at-idx)) "."))))) 223 (substring from (1+ at-idx)) ".")))))
222 (set-buffer (get-buffer-create 224 (set-buffer (get-buffer-create
223 (gnus-get-buffer-name gnus-picons-display-where))) 225 (gnus-get-buffer-name gnus-picons-display-where)))
224 (gnus-add-current-to-buffer-list) 226 (gnus-add-current-to-buffer-list)
225 (goto-char (point-min)) 227 (goto-char (point-min))
228 (when (search-forward "\n\n" nil t) 230 (when (search-forward "\n\n" nil t)
229 (forward-line -1)) 231 (forward-line -1))
230 (unless (eolp) 232 (unless (eolp)
231 (push (make-annotation "\n" (point) 'text) 233 (push (make-annotation "\n" (point) 'text)
232 gnus-article-annotations))) 234 gnus-article-annotations)))
233 235
234 (gnus-picons-remove gnus-article-annotations) 236 (gnus-picons-remove gnus-article-annotations)
235 (setq gnus-article-annotations nil) 237 (setq gnus-article-annotations nil)
236 238
237 ;; look for domain paths. 239 ;; look for domain paths.
238 (setq databases gnus-picons-domain-directories) 240 (setq databases gnus-picons-domain-directories)
239 (while databases 241 (while databases
240 (setq gnus-article-annotations 242 (setq gnus-article-annotations
241 (nconc (gnus-picons-insert-face-if-exists 243 (nconc (gnus-picons-insert-face-if-exists
242 (car databases) 244 (car databases)
243 addrs 245 addrs
244 "unknown" (or gnus-picons-display-as-address 246 "unknown" (or gnus-picons-display-as-address
245 gnus-article-annotations) t t) 247 gnus-article-annotations) t t)
246 gnus-article-annotations)) 248 gnus-article-annotations))
247 (setq databases (cdr databases))) 249 (setq databases (cdr databases)))
248 250
249 ;; add an '@' if displaying as address 251 ;; add an '@' if displaying as address
250 (when gnus-picons-display-as-address 252 (when gnus-picons-display-as-address
251 (setq gnus-article-annotations 253 (setq gnus-article-annotations
252 (nconc gnus-article-annotations 254 (nconc gnus-article-annotations
253 (list 255 (list
254 (make-annotation "@" (point) 'text nil nil nil t))))) 256 (make-annotation "@" (point) 'text nil nil nil t)))))
255 257
256 ;; then do user directories, 258 ;; then do user directories,
257 (let (found) 259 (let (found)
258 (setq databases gnus-picons-user-directories) 260 (setq databases gnus-picons-user-directories)
259 (setq username (downcase username)) 261 (setq username (downcase username))
260 (while databases 262 (while databases
261 (setq found 263 (setq found
262 (nconc (gnus-picons-insert-face-if-exists 264 (nconc (gnus-picons-insert-face-if-exists
263 (car databases) addrs username 265 (car databases) addrs username
264 (or gnus-picons-display-as-address 266 (or gnus-picons-display-as-address
265 gnus-article-annotations) nil t) 267 gnus-article-annotations) nil t)
266 found)) 268 found))
267 (setq databases (cdr databases))) 269 (setq databases (cdr databases)))
268 ;; add their name if no face exists 270 ;; add their name if no face exists
269 (when (and gnus-picons-display-as-address (not found)) 271 (when (and gnus-picons-display-as-address (not found))
270 (setq found 272 (setq found
271 (list 273 (list
272 (make-annotation username (point) 'text nil nil nil t)))) 274 (make-annotation username (point) 'text nil nil nil t))))
273 (setq gnus-article-annotations 275 (setq gnus-article-annotations
274 (nconc found gnus-article-annotations))) 276 (nconc found gnus-article-annotations)))
275 277
276 (add-hook 'gnus-summary-exit-hook 'gnus-picons-remove-all)))))) 278 (add-hook 'gnus-summary-exit-hook 'gnus-picons-remove-all))))))
277 279
278 (defun gnus-group-display-picons () 280 (defun gnus-group-display-picons ()
279 "Display icons for the group in the gnus-picons-display-where buffer." 281 "Display icons for the group in the gnus-picons-display-where buffer."
280 (interactive) 282 (interactive)
281 ;; let display catch up so far 283 ;; let display catch up so far
282 (when gnus-picons-refresh-before-display 284 (when gnus-picons-refresh-before-display
283 (sit-for 0)) 285 (sit-for 0))
284 (when (and (featurep 'xpm) 286 (when (and (featurep 'xpm)
324 nobar-p dots rightp) 326 nobar-p dots rightp)
325 "Inserts a face at point if I can find one" 327 "Inserts a face at point if I can find one"
326 ;; '(gnus-picons-insert-face-if-exists 328 ;; '(gnus-picons-insert-face-if-exists
327 ;; "Database" '("edu" "indiana" "cs") "Name") 329 ;; "Database" '("edu" "indiana" "cs") "Name")
328 ;; looks for: 330 ;; looks for:
329 ;; 1. edu/indiana/cs/Name 331 ;; 1. edu/indiana/cs/Name
330 ;; 2. edu/indiana/Name 332 ;; 2. edu/indiana/Name
331 ;; 3. edu/Name 333 ;; 3. edu/Name
332 ;; '(gnus-picons-insert-face-if-exists 334 ;; '(gnus-picons-insert-face-if-exists
333 ;; "Database/MISC" '("edu" "indiana" "cs") "Name") 335 ;; "Database/MISC" '("edu" "indiana" "cs") "Name")
334 ;; looks for: 336 ;; looks for:
335 ;; 1. MISC/Name 337 ;; 1. MISC/Name
336 ;; The special treatment of MISC doesn't conform with the conventions for 338 ;; The special treatment of MISC doesn't conform with the conventions for
337 ;; picon databases, but otherwise we would always see the MISC/unknown face. 339 ;; picon databases, but otherwise we would always see the MISC/unknown face.
338 (let ((bar (and (not nobar-p) 340 (let ((bar (and (not nobar-p)
339 (or gnus-picons-display-as-address 341 (or gnus-picons-display-as-address
340 (annotations-in-region 342 (annotations-in-region
341 (point) (min (point-max) (1+ (point))) 343 (point) (min (point-max) (1+ (point)))
342 (current-buffer))))) 344 (current-buffer)))))
343 (path (concat (file-name-as-directory gnus-picons-database) 345 (path (concat (file-name-as-directory gnus-picons-database)
344 database "/")) 346 database "/"))
345 (domainp (and gnus-picons-display-as-address dots)) 347 (domainp (and gnus-picons-display-as-address dots))
348 (setq addrs '(""))) 350 (setq addrs '("")))
349 (while (and addrs 351 (while (and addrs
350 (file-accessible-directory-p path)) 352 (file-accessible-directory-p path))
351 (setq cur (pop addrs) 353 (setq cur (pop addrs)
352 path (concat path cur "/")) 354 path (concat path cur "/"))
353 (if (setq found 355 (if (setq found
354 (gnus-picons-try-suffixes (concat path filename "/face."))) 356 (gnus-picons-try-suffixes (concat path filename "/face.")))
355 (progn 357 (progn
356 (setq picons (nconc (when (and domainp first rightp) 358 (setq picons (nconc (when (and domainp first rightp)
357 (list (make-annotation 359 (list (make-annotation
358 "." (point) 'text 360 "." (point) 'text
359 nil nil nil rightp) 361 nil nil nil rightp)
360 picons)) 362 picons))
361 (gnus-picons-try-to-find-face 363 (gnus-picons-try-to-find-face
362 found nil (if domainp cur filename) rightp) 364 found nil (if domainp cur filename) rightp)
363 (when (and domainp first (not rightp)) 365 (when (and domainp first (not rightp))
364 (list (make-annotation 366 (list (make-annotation
365 "." (point) 'text 367 "." (point) 'text
366 nil nil nil rightp) 368 nil nil nil rightp)
367 picons)) 369 picons))
368 picons))) 370 picons)))
369 (when domainp 371 (when domainp
370 (setq picons 372 (setq picons
371 (nconc (list (make-annotation 373 (nconc (list (make-annotation
372 (if first (concat (if (not rightp) ".") cur 374 (if first (concat (if (not rightp) ".") cur
373 (if rightp ".")) cur) 375 (if rightp ".")) cur)
374 (point) 'text nil nil nil rightp)) 376 (point) 'text nil nil nil rightp))
375 picons)))) 377 picons))))
376 (when (and bar (or domainp found)) 378 (when (and bar (or domainp found))
377 (setq bar-ann (gnus-picons-try-to-find-face 379 (setq bar-ann (gnus-picons-try-to-find-face
378 (concat gnus-xmas-glyph-directory "bar.xbm") 380 (concat gnus-xmas-glyph-directory "bar.xbm")
379 nil nil t)) 381 nil nil t))
380 (when bar-ann 382 (when bar-ann
381 (setq picons (nconc picons bar-ann)) 383 (setq picons (nconc picons bar-ann))
382 (setq bar nil))) 384 (setq bar nil)))
383 (setq first t)) 385 (setq first t))
384 (when (and addrs domainp) 386 (when (and addrs domainp)
385 (let ((it (mapconcat 'downcase (nreverse addrs) "."))) 387 (let ((it (mapconcat 'downcase (nreverse addrs) ".")))
386 (make-annotation 388 (make-annotation
387 (if first (concat (if (not rightp) ".") it (if rightp ".")) it) 389 (if first (concat (if (not rightp) ".") it (if rightp ".")) it)
388 (point) 'text nil nil nil rightp))) 390 (point) 'text nil nil nil rightp)))
389 picons)) 391 picons))
390 392
391 (defvar gnus-picons-glyph-alist nil) 393 (defvar gnus-picons-glyph-alist nil)
392 394
393 (defun gnus-picons-try-to-find-face (path &optional xface-p part rightp) 395 (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." 396 "If PATH exists, display it as a bitmap. Returns t if succeeded."
395 (let ((glyph (and (not xface-p) 397 (let ((glyph (and (not xface-p)
396 (cdr (assoc path gnus-picons-glyph-alist))))) 398 (cdr (assoc path gnus-picons-glyph-alist)))))
397 (when (or glyph (file-exists-p path)) 399 (when (or glyph (file-exists-p path))