Mercurial > hg > xemacs-beta
diff lisp/gnus/gnus-picon.el @ 30:ec9a17fef872 r19-15b98
Import from CVS: tag r19-15b98
author | cvs |
---|---|
date | Mon, 13 Aug 2007 08:52:29 +0200 |
parents | 441bb1e64a06 |
children | 131b0175ea99 |
line wrap: on
line diff
--- a/lisp/gnus/gnus-picon.el Mon Aug 13 08:51:58 2007 +0200 +++ b/lisp/gnus/gnus-picon.el Mon Aug 13 08:52:29 2007 +0200 @@ -29,6 +29,8 @@ (require 'xpm) (require 'annotations) (require 'custom) +(require 'gnus-art) +(require 'gnus-win) (defgroup picons nil "Show pictures of people, domains, and newsgroups (XEmacs). @@ -50,7 +52,7 @@ :group 'picons) (defcustom gnus-picons-database "/usr/local/faces" - "Defines the location of the faces database. + "Defines the location of the faces database. For information on obtaining this database of pretty pictures, please see http://www.cs.indiana.edu/picons/ftp/index.html" :type 'directory @@ -67,7 +69,7 @@ :group 'picons) (defcustom gnus-picons-domain-directories '("domains") - "List of directories to search for domain faces. + "List of directories to search for domain faces. Some people may want to add \"unknown\" to this list." :type '(repeat string) :group 'picons) @@ -77,7 +79,7 @@ :type 'boolean :group 'picons) -(defcustom gnus-picons-x-face-file-name +(defcustom gnus-picons-x-face-file-name (format "/tmp/picon-xface.%s.xbm" (user-login-name)) "The name of the file in which to store the converted X-face header." :type 'string @@ -117,7 +119,7 @@ (define-key gnus-picons-map [(button2)] 'gnus-picons-toggle-extent) ;;; Internal variables. - + (defvar gnus-group-annotations nil) (defvar gnus-article-annotations nil) (defvar gnus-x-face-annotations nil) @@ -178,7 +180,7 @@ (sleep-for .1))) ;; display it (save-excursion - (set-buffer (get-buffer-create (gnus-get-buffer-name + (set-buffer (get-buffer-create (gnus-get-buffer-name gnus-picons-display-where))) (gnus-add-current-to-buffer-list) (goto-char (point-min)) @@ -187,7 +189,7 @@ (push (make-annotation "\n" (point) 'text) gnus-x-face-annotations)) ;; append the annotation to gnus-article-annotations for deletion. - (setq gnus-x-face-annotations + (setq gnus-x-face-annotations (append (gnus-picons-try-to-find-face gnus-picons-x-face-file-name t) gnus-x-face-annotations))) @@ -205,7 +207,7 @@ (when (and (featurep 'xpm) (or (not (fboundp 'device-type)) (equal (device-type) 'x)) (setq from (mail-fetch-field "from")) - (setq from (downcase + (setq from (downcase (or (cadr (mail-extract-address-components from)) ""))) (or (setq at-idx (string-match "@" from)) @@ -217,7 +219,7 @@ (nreverse (message-tokenize-header gnus-local-domain ".")) '("")) - (nreverse (message-tokenize-header + (nreverse (message-tokenize-header (substring from (1+ at-idx)) "."))))) (set-buffer (get-buffer-create (gnus-get-buffer-name gnus-picons-display-where))) @@ -230,7 +232,7 @@ (unless (eolp) (push (make-annotation "\n" (point) 'text) gnus-article-annotations))) - + (gnus-picons-remove gnus-article-annotations) (setq gnus-article-annotations nil) @@ -241,7 +243,7 @@ (nconc (gnus-picons-insert-face-if-exists (car databases) addrs - "unknown" (or gnus-picons-display-as-address + "unknown" (or gnus-picons-display-as-address gnus-article-annotations) t t) gnus-article-annotations)) (setq databases (cdr databases))) @@ -250,7 +252,7 @@ (when gnus-picons-display-as-address (setq gnus-article-annotations (nconc gnus-article-annotations - (list + (list (make-annotation "@" (point) 'text nil nil nil t))))) ;; then do user directories, @@ -260,23 +262,23 @@ (while databases (setq found (nconc (gnus-picons-insert-face-if-exists - (car databases) addrs username - (or gnus-picons-display-as-address + (car databases) addrs username + (or gnus-picons-display-as-address gnus-article-annotations) nil t) found)) (setq databases (cdr databases))) ;; add their name if no face exists (when (and gnus-picons-display-as-address (not found)) (setq found - (list + (list (make-annotation username (point) 'text nil nil nil t)))) - (setq gnus-article-annotations + (setq gnus-article-annotations (nconc found gnus-article-annotations))) (add-hook 'gnus-summary-exit-hook 'gnus-picons-remove-all)))))) (defun gnus-group-display-picons () - "Display icons for the group in the gnus-picons-display-where buffer." + "Display icons for the group in the gnus-picons-display-where buffer." (interactive) ;; let display catch up so far (when gnus-picons-refresh-before-display @@ -326,8 +328,8 @@ ;; '(gnus-picons-insert-face-if-exists ;; "Database" '("edu" "indiana" "cs") "Name") ;; looks for: - ;; 1. edu/indiana/cs/Name - ;; 2. edu/indiana/Name + ;; 1. edu/indiana/cs/Name + ;; 2. edu/indiana/Name ;; 3. edu/Name ;; '(gnus-picons-insert-face-if-exists ;; "Database/MISC" '("edu" "indiana" "cs") "Name") @@ -337,7 +339,7 @@ ;; picon databases, but otherwise we would always see the MISC/unknown face. (let ((bar (and (not nobar-p) (or gnus-picons-display-as-address - (annotations-in-region + (annotations-in-region (point) (min (point-max) (1+ (point))) (current-buffer))))) (path (concat (file-name-as-directory gnus-picons-database) @@ -350,32 +352,32 @@ (file-accessible-directory-p path)) (setq cur (pop addrs) path (concat path cur "/")) - (if (setq found + (if (setq found (gnus-picons-try-suffixes (concat path filename "/face."))) - (progn + (progn (setq picons (nconc (when (and domainp first rightp) (list (make-annotation - "." (point) 'text + "." (point) 'text nil nil nil rightp) picons)) - (gnus-picons-try-to-find-face + (gnus-picons-try-to-find-face found nil (if domainp cur filename) rightp) (when (and domainp first (not rightp)) (list (make-annotation - "." (point) 'text + "." (point) 'text nil nil nil rightp) picons)) picons))) (when domainp - (setq picons - (nconc (list (make-annotation - (if first (concat (if (not rightp) ".") cur + (setq picons + (nconc (list (make-annotation + (if first (concat (if (not rightp) ".") cur (if rightp ".")) cur) (point) 'text nil nil nil rightp)) picons)))) (when (and bar (or domainp found)) - (setq bar-ann (gnus-picons-try-to-find-face - (concat gnus-xmas-glyph-directory "bar.xbm") + (setq bar-ann (gnus-picons-try-to-find-face + (concat gnus-xmas-glyph-directory "bar.xbm") nil nil t)) (when bar-ann (setq picons (nconc picons bar-ann)) @@ -383,13 +385,13 @@ (setq first t)) (when (and addrs domainp) (let ((it (mapconcat 'downcase (nreverse addrs) "."))) - (make-annotation - (if first (concat (if (not rightp) ".") it (if rightp ".")) it) + (make-annotation + (if first (concat (if (not rightp) ".") it (if rightp ".")) it) (point) 'text nil nil nil rightp))) 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)