;;; gnus-picon.el --- displaying pretty icons in Gnus
-;; Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001
-;; Free Software Foundation, Inc.
+;; Copyright (C) 1996-2011 Free Software Foundation, Inc.
-;; Author: Wes Hardaker <hardaker@ece.ucdavis.edu>
+;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
;; Keywords: news xpm annotation glyph faces
;; This file is part of GNU Emacs.
-;; GNU Emacs is free software; you can redistribute it and/or modify
+;; GNU Emacs is free software: you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation; either version 2, or (at your option)
-;; any later version.
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
-;; along with GNU Emacs; see the file COPYING. If not, write to the
-;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
-;; Boston, MA 02111-1307, USA.
+;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
;;; Commentary:
;; domain/dom/subdomain/unknown/face.gif
;; Groups: comp.lang.lisp
;; news/comp/lang/lisp/unknown/face.gif
-
+;;
+;; Original implementation by Wes Hardaker <hardaker@ece.ucdavis.edu>.
+;;
;;; Code:
+;; For Emacs <22.2 and XEmacs.
+(eval-and-compile
+ (unless (fboundp 'declare-function) (defmacro declare-function (&rest r))))
+
+(eval-when-compile (require 'cl))
+
(require 'gnus)
-(require 'custom)
(require 'gnus-art)
-(require 'gnus-win)
;;; User variables:
-(defgroup picon nil
- "Show pictures of people, domains, and newsgroups.
-For this to work, you must switch on the `gnus-treat-display-picon'
-variable."
- :group 'gnus-visual)
-
-(defcustom gnus-picon-databases '("/usr/lib/picon" "/usr/local/faces")
- "*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
- :group 'picon)
-
(defcustom gnus-picon-news-directories '("news")
"*List of directories to search for newsgroups faces."
:type '(repeat string)
- :group 'picon)
+ :group 'gnus-picon)
(defcustom gnus-picon-user-directories '("users" "usenix" "local" "misc")
"*List of directories to search for user faces."
:type '(repeat string)
- :group 'picon)
+ :group 'gnus-picon)
(defcustom gnus-picon-domain-directories '("domains")
"*List of directories to search for domain faces.
Some people may want to add \"unknown\" to this list."
:type '(repeat string)
- :group 'picon)
+ :group 'gnus-picon)
(defcustom gnus-picon-file-types
(let ((types (list "xbm")))
types)
"*List of suffixes on picon file names to try."
:type '(repeat string)
- :group 'picon)
-
-(defface gnus-picon-xbm-face '((t (:foreground "black" :background "white")))
- "Face to show xbm picon in."
- :group 'picon)
-
-(defface gnus-picon-face '((t (:foreground "black" :background "white")))
- "Face to show picon in."
- :group 'picon)
+ :group 'gnus-picon)
+
+(defcustom gnus-picon-style 'inline
+ "How should picons be displayed.
+If `inline', the textual representation is replaced. If `right', picons are
+added right to the textual representation."
+ ;; FIXME: `right' needs improvement for XEmacs.
+ :type '(choice (const inline)
+ (const right))
+ :group 'gnus-picon)
+
+(defcustom gnus-picon-inhibit-top-level-domains t
+ "If non-nil, don't piconify top-level domains.
+These are often not very interesting."
+ :type 'boolean
+ :group 'gnus-picon)
;;; Internal variables:
-(defvar gnus-picon-setup-p nil)
(defvar gnus-picon-glyph-alist nil
"Picon glyphs cache.
List of pairs (KEY . GLYPH) where KEY is either a filename or an URL.")
+(defvar gnus-picon-cache nil)
;;; Functions:
(split-string (car address) "\\."))))
(defun gnus-picon-find-face (address directories &optional exact)
- (let* ((databases gnus-picon-databases)
- (address (gnus-picon-split-address address))
+ (let* ((address (gnus-picon-split-address address))
(user (pop address))
- database directory found instance base)
- (while (and (not found)
- (setq database (pop databases)))
- (while (and (not found)
- (setq directory (pop directories)))
- (setq base (expand-file-name directory database))
- ;; Kludge to search misc/MISC for users.
- (when (string= directory "misc")
- (setq address '("MISC")))
- (while (and (not found)
- address)
- (setq found (gnus-picon-find-image
- (concat base "/" (mapconcat 'identity
- (reverse address)
- "/")
- "/" user "/")))
- (if exact
- (setq address nil)
- (pop address)))))
- found))
+ (faddress address)
+ database directory result instance base)
+ (catch 'found
+ (dolist (database gnus-picon-databases)
+ (dolist (directory directories)
+ (setq address faddress
+ base (expand-file-name directory database))
+ (while address
+ (when (setq result (gnus-picon-find-image
+ (concat base "/" (mapconcat 'downcase
+ (reverse address)
+ "/")
+ "/" (downcase user) "/")))
+ (throw 'found result))
+ (if exact
+ (setq address nil)
+ (pop address)))
+ ;; Kludge to search MISC as well. But not in "news".
+ (unless (string= directory "news")
+ (when (setq result (gnus-picon-find-image
+ (concat base "/MISC/" user "/")))
+ (throw 'found result))))))))
(defun gnus-picon-find-image (dire
projects / gnus / blobdiff