Mercurial > hg > xemacs-beta

comparison lisp/gnus/gnus-picon.el @ 142:1856695b1fa9 r20-2b5

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r20-2b5
author cvs
date Mon, 13 Aug 2007 09:33:18 +0200
parents 585fb297b004
children 59463afc5666
comparison
equal deleted inserted replaced
141:ea67ad3963dc 142:1856695b1fa9
20 ;; along with GNU Emacs; see the file COPYING. If not, write to the 20 ;; along with GNU Emacs; see the file COPYING. If not, write to the
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
26 ;;; TODO:
27 ;; See the comment in gnus-picons-remove
25 28
26 ;;; Code: 29 ;;; Code:
27 30
28 (require 'gnus) 31 (require 'gnus)
29 (require 'xpm) 32 (require 'xpm)
30 (require 'annotations) 33 (require 'annotations)
31 (require 'custom) 34 (require 'custom)
32 (require 'gnus-art) 35 (require 'gnus-art)
33 (require 'gnus-win) 36 (require 'gnus-win)
37
38 ;;; User variables:
34 39
35 (defgroup picons nil 40 (defgroup picons nil
36 "Show pictures of people, domains, and newsgroups (XEmacs). 41 "Show pictures of people, domains, and newsgroups (XEmacs).
37 For this to work, you must add gnus-group-display-picons to the 42 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 43 gnus-summary-display-hook or to the gnus-article-display-hook
111 "*Whether to move point to first empty line when displaying picons. 116 "*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'." 117 This has only an effect if `gnus-picons-display-where' has value `article'."
113 :type 'boolean 118 :type 'boolean
114 :group 'picons) 119 :group 'picons)
115 120
116 (defvar gnus-picons-map (make-sparse-keymap "gnus-picons-keys") 121 (defcustom gnus-picons-clear-cache-on-shutdown t
117 "keymap to hide/show picon glyphs") 122 "*Whether to clear the picons cache when exiting gnus.
118 123 Gnus caches every picons it finds while it is running. This saves
119 (define-key gnus-picons-map [(button2)] 'gnus-picons-toggle-extent) 124 some time in the search process but eats some memory. If this
120 125 variable is set to nil, Gnus will never clear the cache itself; you
121 ;;; Internal variables. 126 will have to manually call `gnus-picons-clear-cache' to clear it.
127 Otherwise the cache will be cleared every time you exit Gnus."
128 :type 'boolean
129 :group 'picons)
130
131 (defcustom gnus-picons-piconsearch-url nil
132 "*The url to query for picons. Setting this to nil will disable it.
133 The only plublicly available address currently known is
134 http://www.cs.indiana.edu:800/piconsearch. If you know of any other,
135 please tell me so that we can list it."
136 :type '(choice (const :tag "Disable" :value nil)
137 (const :tag "www.cs.indiana.edu"
138 :value "http://www.cs.indiana.edu:800/piconsearch")
139 (string))
140 :group 'picons)
141
142 ;;; Internal variables:
143
144 (defvar gnus-picons-processes-alist nil
145 "Picons processes currently running and their environment.")
146 (defvar gnus-picons-glyph-alist nil
147 "Picons glyphs cache.
148 List of pairs (KEY . GLYPH) where KEY is either a filename or an URL.")
149 (defvar gnus-picons-url-alist nil
150 "Picons file names cache.
151 List of pairs (KEY . NAME) where KEY is (USER HOST DBS) and NAME is an URL.")
122 152
123 (defvar gnus-group-annotations nil 153 (defvar gnus-group-annotations nil
124 "List of annotations added/removed when selecting/exiting a group") 154 "List of annotations added/removed when selecting/exiting a group")
155 (defvar gnus-group-annotations-lock nil)
125 (defvar gnus-article-annotations nil 156 (defvar gnus-article-annotations nil
126 "List of annotations added/removed when selecting an article") 157 "List of annotations added/removed when selecting an article")
158 (defvar gnus-article-annotations-lock nil)
127 (defvar gnus-x-face-annotations nil 159 (defvar gnus-x-face-annotations nil
128 "List of annotations added/removed when selecting an article with an X-Face.") 160 "List of annotations added/removed when selecting an article with an
161 X-Face.")
162 (defvar gnus-x-face-annotations-lock nil)
163
164 (defvar gnus-picons-jobs-alist nil
165 "List of jobs that still need be done.
166 This is a list of (SYM-ANN TAG ARGS...) where SYM-ANN three annotations list,
167 TAG is one of `picon' or `search' indicating that the job should query a
168 picon or do a search for picons file names, and ARGS is some additionnal
169 arguments necessary for the job.")
170
171 (defvar gnus-picons-job-already-running nil
172 "Lock to ensure only one stream of http requests is running.")
173
174 ;;; Functions:
175
176 (defsubst gnus-picons-lock (symbol)
177 (intern (concat (symbol-name symbol) "-lock")))
129 178
130 (defun gnus-picons-remove (symbol) 179 (defun gnus-picons-remove (symbol)
131 "Remove all annotations/processes in variable named SYMBOL. 180 "Remove all annotations in variable named SYMBOL.
132 This function is careful to set it to nil before removing anything so that 181 This function is careful to set it to nil before removing anything so that
133 asynchronous process don't get crazy." 182 asynchronous process don't get crazy."
134 (let ((listitems (symbol-value symbol))) 183 ;; clear the lock
135 (set symbol nil) 184 (set (gnus-picons-lock symbol) nil)
136 (while listitems 185 ;; clear all annotations
137 (let ((item (pop listitems))) 186 (mapc (function (lambda (item)
138 (cond ((annotationp item) 187 (if (annotationp item)
139 (delete-annotation item)) 188 (delete-annotation item))))
140 ((processp item) 189 (prog1 (symbol-value symbol)
141 ;; kill the process, ignore any output. 190 (set symbol nil)))
142 (set-process-sentinel item (function (lambda (p e)))) 191 ;; FIXME: there's a race condition here. If a job is already
143 (delete-process item))))))) 192 ;; running, it has already removed itself from this queue... But
193 ;; will still display its picon.
194 ;; TODO: push a request to clear an annotation. Then
195 ;; gnus-picons-next-job will be able to clean up when it gets the
196 ;; hand
197 (setq gnus-picons-jobs-alist (remassq symbol gnus-picons-jobs-alist)))
144 198
145 (defun gnus-picons-remove-all () 199 (defun gnus-picons-remove-all ()
146 "Removes all picons from the Gnus display(s)." 200 "Removes all picons from the Gnus display(s)."
147 (interactive) 201 (interactive)
148 (gnus-picons-remove 'gnus-article-annotations) 202 (gnus-picons-remove 'gnus-article-annotations)
151 (when (bufferp gnus-picons-buffer) 205 (when (bufferp gnus-picons-buffer)
152 (kill-buffer gnus-picons-buffer))) 206 (kill-buffer gnus-picons-buffer)))
153 207
154 (defun gnus-get-buffer-name (variable) 208 (defun gnus-get-buffer-name (variable)
155 "Returns the buffer name associated with the contents of a variable." 209 "Returns the buffer name associated with the contents of a variable."
156 (cond ((symbolp variable) 210 (cond ((symbolp variable) (let ((newvar (cdr (assq variable
157 (let ((newvar (cdr (assq variable gnus-window-to-buffer)))) 211 gnus-window-to-buffer))))
158 (cond ((symbolp newvar) 212 (cond ((symbolp newvar)
159 (symbol-value newvar)) 213 (symbol-value newvar))
160 ((stringp newvar) newvar)))) 214 ((stringp newvar) newvar))))
161 ((stringp variable) 215 ((stringp variable) variable)))
162 variable)))
163 216
164 (defun gnus-picons-prepare-for-annotations (annotations) 217 (defun gnus-picons-prepare-for-annotations (annotations)
165 "Prepare picons buffer for puting annotations memorized in ANNOTATIONS. 218 "Prepare picons buffer for puting annotations memorized in ANNOTATIONS.
166 ANNOTATIONS should be a symbol naming a variable wich contains a list of 219 ANNOTATIONS should be a symbol naming a variable wich contains a list of
167 annotations. Sets buffer to `gnus-picons-display-where'." 220 annotations. Sets buffer to `gnus-picons-display-where'."
173 (gnus-add-current-to-buffer-list) 226 (gnus-add-current-to-buffer-list)
174 (goto-char (point-min)) 227 (goto-char (point-min))
175 (if (and (eq gnus-picons-display-where 'article) 228 (if (and (eq gnus-picons-display-where 'article)
176 gnus-picons-display-article-move-p) 229 gnus-picons-display-article-move-p)
177 (when (search-forward "\n\n" nil t) 230 (when (search-forward "\n\n" nil t)
178 (forward-line -1))) 231 (forward-line -1))
232 (make-local-variable 'inhibit-read-only)
233 (setq buffer-read-only t
234 inhibit-read-only nil))
179 (gnus-picons-remove annotations)) 235 (gnus-picons-remove annotations))
180 236
181 (defun gnus-picons-article-display-x-face () 237 (defun gnus-picons-article-display-x-face ()
182 "Display the x-face header bitmap in the 'gnus-picons-display-where buffer." 238 "Display the x-face header bitmap in the 'gnus-picons-display-where buffer."
183 ;; delete any old ones. 239 ;; delete any old ones.
187 ;; display the new one. 243 ;; display the new one.
188 (let ((gnus-article-x-face-command 'gnus-picons-display-x-face)) 244 (let ((gnus-article-x-face-command 'gnus-picons-display-x-face))
189 (gnus-article-display-x-face))) 245 (gnus-article-display-x-face)))
190 246
191 (defun gnus-picons-x-face-sentinel (process event) 247 (defun gnus-picons-x-face-sentinel (process event)
192 ;; don't call gnus-picons-prepare-for-annotations, it would reset 248 (let* ((env (assq process gnus-picons-processes-alist))
193 ;; gnus-x-face-annotations. 249 (annot (cdr env)))
194 (set-buffer (get-buffer-create 250 (setq gnus-picons-processes-alist (remassq process
195 (gnus-get-buffer-name gnus-picons-display-where))) 251 gnus-picons-processes-alist))
196 (gnus-add-current-to-buffer-list) 252 (when annot
197 (goto-char (point-min)) 253 (set-annotation-glyph annot
198 (if (and (eq gnus-picons-display-where 'article) 254 (make-glyph gnus-picons-x-face-file-name))
199 gnus-picons-display-article-move-p) 255 (if (memq annot gnus-x-face-annotations)
200 (when (search-forward "\n\n" nil t) 256 (delete-file gnus-picons-x-face-file-name)))))
201 (forward-line -1)))
202 ;; If the process is still in the list, insert this icon
203 (let ((myself (member process gnus-x-face-annotations)))
204 (when myself
205 (setcar myself
206 (make-annotation gnus-picons-x-face-file-name nil 'text))
207 (delete-file gnus-picons-x-face-file-name))))
208 257
209 (defun gnus-picons-display-x-face (beg end) 258 (defun gnus-picons-display-x-face (beg end)
210 "Function to display the x-face header in the picons window. 259 "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)" 260 To use: (setq gnus-article-x-face-command 'gnus-picons-display-x-face)"
212 (interactive) 261 (interactive)
214 ;; Use builtin support 263 ;; Use builtin support
215 (let ((buf (current-buffer))) 264 (let ((buf (current-buffer)))
216 (save-excursion 265 (save-excursion
217 (gnus-picons-prepare-for-annotations 'gnus-x-face-annotations) 266 (gnus-picons-prepare-for-annotations 'gnus-x-face-annotations)
218 (setq gnus-x-face-annotations 267 (setq gnus-x-face-annotations
219 (cons (make-annotation (concat "X-Face: " 268 (cons (make-annotation
220 (buffer-substring beg end buf)) 269 (vector 'xface
270 :data (concat "X-Face: "
271 (buffer-substring beg end buf)))
221 nil 'text) 272 nil 'text)
222 gnus-x-face-annotations)))) 273 gnus-x-face-annotations))))
223 ;; convert the x-face header to a .xbm file 274 ;; convert the x-face header to a .xbm file
224 (let* ((process-connection-type nil) 275 (let* ((process-connection-type nil)
225 (process (start-process "gnus-x-face" nil 276 (annot (save-excursion
226 shell-file-name shell-command-switch 277 (gnus-picons-prepare-for-annotations
227 gnus-picons-convert-x-face))) 278 'gnus-x-face-annotations)
279 (make-annotation nil nil 'text)))
280 (process (start-process-shell-command "gnus-x-face" nil
281 gnus-picons-convert-x-face)))
282 (push annot gnus-x-face-annotations)
283 (push (cons process annot) gnus-picons-processes-alist)
228 (process-kill-without-query process) 284 (process-kill-without-query process)
229 (setq gnus-x-face-annotations (list process))
230 (set-process-sentinel process 'gnus-picons-x-face-sentinel) 285 (set-process-sentinel process 'gnus-picons-x-face-sentinel)
231 (process-send-region process beg end) 286 (process-send-region process beg end)
232 (process-send-eof process)))) 287 (process-send-eof process))))
233 288
234 (defun gnus-article-display-picons () 289 (defun gnus-article-display-picons ()
236 (interactive) 291 (interactive)
237 (let (from at-idx) 292 (let (from at-idx)
238 (when (and (featurep 'xpm) 293 (when (and (featurep 'xpm)
239 (or (not (fboundp 'device-type)) (equal (device-type) 'x)) 294 (or (not (fboundp 'device-type)) (equal (device-type) 'x))
240 (setq from (mail-fetch-field "from")) 295 (setq from (mail-fetch-field "from"))
241 (setq from (downcase 296 (setq from (downcase (or (cadr (mail-extract-address-components
242 (or (cadr (mail-extract-address-components from)) 297 from))
243 ""))) 298 "")))
244 (or (setq at-idx (string-match "@" from)) 299 (or (setq at-idx (string-match "@" from))
245 (setq at-idx (length from)))) 300 (setq at-idx (length from))))
246 (save-excursion 301 (save-excursion
247 (let ((username (substring from 0 at-idx)) 302 (let ((username (downcase (substring from 0 at-idx)))
248 (addrs (if (eq at-idx (length from)) 303 (addrs (if (eq at-idx (length from))
249 (if gnus-local-domain 304 (if gnus-local-domain
250 (message-tokenize-header gnus-local-domain ".") 305 (message-tokenize-header gnus-local-domain "."))
251 nil)
252 (message-tokenize-header (substring from (1+ at-idx)) 306 (message-tokenize-header (substring from (1+ at-idx))
253 ".")))) 307 "."))))
254 (gnus-picons-prepare-for-annotations 'gnus-article-annotations) 308 (gnus-picons-prepare-for-annotations 'gnus-article-annotations)
255 (setq gnus-article-annotations 309 (if (null gnus-picons-piconsearch-url)
256 (nconc gnus-article-annotations 310 (setq gnus-article-annotations
257 ;; look for domain paths. 311 (nconc gnus-article-annotations
258 (gnus-picons-display-pairs 312 (gnus-picons-display-pairs
259 (gnus-picons-lookup-pairs addrs 313 (gnus-picons-lookup-pairs
260 gnus-picons-domain-directories) 314 addrs gnus-picons-domain-directories)
261 (not (or gnus-picons-display-as-address 315 (not (or gnus-picons-display-as-address
262 gnus-article-annotations)) 316 gnus-article-annotations))
263 nil "." t) 317 "." t)
264 ;; add an '@' if displaying as address 318 (if (and gnus-picons-display-as-address addrs)
265 (if (and gnus-picons-display-as-address addrs) 319 (list (make-annotation [string :data "@"] nil
266 (list (make-annotation "@" nil 'text nil nil nil t))) 320 'text nil nil nil t)))
267 ;; then do user directories, 321 (gnus-picons-display-picon-or-name
268 (gnus-picons-display-picon-or-name 322 (gnus-picons-lookup-user username addrs)
269 (gnus-picons-lookup-user (downcase username) addrs) 323 username t)))
270 username nil t))) 324 (push (list 'gnus-article-annotations 'search username addrs
325 gnus-picons-domain-directories t)
326 gnus-picons-jobs-alist)
327 (gnus-picons-next-job))
271 328
272 (add-hook 'gnus-summary-exit-hook 'gnus-picons-remove-all)))))) 329 (add-hook 'gnus-summary-exit-hook 'gnus-picons-remove-all))))))
273 330
274 (defun gnus-group-display-picons () 331 (defun gnus-group-display-picons ()
275 "Display icons for the group in the gnus-picons-display-where buffer." 332 "Display icons for the group in the gnus-picons-display-where buffer."
276 (interactive) 333 (interactive)
277 (when (and (featurep 'xpm) 334 (when (and (featurep 'xpm)
278 (or (not (fboundp 'device-type)) (equal (device-type) 'x))) 335 (or (not (fboundp 'device-type)) (equal (device-type) 'x)))
279 (save-excursion 336 (save-excursion
280 (gnus-picons-prepare-for-annotations 'gnus-group-annotations) 337 (gnus-picons-prepare-for-annotations 'gnus-group-annotations)
281 (setq gnus-group-annotations 338 (if (null gnus-picons-piconsearch-url)
282 (gnus-picons-display-pairs 339 (setq gnus-group-annotations
283 (gnus-picons-lookup-pairs (reverse (message-tokenize-header 340 (gnus-picons-display-pairs
284 gnus-newsgroup-name ".")) 341 (gnus-picons-lookup-pairs (reverse (message-tokenize-header
285 gnus-picons-news-directory) 342 gnus-newsgroup-name "."))
286 t nil ".")) 343 gnus-picons-news-directory)
344 t "."))
345 (push (list 'gnus-group-annotations 'search nil
346 (message-tokenize-header gnus-newsgroup-name ".")
347 (if (listp gnus-picons-news-directory)
348 gnus-picons-news-directory
349 (list gnus-picons-news-directory))
350 nil)
351 gnus-picons-jobs-alist)
352 (gnus-picons-next-job))
353
287 (add-hook 'gnus-summary-exit-hook 'gnus-picons-remove-all)))) 354 (add-hook 'gnus-summary-exit-hook 'gnus-picons-remove-all))))
288 355
289 (defun gnus-picons-make-path (dir subdirs) 356 (defsubst gnus-picons-lookup-internal (addrs dir)
290 "Make a directory name from a base DIR and a list of SUBDIRS. 357 (setq dir (expand-file-name dir gnus-picons-database))
291 Returns a directory name build by concatenating DIR and all elements of 358 (gnus-picons-try-face (dolist (part (reverse addrs) dir)
292 SUBDIRS with \"/\" between elements." 359 (setq dir (expand-file-name part dir)))))
293 (while subdirs
294 (setq dir (file-name-as-directory (concat dir (pop subdirs)))))
295 dir)
296
297 (defsubst gnus-picons-try-suffixes (file)
298 (let ((suffixes gnus-picons-file-suffixes)
299 f)
300 (while (and suffixes
301 (not (file-exists-p (setq f (concat file (pop suffixes))))))
302 (setq f nil))
303 f))
304 360
305 (defun gnus-picons-lookup (addrs dirs) 361 (defun gnus-picons-lookup (addrs dirs)
306 "Lookup the picon for ADDRS in databases DIRS. 362 "Lookup the picon for ADDRS in databases DIRS.
307 Returns the picon filename or NIL if none found." 363 Returns the picon filename or NIL if none found."
308 (let (result) 364 (let (result)
309 (while (and dirs (null result)) 365 (while (and dirs (null result))
310 (setq result 366 (setq result (gnus-picons-lookup-internal addrs (pop dirs))))
311 (gnus-picons-try-suffixes
312 (expand-file-name "face."
313 (gnus-picons-make-path
314 (file-name-as-directory
315 (concat
316 (file-name-as-directory gnus-picons-database)
317 (pop dirs)))
318 (reverse addrs))))))
319 result)) 367 result))
320 368
321 (defun gnus-picons-lookup-user-internal (user domains) 369 (defun gnus-picons-lookup-user-internal (user domains)
322 (let ((dirs gnus-picons-user-directories) 370 (let ((dirs gnus-picons-user-directories)
323 picon) 371 domains-tmp dir picon)
324 (while (and dirs (null picon)) 372 (while (and dirs (null picon))
325 (let ((dir (list (pop dirs))) 373 (setq domains-tmp domains
326 (domains domains)) 374 dir (pop dirs))
327 (while (and domains (null picon)) 375 (while (and domains-tmp
328 (setq picon (gnus-picons-lookup (cons user domains) dir)) 376 (null (setq picon (gnus-picons-lookup-internal
329 (pop domains)) 377 (cons user domains-tmp) dir))))
330 ;; Also make a try MISC subdir 378 (pop domains-tmp))
331 (unless picon 379 ;; Also make a try in MISC subdir
332 (setq picon (gnus-picons-lookup (list user "MISC") dir))))) 380 (unless picon
333 381 (setq picon (gnus-picons-lookup-internal (list user "MISC") dir))))
334 picon)) 382 picon))
335 383
336 (defun gnus-picons-lookup-user (user domains) 384 (defun gnus-picons-lookup-user (user domains)
337 "Lookup the picon for USER at DOMAINS. 385 "Lookup the picon for USER at DOMAINS.
338 USER is a string containing a name. 386 USER is a string containing a name.
343 (defun gnus-picons-lookup-pairs (domains directories) 391 (defun gnus-picons-lookup-pairs (domains directories)
344 "Lookup picons for DOMAINS and all its parents in DIRECTORIES. 392 "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 393 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." 394 none, and whose CDR is the corresponding element of DOMAINS."
347 (let (picons) 395 (let (picons)
396 (setq directories (if (listp directories)
397 directories
398 (list directories)))
348 (while domains 399 (while domains
349 (push (list (gnus-picons-lookup (cons "unknown" domains) 400 (push (list (gnus-picons-lookup (cons "unknown" domains) directories)
350 (if (listp directories)
351 directories
352 (list directories)))
353 (pop domains)) 401 (pop domains))
354 picons)) 402 picons))
355 picons)) 403 picons))
356 404
357 (defun gnus-picons-display-picon-or-name (picon name &optional xface-p right-p) 405 (defun gnus-picons-display-picon-or-name (picon name &optional right-p)
358 (if picon 406 (cond (picon (gnus-picons-display-glyph picon name right-p))
359 (gnus-picons-try-to-find-face picon xface-p name right-p) 407 (gnus-picons-display-as-address (list (make-annotation
360 (list (make-annotation name nil 'text nil nil nil right-p)))) 408 (vector 'string :data name)
361 409 nil 'text
362 (defun gnus-picons-display-pairs (pairs &optional bar-p xface-p dot-p right-p) 410 nil nil nil right-p)))))
411
412 (defun gnus-picons-display-pairs (pairs &optional bar-p dot-p right-p)
363 "Display picons in list PAIRS." 413 "Display picons in list PAIRS."
364 (let ((bar (and bar-p (or gnus-picons-display-as-address 414 (let ((bar (and bar-p (or gnus-picons-display-as-address
365 (annotations-in-region (point) 415 (annotations-in-region (point)
366 (min (point-max) (1+ (point))) 416 (min (point-max)
367 (current-buffer))))) 417 (1+ (point)))
418 (current-buffer)))))
368 (domain-p (and gnus-picons-display-as-address dot-p)) 419 (domain-p (and gnus-picons-display-as-address dot-p))
369 picons) 420 pair picons)
370 (while pairs 421 (while pairs
371 (let ((pair (pop pairs))) 422 (setq pair (pop pairs)
372 (setq picons (nconc (if (and domain-p picons (not right-p)) 423 picons (nconc (if (and domain-p picons (not right-p))
373 (list (make-annotation 424 (list (make-annotation
374 dot-p nil 'text nil nil nil right-p))) 425 (vector 'string :data dot-p)
375 (gnus-picons-display-picon-or-name (car pair) 426 nil 'text nil nil nil right-p)))
376 (cadr pair) 427 (gnus-picons-display-picon-or-name (car pair)
377 xface-p 428 (cadr pair)
378 right-p) 429 right-p)
379 (if (and domain-p pairs right-p) 430 (if (and domain-p pairs right-p)
380 (list (make-annotation 431 (list (make-annotation
381 dot-p nil 'text nil nil nil right-p))) 432 (vector 'string :data dot-p)
382 (when (and bar domain-p) 433 nil 'text nil nil nil right-p)))
383 (setq bar nil) 434 (when (and bar domain-p)
384 (gnus-picons-try-to-find-face 435 (setq bar nil)
385 (expand-file-name "bar.xbm" 436 (gnus-picons-display-glyph
386 gnus-xmas-glyph-directory) 437 (gnus-picons-try-face gnus-xmas-glyph-directory
387 nil nil t)) 438 "bar.")
388 picons)))) 439 nil t))
440 picons)))
389 picons)) 441 picons))
390 442
391 (defvar gnus-picons-glyph-alist nil) 443 (defun gnus-picons-try-face (dir &optional filebase)
392 444 (let* ((dir (file-name-as-directory dir))
393 (defun gnus-picons-try-to-find-face (path &optional xface-p part rightp) 445 (filebase (or filebase "face."))
394 "If PATH exists, display it as a bitmap. Returns t if succeeded." 446 (key (concat dir filebase))
395 (let ((glyph (and (not xface-p) 447 (glyph (cdr (assoc key gnus-picons-glyph-alist)))
396 (cdr (assoc path gnus-picons-glyph-alist))))) 448 (suffixes gnus-picons-file-suffixes)
397 (when (or glyph (file-exists-p path)) 449 f)
398 (unless glyph 450 (while (and suffixes (null glyph))
399 (setq glyph (make-glyph path)) 451 (when (file-exists-p (setq f (expand-file-name (concat filebase
400 (unless xface-p 452 (pop suffixes))
401 (push (cons path glyph) gnus-picons-glyph-alist)) 453 dir)))
402 (set-glyph-face glyph 'default)) 454 (setq glyph (make-glyph f))
403 (let ((new (make-annotation glyph (point) 'text nil nil nil rightp))) 455 (push (cons key glyph) gnus-picons-glyph-alist)))
404 (nconc 456 glyph))
405 (list new) 457
406 (when (and (eq major-mode 'gnus-article-mode) 458 (defun gnus-picons-display-glyph (glyph &optional part rightp)
407 (not gnus-picons-display-as-address) 459 (let ((new (make-annotation glyph (point) 'text nil nil nil rightp)))
408 (not part)) 460 (when (and part gnus-picons-display-as-address)
409 (list (make-annotation " " (point) 'text nil nil nil rightp))) 461 (set-annotation-data new (cons new
410 (when (and part gnus-picons-display-as-address) 462 (make-glyph (vector 'string :data part))))
411 (let ((txt (make-annotation part (point) 'text nil nil nil rightp))) 463 (set-annotation-action new 'gnus-picons-action-toggle))
412 (hide-annotation txt) 464 (nconc
413 (set-extent-property txt 'its-partner new) 465 (list new)
414 (set-extent-property txt 'keymap gnus-picons-map) 466 (if (and (eq major-mode 'gnus-article-mode)
415 (set-extent-property txt 'mouse-face gnus-article-mouse-face) 467 (not gnus-picons-display-as-address)
416 (set-extent-property new 'its-partner txt) 468 (not part))
417 (set-extent-property new 'keymap gnus-picons-map) 469 (list (make-annotation [string :data " "]
418 (list txt)))))))) 470 (point) 'text nil nil nil rightp))))))
419 471
420 (defun gnus-picons-toggle-extent (event) 472 (defun gnus-picons-action-toggle (data)
421 "Toggle picon glyph at given point" 473 "Toggle annotation"
422 (interactive "e") 474 (interactive "e")
423 (let* ((ant1 (event-glyph-extent event)) 475 (let* ((annot (car data))
424 (ant2 (extent-property ant1 'its-partner))) 476 (glyph (annotation-glyph annot)))
425 (when (and (annotationp ant1) (annotationp ant2)) 477 (set-annotation-glyph annot (cdr data))
426 (reveal-annotation ant2) 478 (set-annotation-data annot (cons annot glyph))))
427 (hide-annotation ant1)))) 479
480 (defun gnus-picons-clear-cache ()
481 "Clear the picons cache"
482 (interactive)
483 (setq gnus-picons-glyph-alist nil))
428 484
429 (gnus-add-shutdown 'gnus-picons-close 'gnus) 485 (gnus-add-shutdown 'gnus-picons-close 'gnus)
430 486
431 (defun gnus-picons-close () 487 (defun gnus-picons-close ()
432 "Shut down the picons." 488 "Shut down the picons."
433 (setq gnus-picons-glyph-alist nil)) 489 (if gnus-picons-clear-cache-on-shutdown
490 (gnus-picons-clear-cache)))
491
492 ;;; Query a remote DB. This requires some stuff from w3 !
493
494 (require 'url)
495 (require 'w3-forms)
496
497 (defun gnus-picons-url-retrieve (url fn arg)
498 (let ((old-asynch (default-value 'url-be-asynchronous))
499 (url-working-buffer (generate-new-buffer " *picons*"))
500 (url-request-method nil)
501 (url-package-name "Gnus")
502 (url-package-version gnus-version-number))
503 (setq-default url-be-asynchronous t)
504 (save-excursion
505 (set-buffer url-working-buffer)
506 (setq url-be-asynchronous t
507 url-show-status nil
508 url-current-callback-data arg
509 url-current-callback-func fn)
510 (url-retrieve url t))
511 (setq-default url-be-asynchronous old-asynch)))
512
513 (defun gnus-picons-make-glyph (type)
514 "Make a TYPE glyph using current buffer as data. Handles xbm nicely."
515 (cond ((null type) nil)
516 ((eq type 'xbm) (let ((fname (make-temp-name "/tmp/picon")))
517 (write-region (point-min) (point-max) fname
518 nil 'quiet)
519 (prog1 (make-glyph (vector 'xbm :file fname))
520 (delete-file fname))))
521 (t (make-glyph (vector type :data (buffer-string))))))
522
523 ;;; Parsing of piconsearch result page.
524
525 ;; Assumes:
526 ;; 1 - each value field has the form: "<strong>key</strong> = <kbd>value</kbd>"
527 ;; 2 - a "<p>" separates the keywords from the results
528 ;; 3 - every results begins by the path within the database at the beginning
529 ;; of the line in raw text.
530 ;; 3b - and the href following it is the preferred image type.
531
532 ;; if 1 or 2 is not met, it will probably cause an error. The other
533 ;; will go undetected
534
535 (defun gnus-picons-parse-value (name)
536 (goto-char (point-min))
537 (re-search-forward (concat "<strong>"
538 (regexp-quote name)
539 "</strong> *= *<kbd> *\\([^ <][^<]*\\) *</kbd>"))
540 (buffer-substring (match-beginning 1) (match-end 1)))
541
542 (defun gnus-picons-parse-filenames ()
543 ;; returns an alist of ((USER ADDRS DB) . URL)
544 (let* ((case-fold-search t)
545 (user (gnus-picons-parse-value "user"))
546 (host (gnus-picons-parse-value "host"))
547 (dbs (message-tokenize-header (gnus-picons-parse-value "db") " "))
548 (start-re
549 (concat
550 ;; dbs
551 "^\\(" (mapconcat 'identity dbs "\\|") "\\)/"
552 ;; host
553 "\\(\\(" (replace-in-string host "\\." "/\\|" t) "/\\|MISC/\\)*\\)"
554 ;; user
555 "\\(" (regexp-quote user) "\\|unknown\\)/"
556 "face\\."))
557 cur-db cur-host cur-user types res)
558 ;; now point will be somewhere in the header. Find beginning of
559 ;; entries
560 (re-search-forward "<p>[ \t\n]*")
561 (while (re-search-forward start-re nil t)
562 (setq cur-db (buffer-substring (match-beginning 1) (match-end 1))
563 cur-host (buffer-substring (match-beginning 2) (match-end 2))
564 cur-user (buffer-substring (match-beginning 4) (match-end 4))
565 cur-host (nreverse (message-tokenize-header cur-host "/")))
566 ;; XXX - KLUDGE: there is a blank picon in news/MISC/unknown
567 (unless (and (string-equal cur-db "news")
568 (string-equal cur-user "unknown")
569 (equal cur-host '("MISC")))
570 ;; ok now we have found an entry (USER HOST DB), find the
571 ;; corresponding picon URL
572 (save-restriction
573 ;; restrict region to this entry
574 (narrow-to-region (point) (search-forward "<br>"))
575 (goto-char (point-min))
576 (setq types gnus-picons-file-suffixes)
577 (while (and types
578 (not (re-search-forward
579 (concat "<a[ \t\n]+href=\"\\([^\"]*\\."
580 (regexp-quote (car types)) "\\)\"")
581 nil t)))
582 (pop types))
583 (push (cons (list cur-user cur-host cur-db)
584 (buffer-substring (match-beginning 1) (match-end 1)))
585 res))))
586 (nreverse res)))
587
588 ;;; picon network display functions :
589
590 (defun gnus-picons-network-display-internal (sym-ann glyph part right-p)
591 (set-buffer
592 (get-buffer-create (gnus-get-buffer-name gnus-picons-display-where)))
593 (set sym-ann (nconc (symbol-value sym-ann)
594 (gnus-picons-display-picon-or-name glyph part right-p)))
595 (gnus-picons-next-job-internal))
596
597 (defun gnus-picons-network-display-callback (url part sym-ann right-p)
598 (let ((glyph (gnus-picons-make-glyph (cdr (assoc url-current-mime-type
599 w3-image-mappings)))))
600 (kill-buffer (current-buffer))
601 (push (cons url glyph) gnus-picons-glyph-alist)
602 (gnus-picons-network-display-internal sym-ann glyph part right-p)))
603
604 (defun gnus-picons-network-display (url part sym-ann right-p)
605 (let ((cache (assoc url gnus-picons-glyph-alist)))
606 (if (or cache (null url))
607 (gnus-picons-network-display-internal sym-ann (cdr cache) part right-p)
608 (gnus-picons-url-retrieve url 'gnus-picons-network-display-callback
609 (list url part sym-ann right-p)))))
610
611 ;;; search job functions
612
613 (defun gnus-picons-network-search-internal (user addrs dbs sym-ann right-p
614 &optional fnames)
615 (let (curkey dom pfx url dbs-tmp cache new-jobs)
616 ;; First do the domain search
617 (dolist (part (if right-p
618 (reverse addrs)
619 addrs))
620 (setq pfx (nconc (list part) pfx)
621 dom (cond ((and dom right-p) (concat part "." dom))
622 (dom (concat dom "." part))
623 (t part))
624 curkey (list "unknown" dom dbs))
625 (when (null (setq cache (assoc curkey gnus-picons-url-alist)))
626 ;; This one is not yet in the cache, create a new entry
627 ;; Search for an entry
628 (setq dbs-tmp dbs
629 url nil)
630 (while (and dbs-tmp (null url))
631 (setq url (or (cdr (assoc (list "unknown" pfx (car dbs-tmp)) fnames))
632 (and (eq dom part)
633 ;; This is the first component. Try the
634 ;; catch-all MISC component
635 (cdr (assoc (list "unknown"
636 '("MISC")
637 (car dbs-tmp))
638 fnames)))))
639 (pop dbs-tmp))
640 (push (setq cache (cons curkey url)) gnus-picons-url-alist))
641 ;; Put this glyph in the job list
642 (if (and (not (eq dom part)) gnus-picons-display-as-address)
643 (push (list sym-ann "." right-p) new-jobs))
644 (push (list sym-ann 'picon (cdr cache) part right-p) new-jobs))
645 ;; next, the user search
646 (when user
647 (setq curkey (list user dom gnus-picons-user-directories))
648 (if (null (setq cache (assoc curkey gnus-picons-url-alist)))
649 (let ((users (list user "unknown"))
650 dirs usr domains-tmp dir picon)
651 (while (and users (null picon))
652 (setq dirs gnus-picons-user-directories
653 usr (pop users))
654 (while (and dirs (null picon))
655 (setq domains-tmp addrs
656 dir (pop dirs))
657 (while (and domains-tmp
658 (null (setq picon (assoc (list usr domains-tmp dir)
659 fnames))))
660 (pop domains-tmp))
661 (unless picon
662 (setq picon (assoc (list usr '("MISC") dir) fnames)))))
663 (push (setq cache (cons curkey (cdr picon)))
664 gnus-picons-url-alist)))
665 (if (and gnus-picons-display-as-address new-jobs)
666 (push (list sym-ann "@" right-p) new-jobs))
667 (push (list sym-ann 'picon (cdr cache) user right-p) new-jobs))
668 (setq gnus-picons-jobs-alist (nconc (nreverse new-jobs)
669 gnus-picons-jobs-alist))
670 (gnus-picons-next-job-internal)))
671
672 (defun gnus-picons-network-search-callback (user addrs dbs sym-ann right-p)
673 (gnus-picons-network-search-internal user addrs dbs sym-ann right-p
674 (prog1 (gnus-picons-parse-filenames)
675 (kill-buffer (current-buffer)))))
676
677 (defun gnus-picons-network-search (user addrs dbs sym-ann right-p)
678 (let* ((host (mapconcat 'identity addrs "."))
679 (key (list (or user "unknown") host (if user
680 gnus-picons-user-directories
681 dbs)))
682 (cache (assoc key gnus-picons-url-alist)))
683 (if (null cache)
684 (gnus-picons-url-retrieve
685 (concat gnus-picons-piconsearch-url
686 "?user=" (w3-form-encode-xwfu (or user "unknown"))
687 "&host=" (w3-form-encode-xwfu host)
688 "&db=" (mapconcat 'w3-form-encode-xwfu
689 (if user
690 (append dbs
691 gnus-picons-user-directories)
692 dbs)
693 "+"))
694 'gnus-picons-network-search-callback
695 (list user addrs dbs sym-ann right-p))
696 (gnus-picons-network-search-internal user addrs dbs sym-ann right-p))))
697
698 ;;; Main jobs dispatcher function
699 ;; Given that XEmacs is not really multi threaded, this locking should
700 ;; be sufficient
701
702 (defun gnus-picons-next-job-internal ()
703 (if gnus-picons-jobs-alist
704 (let* ((job (pop gnus-picons-jobs-alist))
705 (sym-ann (pop job))
706 (tag (pop job)))
707 (if tag
708 (cond ((stringp tag);; (SYM-ANN "..." RIGHT-P)
709 (gnus-picons-network-display-internal sym-ann nil tag
710 (pop job)))
711 ((eq 'search tag);; (SYM-ANN 'search USER ADDRS DBS RIGHT-P)
712 (gnus-picons-network-search
713 (pop job) (pop job) (pop job) sym-ann (pop job)))
714 ((eq 'picon tag);; (SYM-ANN 'picon URL PART RIGHT-P)
715 (gnus-picons-network-display
716 (pop job) (pop job) sym-ann (pop job)))
717 (t (error "Unknown picon job tag %s" tag)))))
718 (setq gnus-picons-job-already-running nil)))
719
720 (defun gnus-picons-next-job ()
721 "Start processing the job queue."
722 (unless gnus-picons-job-already-running
723 (setq gnus-picons-job-already-running t)
724 (gnus-picons-next-job-internal)))
434 725
435 (provide 'gnus-picon) 726 (provide 'gnus-picon)
436 727
437 ;;; gnus-picon.el ends here 728 ;;; gnus-picon.el ends here