- (when (and (featurep 'xpm)
- (or (not (fboundp 'device-type)) (equal (device-type) 'x)))
- (save-excursion
- (gnus-picons-prepare-for-annotations 'gnus-group-annotations)
- (setq gnus-group-annotations
- (gnus-picons-display-pairs
- (gnus-picons-lookup-pairs (reverse (message-tokenize-header
- gnus-newsgroup-name "."))
- gnus-picons-news-directory)
- t nil "."))
- (add-hook 'gnus-summary-exit-hook 'gnus-picons-remove-all))))
-
-(defun gnus-picons-make-path (dir subdirs)
- "Make a directory name from a base DIR and a list of SUBDIRS.
-Returns a directory name build by concatenating DIR and all elements of
-SUBDIRS with \"/\" between elements."
- (while subdirs
- (setq dir (file-name-as-directory (concat dir (pop subdirs)))))
- dir)
-
-(defsubst gnus-picons-try-suffixes (file)
- (let ((suffixes gnus-picons-file-suffixes)
- f)
- (while (and suffixes
- (not (file-exists-p (setq f (concat file (pop suffixes))))))
- (setq f nil))
- f))
-
-(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-try-suffixes
- (expand-file-name "face."
- (gnus-picons-make-path
- (file-name-as-directory
- (concat
- (file-name-as-directory gnus-picons-database)
- (pop dirs)))
- (reverse addrs))))))
- result))
-
-(defun gnus-picons-lookup-user-internal (user domains)
- (let ((dirs gnus-picons-user-directories)
- picon)
- (while (and dirs (null picon))
- (let ((dir (list (pop dirs)))
- (domains domains))
- (while (and domains (null picon))
- (setq picon (gnus-picons-lookup (cons user domains) dir))
- (pop domains))
- ;; Also make a try MISC subdir
- (unless picon
- (setq picon (gnus-picons-lookup (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)
- (while domains
- (push (list (gnus-picons-lookup (cons "unknown" domains)
- (if (listp directories)
- directories
- (list directories)))
- (pop domains))
- picons))
- picons))
-
-(defun gnus-picons-display-picon-or-name (picon name &optional xface-p right-p)
- (if picon
- (gnus-picons-try-to-find-face picon xface-p name right-p)
- (list (make-annotation name nil 'text nil nil nil right-p))))
-
-(defun gnus-picons-display-pairs (pairs &optional bar-p xface-p dot-p right-p)
- "Display picons in list PAIRS."
- (let ((bar (and bar-p (or gnus-picons-display-as-address
- (annotations-in-region (point)
- (min (point-max) (1+ (point)))
- (current-buffer)))))
- (domain-p (and gnus-picons-display-as-address dot-p))
- picons)
- (while pairs
- (let ((pair (pop pairs)))
- (setq picons (nconc (if (and domain-p picons (not right-p))
- (list (make-annotation
- dot-p nil 'text nil nil nil right-p)))
- (gnus-picons-display-picon-or-name (car pair)
- (cadr pair)
- xface-p
- right-p)
- (if (and domain-p pairs right-p)
- (list (make-annotation
- dot-p nil 'text nil nil nil right-p)))
- (when (and bar domain-p)
- (setq bar nil)
- (gnus-picons-try-to-find-face
- (expand-file-name "bar.xbm"
- gnus-xmas-glyph-directory)
- nil nil t))
- picons))))
- picons))
-
-(defvar gnus-picons-glyph-alist nil)
-
-(defun gnus-picons-try-to-find-face (path &optional xface-p part rightp)
- "If PATH exists, display it as a bitmap. Returns t if succeeded."
- (let ((glyph (and (not xface-p)
- (cdr (assoc path gnus-picons-glyph-alist)))))
- (when (or glyph (file-exists-p path))
- (unless glyph
- (setq glyph (make-glyph path))
- (unless xface-p
- (push (cons path glyph) gnus-picons-glyph-alist))
- (set-glyph-face glyph 'default))
- (let ((new (make-annotation glyph (point) 'text nil nil nil rightp)))
- (nconc
- (list new)
- (when (and (eq major-mode 'gnus-article-mode)
- (not gnus-picons-display-as-address)
- (not part))
- (list (make-annotation " " (point) 'text nil nil nil rightp)))
- (when (and part gnus-picons-display-as-address)
- (let ((txt (make-annotation part (point) 'text nil nil nil rightp)))
- (hide-annotation txt)
- (set-extent-property txt 'its-partner new)
- (set-extent-property txt 'keymap gnus-picons-map)
- (set-extent-property txt 'mouse-face gnus-article-mouse-face)
- (set-extent-property new 'its-partner txt)
- (set-extent-property new 'keymap gnus-picons-map)
- (list txt))))))))
-
-(defun gnus-picons-toggle-extent (event)
- "Toggle picon glyph at given point"
- (interactive "e")
- (let* ((ant1 (event-glyph-extent event))
- (ant2 (extent-property ant1 'its-partner)))
- (when (and (annotationp ant1) (annotationp ant2))
- (reveal-annotation ant2)
- (hide-annotation ant1))))
-
-(gnus-add-shutdown 'gnus-picons-close 'gnus)
-
-(defun gnus-picons-close ()
- "Shut down the picons."
- (setq gnus-picons-glyph-alist nil))