Mercurial > hg > xemacs-beta

comparison lisp/gnus/gnus-picon.el @ 98:0d2f883870bc r20-1b1

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r20-1b1
author cvs
date Mon, 13 Aug 2007 09:13:56 +0200
parents 131b0175ea99
children cf808b4c4290
comparison
equal deleted inserted replaced
97:498bf5da1c90 98:0d2f883870bc
1 ;;; gnus-picon.el --- displaying pretty icons in Gnus 1 ;;; gnus-picon.el --- displaying pretty icons in Gnus
2 ;; Copyright (C) 1996 Free Software Foundation, Inc. 2 ;; Copyright (C) 1996,97 Free Software Foundation, Inc.
3 3
4 ;; Author: Wes Hardaker <hardaker@ece.ucdavis.edu> 4 ;; Author: Wes Hardaker <hardaker@ece.ucdavis.edu>
5 ;; Keywords: news xpm annotation glyph faces 5 ;; Keywords: news xpm annotation glyph faces
6 6
7 ;; This file is part of GNU Emacs. 7 ;; This file is part of GNU Emacs.
21 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, 21 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
22 ;; Boston, MA 02111-1307, USA. 22 ;; Boston, MA 02111-1307, USA.
23 23
24 ;;; Commentary: 24 ;;; Commentary:
25 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: 26 ;;; Code:
76 27
28 (require 'gnus)
77 (require 'xpm) 29 (require 'xpm)
78 (require 'annotations) 30 (require 'annotations)
79 (eval-when-compile (require 'cl)) 31 (require 'custom)
80 32
81 (defvar gnus-picons-buffer "*Icon Buffer*" 33 (defgroup picons nil
82 "Buffer name to display the icons in if gnus-picons-display-where is 'picons.") 34 "Show pictures of people, domains, and newsgroups (XEmacs).
83 35 For this to work, you must add gnus-group-display-picons to the
84 (defvar gnus-picons-display-where 'picons 36 gnus-summary-display-hook or to the gnus-article-display-hook
85 "Where to display the group and article icons.") 37 depending on what gnus-picons-display-where is set to. You must
86 38 also add gnus-article-display-picons to gnus-article-display-hook."
87 (defvar gnus-picons-database "/usr/local/faces" 39 :group 'gnus-visual)
40
41 (defcustom gnus-picons-buffer "*Icon Buffer*"
42 "Buffer name to display the icons in if gnus-picons-display-where is 'picons."
43 :type 'string
44 :group 'picons)
45
46 (defcustom gnus-picons-display-where 'picons
47 "Where to display the group and article icons."
48 :type '(choice symbol string)
49 :group 'picons)
50
51 (defcustom gnus-picons-database "/usr/local/faces"
88 "Defines the location of the faces database. 52 "Defines the location of the faces database.
89 For information on obtaining this database of pretty pictures, please 53 For information on obtaining this database of pretty pictures, please
90 see http://www.cs.indiana.edu/picons/ftp/index.html" ) 54 see http://www.cs.indiana.edu/picons/ftp/index.html"
91 55 :type 'directory
92 (defvar gnus-picons-news-directory "news" 56 :group 'picons)
57
58 (defcustom gnus-picons-news-directory "news"
93 "Sub-directory of the faces database containing the icons for newsgroups." 59 "Sub-directory of the faces database containing the icons for newsgroups."
94 ) 60 :type 'string
95 61 :group 'picons)
96 (defvar gnus-picons-user-directories '("local" "users" "usenix" "misc/MISC") 62
63 (defcustom gnus-picons-user-directories '("local" "users" "usenix" "misc/MISC")
97 "List of directories to search for user faces." 64 "List of directories to search for user faces."
98 ) 65 :type '(repeat string)
99 66 :group 'picons)
100 (defvar gnus-picons-domain-directories '("domains") 67
68 (defcustom gnus-picons-domain-directories '("domains")
101 "List of directories to search for domain faces. 69 "List of directories to search for domain faces.
102 Some people may want to add \"unknown\" to this list." 70 Some people may want to add \"unknown\" to this list."
103 ) 71 :type '(repeat string)
104 72 :group 'picons)
105 (defvar gnus-picons-x-face-file-name 73
74 (defcustom gnus-picons-refresh-before-display nil
75 "If non-nil, display the article buffer before computing the picons."
76 :type 'boolean
77 :group 'picons)
78
79 (defcustom gnus-picons-x-face-file-name
106 (format "/tmp/picon-xface.%s.xbm" (user-login-name)) 80 (format "/tmp/picon-xface.%s.xbm" (user-login-name))
107 "The name of the file in which to store the converted X-face header.") 81 "The name of the file in which to store the converted X-face header."
108 82 :type 'string
109 (defvar gnus-picons-convert-x-face (format "{ echo '/* Width=48, Height=48 */'; uncompface; } | icontopbm | pbmtoxbm > %s" gnus-picons-x-face-file-name) 83 :group 'picons)
84
85 (defcustom 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." 86 "Command to convert the x-face header into a xbm file."
111 ) 87 :type 'string
112 88 :group 'picons)
113 (defvar gnus-picons-file-suffixes 89
90 (defcustom gnus-picons-display-as-address t
91 "*If t display textual email addresses along with pictures."
92 :type 'boolean
93 :group 'picons)
94
95 (defcustom gnus-picons-file-suffixes
114 (when (featurep 'x) 96 (when (featurep 'x)
115 (let ((types (list "xbm"))) 97 (let ((types (list "xbm")))
116 (when (featurep 'gif) 98 (when (featurep 'gif)
117 (push "gif" types)) 99 (push "gif" types))
118 (when (featurep 'xpm) 100 (when (featurep 'xpm)
119 (push "xpm" types)) 101 (push "xpm" types))
120 types)) 102 types))
121 "List of suffixes on picon file names to try.") 103 "List of suffixes on picon file names to try."
122 104 :type '(repeat string)
123 (defvar gnus-picons-display-article-move-p t 105 :group 'picons)
106
107 (defcustom gnus-picons-display-article-move-p t
124 "*Whether to move point to first empty line when displaying picons. 108 "*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.") 109 This has only an effect if `gnus-picons-display-where' hs value article."
110 :type 'boolean
111 :group 'picons)
112
113 (defvar gnus-picons-map (make-sparse-keymap "gnus-picons-keys")
114 "keymap to hide/show picon glyphs")
115
116 (define-key gnus-picons-map [(button2)] 'gnus-picons-toggle-extent)
126 117
127 ;;; Internal variables. 118 ;;; Internal variables.
128 119
129 (defvar gnus-group-annotations nil) 120 (defvar gnus-group-annotations nil)
130 (defvar gnus-article-annotations nil) 121 (defvar gnus-article-annotations nil)
131 (defvar gnus-x-face-annotations nil) 122 (defvar gnus-x-face-annotations nil)
132 123
133 (defun gnus-picons-remove (plist) 124 (defun gnus-picons-remove (plist)
134 (let ((listitem (car plist))) 125 (let ((listitem (car plist)))
135 (while (setq listitem (car plist)) 126 (while (setq listitem (car plist))
136 (if (annotationp listitem) 127 (when (annotationp listitem)
137 (delete-annotation listitem)) 128 (delete-annotation listitem))
138 (setq plist (cdr plist)))) 129 (setq plist (cdr plist)))))
139 )
140 130
141 (defun gnus-picons-remove-all () 131 (defun gnus-picons-remove-all ()
142 "Removes all picons from the Gnus display(s)." 132 "Removes all picons from the Gnus display(s)."
143 (interactive) 133 (interactive)
144 (gnus-picons-remove gnus-article-annotations) 134 (gnus-picons-remove gnus-article-annotations)
145 (gnus-picons-remove gnus-group-annotations) 135 (gnus-picons-remove gnus-group-annotations)
146 (gnus-picons-remove gnus-x-face-annotations) 136 (gnus-picons-remove gnus-x-face-annotations)
147 (setq gnus-article-annotations nil 137 (setq gnus-article-annotations nil
148 gnus-group-annotations nil 138 gnus-group-annotations nil
149 gnus-x-face-annotations nil) 139 gnus-x-face-annotations nil)
150 (if (bufferp gnus-picons-buffer) 140 (when (bufferp gnus-picons-buffer)
151 (kill-buffer gnus-picons-buffer)) 141 (kill-buffer gnus-picons-buffer)))
152 )
153 142
154 (defun gnus-get-buffer-name (variable) 143 (defun gnus-get-buffer-name (variable)
155 "Returns the buffer name associated with the contents of a variable." 144 "Returns the buffer name associated with the contents of a variable."
156 (cond ((symbolp variable) 145 (cond ((symbolp variable)
157 (let ((newvar (cdr (assq variable gnus-window-to-buffer)))) 146 (let ((newvar (cdr (assq variable gnus-window-to-buffer))))
205 (delete-file gnus-picons-x-face-file-name))) 194 (delete-file gnus-picons-x-face-file-name)))
206 195
207 (defun gnus-article-display-picons () 196 (defun gnus-article-display-picons ()
208 "Display faces for an author and his/her domain in gnus-picons-display-where." 197 "Display faces for an author and his/her domain in gnus-picons-display-where."
209 (interactive) 198 (interactive)
210 (let (from at-idx databases) 199 ;; let drawing catch up
211 (when (and (featurep 'xpm) 200 (when gnus-picons-refresh-before-display
201 (sit-for 0))
202 (let ((first t)
203 from at-idx databases)
204 (when (and (featurep 'xpm)
212 (or (not (fboundp 'device-type)) (equal (device-type) 'x)) 205 (or (not (fboundp 'device-type)) (equal (device-type) 'x))
213 (setq from (mail-fetch-field "from")) 206 (setq from (mail-fetch-field "from"))
214 (setq from (downcase (or (cadr (mail-extract-address-components 207 (setq from (downcase
215 from)) 208 (or (cadr (mail-extract-address-components from))
216 "")) 209 "")))
217 at-idx (string-match "@" from))) 210 (or (setq at-idx (string-match "@" from))
211 (setq at-idx (length from))))
218 (save-excursion 212 (save-excursion
219 (let ((username (substring from 0 at-idx)) 213 (let ((username (substring from 0 at-idx))
220 (addrs (nreverse 214 (addrs (if (eq at-idx (length from))
221 (message-tokenize-header (substring from (1+ at-idx)) 215 (if gnus-local-domain
222 ".")))) 216 (nreverse (message-tokenize-header
217 gnus-local-domain "."))
218 '(""))
219 (nreverse (message-tokenize-header
220 (substring from (1+ at-idx)) ".")))))
223 (set-buffer (get-buffer-create 221 (set-buffer (get-buffer-create
224 (gnus-get-buffer-name gnus-picons-display-where))) 222 (gnus-get-buffer-name gnus-picons-display-where)))
225 (gnus-add-current-to-buffer-list) 223 (gnus-add-current-to-buffer-list)
226 (goto-char (point-min)) 224 (goto-char (point-min))
227 (if (and (eq gnus-picons-display-where 'article) 225 (if (and (eq gnus-picons-display-where 'article)
233 gnus-article-annotations))) 231 gnus-article-annotations)))
234 232
235 (gnus-picons-remove gnus-article-annotations) 233 (gnus-picons-remove gnus-article-annotations)
236 (setq gnus-article-annotations nil) 234 (setq gnus-article-annotations nil)
237 235
238 (setq databases (append gnus-picons-user-directories 236 ;; look for domain paths.
239 gnus-picons-domain-directories)) 237 (setq databases gnus-picons-domain-directories)
240 (while databases 238 (while databases
241 (setq gnus-article-annotations 239 (setq gnus-article-annotations
242 (nconc (gnus-picons-insert-face-if-exists 240 (nconc (gnus-picons-insert-face-if-exists
243 (car databases) 241 (car databases)
244 addrs 242 addrs
245 "unknown") 243 "unknown" (or gnus-picons-display-as-address
246 (gnus-picons-insert-face-if-exists 244 gnus-article-annotations) t t)
247 (car databases)
248 addrs
249 (downcase username) t)
250 gnus-article-annotations)) 245 gnus-article-annotations))
251 (setq databases (cdr databases))) 246 (setq databases (cdr databases)))
247
248 ;; add an '@' if displaying as address
249 (when gnus-picons-display-as-address
250 (setq gnus-article-annotations
251 (nconc gnus-article-annotations
252 (list
253 (make-annotation "@" (point) 'text nil nil nil t)))))
254
255 ;; then do user directories,
256 (let (found)
257 (setq databases gnus-picons-user-directories)
258 (setq username (downcase username))
259 (while databases
260 (setq found
261 (nconc (gnus-picons-insert-face-if-exists
262 (car databases) addrs username
263 (or gnus-picons-display-as-address
264 gnus-article-annotations) nil t)
265 found))
266 (setq databases (cdr databases)))
267 ;; add their name if no face exists
268 (when (and gnus-picons-display-as-address (not found))
269 (setq found
270 (list
271 (make-annotation username (point) 'text nil nil nil t))))
272 (setq gnus-article-annotations
273 (nconc found gnus-article-annotations)))
274
252 (add-hook 'gnus-summary-exit-hook 'gnus-picons-remove-all)))))) 275 (add-hook 'gnus-summary-exit-hook 'gnus-picons-remove-all))))))
253 276
254 (defun gnus-group-display-picons () 277 (defun gnus-group-display-picons ()
255 "Display icons for the group in the gnus-picons-display-where buffer." 278 "Display icons for the group in the gnus-picons-display-where buffer."
256 (interactive) 279 (interactive)
257 (when (and (featurep 'xpm) 280 ;; let display catch up so far
281 (when gnus-picons-refresh-before-display
282 (sit-for 0))
283 (when (and (featurep 'xpm)
258 (or (not (fboundp 'device-type)) (equal (device-type) 'x))) 284 (or (not (fboundp 'device-type)) (equal (device-type) 'x)))
259 (save-excursion 285 (save-excursion
260 (set-buffer (get-buffer-create 286 (set-buffer (get-buffer-create
261 (gnus-get-buffer-name gnus-picons-display-where))) 287 (gnus-get-buffer-name gnus-picons-display-where)))
262 (gnus-add-current-to-buffer-list) 288 (gnus-add-current-to-buffer-list)
263 (goto-char (point-min)) 289 (goto-char (point-min))
264 (if (and (eq gnus-picons-display-where 'article) 290 (if (and (eq gnus-picons-display-where 'article)
265 gnus-picons-display-article-move-p) 291 gnus-picons-display-article-move-p)
266 (if (search-forward "\n\n" nil t) 292 (when (search-forward "\n\n" nil t)
267 (forward-line -1)) 293 (forward-line -1))
268 (unless (eolp) 294 (unless (eolp)
269 (push (make-annotation "\n" (point) 'text) 295 (push (make-annotation "\n" (point) 'text)
270 gnus-group-annotations))) 296 gnus-group-annotations)))
271 (cond 297 (cond
272 ((listp gnus-group-annotations) 298 ((listp gnus-group-annotations)
273 (mapcar 'delete-annotation gnus-group-annotations) 299 (mapc #'(lambda (ext) (when (extent-live-p ext)
300 (delete-annotation ext)))
301 gnus-group-annotations)
274 (setq gnus-group-annotations nil)) 302 (setq gnus-group-annotations nil))
275 ((annotationp gnus-group-annotations) 303 ((annotationp gnus-group-annotations)
276 (delete-annotation gnus-group-annotations) 304 (delete-annotation gnus-group-annotations)
277 (setq gnus-group-annotations nil))) 305 (setq gnus-group-annotations nil)))
278 (gnus-picons-remove gnus-group-annotations) 306 (gnus-picons-remove gnus-group-annotations)
279 (setq gnus-group-annotations 307 (setq gnus-group-annotations
280 (gnus-picons-insert-face-if-exists 308 (gnus-picons-insert-face-if-exists
281 gnus-picons-news-directory 309 gnus-picons-news-directory
282 (message-tokenize-header gnus-newsgroup-name ".") 310 (message-tokenize-header gnus-newsgroup-name ".")
283 "unknown")) 311 "unknown" nil t))
284 (add-hook 'gnus-summary-exit-hook 'gnus-picons-remove-all)))) 312 (add-hook 'gnus-summary-exit-hook 'gnus-picons-remove-all))))
285 313
286 (defsubst gnus-picons-try-suffixes (file) 314 (defsubst gnus-picons-try-suffixes (file)
287 (let ((suffixes gnus-picons-file-suffixes) 315 (let ((suffixes gnus-picons-file-suffixes)
288 f) 316 f)
290 (not (file-exists-p (setq f (concat file (pop suffixes)))))) 318 (not (file-exists-p (setq f (concat file (pop suffixes))))))
291 (setq f nil)) 319 (setq f nil))
292 f)) 320 f))
293 321
294 (defun gnus-picons-insert-face-if-exists (database addrs filename &optional 322 (defun gnus-picons-insert-face-if-exists (database addrs filename &optional
295 nobar-p) 323 nobar-p dots rightp)
296 "Inserts a face at point if I can find one" 324 "Inserts a face at point if I can find one"
297 ;; '(gnus-picons-insert-face-if-exists 325 ;; '(gnus-picons-insert-face-if-exists
298 ; "Database" '("edu" "indiana" "cs") "Name") 326 ;; "Database" '("edu" "indiana" "cs") "Name")
299 ;; looks for: 327 ;; looks for:
300 ;; 1. edu/indiana/cs/Name 328 ;; 1. edu/indiana/cs/Name
301 ;; 2. edu/indiana/Name 329 ;; 2. edu/indiana/Name
302 ;; 3. edu/Name 330 ;; 3. edu/Name
303 ;; '(gnus-picons-insert-face-if-exists 331 ;; '(gnus-picons-insert-face-if-exists
305 ;; looks for: 333 ;; looks for:
306 ;; 1. MISC/Name 334 ;; 1. MISC/Name
307 ;; The special treatment of MISC doesn't conform with the conventions for 335 ;; The special treatment of MISC doesn't conform with the conventions for
308 ;; picon databases, but otherwise we would always see the MISC/unknown face. 336 ;; picon databases, but otherwise we would always see the MISC/unknown face.
309 (let ((bar (and (not nobar-p) 337 (let ((bar (and (not nobar-p)
310 (annotations-in-region 338 (or gnus-picons-display-as-address
311 (point) (min (point-max) (1+ (point))) 339 (annotations-in-region
312 (current-buffer)))) 340 (point) (min (point-max) (1+ (point)))
341 (current-buffer)))))
313 (path (concat (file-name-as-directory gnus-picons-database) 342 (path (concat (file-name-as-directory gnus-picons-database)
314 database "/")) 343 database "/"))
315 picons found bar-ann) 344 (domainp (and gnus-picons-display-as-address dots))
316 (if (string-match "/MISC" database) 345 picons found bar-ann cur first)
317 (setq addrs '(""))) 346 (when (string-match "/MISC" database)
347 (setq addrs '("")))
318 (while (and addrs 348 (while (and addrs
319 (file-accessible-directory-p path)) 349 (file-accessible-directory-p path))
320 (setq path (concat path (pop addrs) "/")) 350 (setq cur (pop addrs)
321 (when (setq found 351 path (concat path cur "/"))
322 (gnus-picons-try-suffixes 352 (if (setq found
323 (concat path filename "/face."))) 353 (gnus-picons-try-suffixes (concat path filename "/face.")))
324 (when bar 354 (progn
325 (setq bar-ann (gnus-picons-try-to-find-face 355 (setq picons (nconc (when (and domainp first rightp)
326 (concat gnus-xmas-glyph-directory "bar.xbm"))) 356 (list (make-annotation
327 (when bar-ann 357 "." (point) 'text
328 (setq picons (nconc picons bar-ann)) 358 nil nil nil rightp)
329 (setq bar nil))) 359 picons))
330 (setq picons (nconc (gnus-picons-try-to-find-face found) 360 (gnus-picons-try-to-find-face
331 picons)))) 361 found nil (if domainp cur filename) rightp)
332 (nreverse picons))) 362 (when (and domainp first (not rightp))
363 (list (make-annotation
364 "." (point) 'text
365 nil nil nil rightp)
366 picons))
367 picons)))
368 (when domainp
369 (setq picons
370 (nconc (list (make-annotation
371 (if first (concat (if (not rightp) ".") cur
372 (if rightp ".")) cur)
373 (point) 'text nil nil nil rightp))
374 picons))))
375 (when (and bar (or domainp found))
376 (setq bar-ann (gnus-picons-try-to-find-face
377 (concat gnus-xmas-glyph-directory "bar.xbm")
378 nil nil t))
379 (when bar-ann
380 (setq picons (nconc picons bar-ann))
381 (setq bar nil)))
382 (setq first t))
383 (when (and addrs domainp)
384 (let ((it (mapconcat 'downcase (nreverse addrs) ".")))
385 (make-annotation
386 (if first (concat (if (not rightp) ".") it (if rightp ".")) it)
387 (point) 'text nil nil nil rightp)))
388 picons))
333 389
334 (defvar gnus-picons-glyph-alist nil) 390 (defvar gnus-picons-glyph-alist nil)
335 391
336 (defun gnus-picons-try-to-find-face (path &optional xface-p) 392 (defun gnus-picons-try-to-find-face (path &optional xface-p part rightp)
337 "If PATH exists, display it as a bitmap. Returns t if succedded." 393 "If PATH exists, display it as a bitmap. Returns t if succeeded."
338 (let ((glyph (and (not xface-p) 394 (let ((glyph (and (not xface-p)
339 (cdr (assoc path gnus-picons-glyph-alist))))) 395 (cdr (assoc path gnus-picons-glyph-alist)))))
340 (when (or glyph (file-exists-p path)) 396 (when (or glyph (file-exists-p path))
341 (unless glyph 397 (unless glyph
342 (setq glyph (make-glyph path)) 398 (setq glyph (make-glyph path))
343 (unless xface-p 399 (unless xface-p
344 (push (cons path glyph) gnus-picons-glyph-alist)) 400 (push (cons path glyph) gnus-picons-glyph-alist))
345 (set-glyph-face glyph 'default)) 401 (set-glyph-face glyph 'default))
346 (nconc 402 (let ((new (make-annotation glyph (point) 'text nil nil nil rightp)))
347 (list (make-annotation glyph (point) 'text)) 403 (nconc
348 (when (eq major-mode 'gnus-article-mode) 404 (list new)
349 (list (make-annotation " " (point) 'text))))))) 405 (when (and (eq major-mode 'gnus-article-mode)
406 (not gnus-picons-display-as-address)
407 (not part))
408 (list (make-annotation " " (point) 'text nil nil nil rightp)))
409 (when (and part gnus-picons-display-as-address)
410 (let ((txt (make-annotation part (point) 'text nil nil nil rightp)))
411 (hide-annotation txt)
412 (set-extent-property txt 'its-partner new)
413 (set-extent-property txt 'keymap gnus-picons-map)
414 (set-extent-property txt 'mouse-face gnus-article-mouse-face)
415 (set-extent-property new 'its-partner txt)
416 (set-extent-property new 'keymap gnus-picons-map))))))))
350 417
351 (defun gnus-picons-reverse-domain-path (str) 418 (defun gnus-picons-reverse-domain-path (str)
352 "a/b/c/d -> d/c/b/a" 419 "a/b/c/d -> d/c/b/a"
353 (mapconcat 'downcase (nreverse (message-tokenize-header str "/")) "/")) 420 (mapconcat 'downcase (nreverse (message-tokenize-header str "/")) "/"))
354 421
422 (defun gnus-picons-toggle-extent (event)
423 "Toggle picon glyph at given point"
424 (interactive "e")
425 (let* ((ant1 (event-glyph-extent event))
426 (ant2 (extent-property ant1 'its-partner)))
427 (when (and (annotationp ant1) (annotationp ant2))
428 (reveal-annotation ant2)
429 (hide-annotation ant1))))
430
355 (gnus-add-shutdown 'gnus-picons-close 'gnus) 431 (gnus-add-shutdown 'gnus-picons-close 'gnus)
356 432
357 (defun gnus-picons-close () 433 (defun gnus-picons-close ()
358 "Shut down the picons." 434 "Shut down the picons."
359 (setq gnus-picons-glyph-alist nil)) 435 (setq gnus-picons-glyph-alist nil))