- (when (and (featurep 'xpm)
- (or (not (fboundp 'device-type)) (equal (device-type) 'x)))
- (save-excursion
- (gnus-picons-prepare-for-annotations 'gnus-group-annotations)
- (if (null gnus-picons-piconsearch-url)
- (setq gnus-group-annotations
- (gnus-picons-display-pairs
- (gnus-picons-lookup-pairs (reverse (message-tokenize-header
- (gnus-group-real-name gnus-newsgroup-name)
- "."))
- gnus-picons-news-directories)
- t "."))
- (push (list 'gnus-group-annotations 'search nil
- (message-tokenize-header
- (gnus-group-real-name gnus-newsgroup-name) ".")
- (if (listp gnus-picons-news-directories)
- gnus-picons-news-directories
- (list gnus-picons-news-directories))
- nil)
- gnus-picons-jobs-alist)
- (gnus-picons-next-job))
-
- (add-hook 'gnus-summary-exit-hook 'gnus-picons-remove-all))))
-
-(defsubst gnus-picons-lookup-internal (addrs dir)
- (setq dir (expand-file-name dir gnus-picons-database))
- (gnus-picons-try-face (dolist (part (reverse addrs) dir)
- (setq dir (expand-file-name part dir)))))
-
-(defun gnus-picons-lookup (addrs dirs)
- "Lookup the picon for ADDRS in databases DIRS.
-Returns the picon filename or NIL if none found."
- (let (result)
- (while (and dirs (null result))
- (setq result (gnus-picons-lookup-internal addrs (pop dirs))))
- result))
-
-(defun gnus-picons-lookup-user-internal (user domains)
- (let ((dirs gnus-picons-user-directories)
- domains-tmp dir picon)
- (while (and dirs (null picon))
- (setq domains-tmp domains
- dir (pop dirs))
- (while (and domains-tmp
- (null (setq picon (gnus-picons-lookup-internal
- (cons user domains-tmp) dir))))
- (pop domains-tmp))
- ;; Also make a try in MISC subdir
- (unless picon
- (setq picon (gnus-picons-lookup-internal (list user "MISC") dir))))
- picon))
-
-(defun gnus-picons-lookup-user (user domains)
- "Lookup the picon for USER at DOMAINS.
-USER is a string containing a name.
-DOMAINS is a list of strings from the fully qualified domain name."
- (or (gnus-picons-lookup-user-internal user domains)
- (gnus-picons-lookup-user-internal "unknown" domains)))
-
-(defun gnus-picons-lookup-pairs (domains directories)
- "Lookup picons for DOMAINS and all its parents in DIRECTORIES.
-Returns a list of PAIRS whose CAR is the picon filename or NIL if
-none, and whose CDR is the corresponding element of DOMAINS."
- (let (picons)
- (setq directories (if (listp directories)
- directories
- (list directories)))
- (while domains
- (push (list (gnus-picons-lookup (cons "unknown" domains) directories)
- (pop domains))
- picons))
- picons))
-
-(defun gnus-picons-display-picon-or-name (picon name &optional right-p)
- (cond (picon (gnus-picons-display-glyph picon name right-p))
- (gnus-picons-display-as-address (list (gnus-picons-make-annotation
- (vector 'string :data name)
- nil 'text
- nil nil nil right-p)))))
-
-(defun gnus-picons-display-pairs (pairs &optional bar-p dot-p right-p)
- "Display picons in list PAIRS."
- (let ((domain-p (and gnus-picons-display-as-address dot-p))
- pair picons)
- (if (and bar-p domain-p right-p)
- (setq picons (gnus-picons-display-glyph
- (gnus-picons-try-face gnus-xmas-glyph-directory
- "bar.")
- nil right-p)))
- (while pairs
- (setq pair (pop pairs)
- picons (nconc picons
- (gnus-picons-display-picon-or-name (car pair)
- (cadr pair)
- right-p)
- (if (and domain-p pairs)
- (list (gnus-picons-make-annotation
- (vector 'string :data dot-p)
- nil 'text nil nil nil right-p))))))
- (if (and bar-p domain-p (not right-p))
- (setq picons (nconc picons
- (gnus-picons-display-glyph
- (gnus-picons-try-face gnus-xmas-glyph-directory
- "bar.")
- nil right-p))))
- picons))
-
-(defun gnus-picons-try-face (dir &optional filebase)
- (let* ((dir (file-name-as-directory dir))
- (filebase (or filebase "face."))
- (key (concat dir filebase))
- (glyph (cdr (assoc key gnus-picons-glyph-alist)))
- (suffixes gnus-picons-file-suffixes)
- f)
- (while (and suffixes (null glyph))
- (when (file-exists-p (setq f (expand-file-name (concat filebase
- (pop suffixes))
- dir)))
- (setq glyph (make-glyph f))
- (push (cons key glyph) gnus-picons-glyph-alist)))
- glyph))
-
-(defun gnus-picons-display-glyph (glyph &optional part rightp)
- (let ((new (gnus-picons-make-annotation glyph (point)
- 'text nil nil nil rightp)))
- (when (and part gnus-picons-display-as-address)
- (set-annotation-data new (cons new
- (make-glyph (vector 'string :data part))))
- (set-annotation-action new 'gnus-picons-action-toggle))
- (nconc
- (list new)
- (if (and (eq major-mode 'gnus-article-mode)
- (not gnus-picons-display-as-address)
- (not part))
- (list (gnus-picons-make-annotation [string :data " "] (point)
- 'text nil nil nil rightp))))))
-
-(defun gnus-picons-action-toggle (data)
- "Toggle annotation"
- (interactive "e")
- (let* ((annot (car data))
- (glyph (annotation-glyph annot)))
- (set-annotation-glyph annot (cdr data))
- (set-annotation-data annot (cons annot glyph))))
-
-(defun gnus-picons-clear-cache ()
- "Clear the picons cache"