;;; gnus-picon.el --- displaying pretty icons in Gnus
-;; Copyright (C) 1996,97,98 Free Software Foundation, Inc.
-;; Author: Wes Hardaker <hardaker@ece.ucdavis.edu>
+;; Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004,
+;; 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
+
+;; 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:
+;; There are three picon types relevant to Gnus:
+;;
+;; Persons: person@subdomain.dom
+;; users/dom/subdomain/person/face.gif
+;; usenix/dom/subdomain/person/face.gif
+;; misc/MISC/person/face.gif
+;; Domains: subdomain.dom
+;; 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 'xpm)
-(require 'annotations)
-(require 'custom)
(require 'gnus-art)
-(require 'gnus-win)
;;; User variables:
-(defgroup picons nil
- "Show pictures of people, domains, and newsgroups (XEmacs).
-For this to work, you must add gnus-group-display-picons to the
-gnus-summary-display-hook or to the gnus-article-display-hook
-depending on what gnus-picons-display-where is set to. You must
-also add gnus-article-display-picons to gnus-article-display-hook."
- :group 'gnus-visual)
-
-(defcustom gnus-picons-display-where 'picons
- "Where to display the group and article icons.
-Legal values are `article' and `picons'."
- :type '(choice symbol string)
- :group 'picons)
-
-(defcustom gnus-picons-has-modeline-p t
- "*Whether the picons window should have a modeline.
-This is only useful if `gnus-picons-display-where' is `picons'."
- :type 'boolean
- :group 'picons)
-
-(defcustom gnus-picons-database "/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 'picons)
-
-(defcustom gnus-picons-news-directories '("news")
+(defcustom gnus-picon-news-directories '("news")
"*List of directories to search for newsgroups faces."
:type '(repeat string)
- :group 'picons)
-(define-obsolete-variable-alias 'gnus-picons-news-directory
- 'gnus-picons-news-directories)
+ :group 'gnus-picon)
-(defcustom gnus-picons-user-directories '("local" "users" "usenix" "misc")
+(defcustom gnus-picon-user-directories '("users" "usenix" "local" "misc")
"*List of directories to search for user faces."
:type '(repeat string)
- :group 'picons)
+ :group 'gnus-picon)
-(defcustom gnus-picons-domain-directories '("domains")
+(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 'picons)
-
-(defcustom gnus-picons-refresh-before-display nil
- "*If non-nil, display the article buffer before computing the picons."
- :type 'boolean
- :group 'picons)
-
-(defcustom gnus-picons-group-excluded-groups nil
- "*If this regexp matches the group name, group picons will be disabled."
- :type 'regexp
- :group 'picons)
-
-(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
- :group 'picons)
-
-(defcustom gnus-picons-convert-x-face (format "{ echo '/* Width=48, Height=48 */'; uncompface; } | icontopbm | pbmtoxbm > %s" gnus-picons-x-face-file-name)
- "*Command to convert the x-face header into a xbm file."
- :type 'string
- :group 'picons)
-
-(defcustom gnus-picons-display-as-address t
- "*If t display textual email addresses along with pictures."
- :type 'boolean
- :group 'picons)
-
-(defcustom gnus-picons-file-suffixes
- (when (featurep 'x)
- (let ((types (list "xbm")))
- (when (featurep 'gif)
- (push "gif" types))
- (when (featurep 'xpm)
- (push "xpm" types))
- types))
+ :group 'gnus-picon)
+
+(defcustom gnus-picon-file-types
+ (let ((types (list "xbm")))
+ (when (gnus-image-type-available-p 'gif)
+ (push "gif" types))
+ (when (gnus-image-type-available-p 'xpm)
+ (push "xpm" types))
+ types)
"*List of suffixes on picon file names to try."
:type '(repeat string)
- :group 'picons)
-
-(defcustom gnus-picons-display-article-move-p t
- "*Whether to move point to first empty line when displaying picons.
-This has only an effect if `gnus-picons-display-where' has value `article'."
- :type 'boolean
- :group 'picons)
-
-(defcustom gnus-picons-clear-cache-on-shutdown t
- "*Whether to clear the picons cache when exiting gnus.
-Gnus caches every picons it finds while it is running. This saves
-some time in the search process but eats some memory. If this
-variable is set to nil, Gnus will never clear the cache itself; you
-will have to manually call `gnus-picons-clear-cache' to clear it.
-Otherwise the cache will be cleared every time you exit Gnus."
+ :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 'picons)
-
-(defcustom gnus-picons-piconsearch-url nil
- "*The url to query for picons. Setting this to nil will disable it.
-The only publicly available address currently known is
-http://www.cs.indiana.edu:800/piconsearch. If you know of any other,
-please tell me so that we can list it."
- :type '(choice (const :tag "Disable" :value nil)
- (const :tag "www.cs.indiana.edu"
- :value "http://www.cs.indiana.edu:800/piconsearch")
- (string))
- :group 'picons)
-
-(defface gnus-picons-xbm-face '((t (:foreground "black" :background "white")))
- "Face to show X face"
- :group 'picons)
+ :group 'gnus-picon)
;;; Internal variables:
-(defvar gnus-picons-processes-alist nil
- "Picons processes currently running and their environment.")
-(defvar gnus-picons-glyph-alist nil
- "Picons glyphs cache.
+(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-picons-url-alist nil
- "Picons file names cache.
-List of pairs (KEY . NAME) where KEY is (USER HOST DBS) and NAME is an URL.")
-
-(defvar gnus-picons-jobs-alist nil
- "List of jobs that still need be done.
-This is a list of (SYM-ANN TAG ARGS...) where SYM-ANN three annotations list,
-TAG is one of `picon' or `search' indicating that the job should query a
-picon or do a search for picons file names, and ARGS is some additionnal
-arguments necessary for the job.")
-
-(defvar gnus-picons-job-already-running nil
- "Lock to ensure only one stream of http requests is running.")
+(defvar gnus-picon-cache nil)
;;; Functions:
-(defun gnus-picons-remove-all ()
- "Removes all picons from the Gnus display(s)."
- (interactive)
- (map-extents (function (lambda (ext unused) (delete-annotation ext) nil))
- nil nil nil nil nil 'gnus-picon)
- (setq gnus-picons-jobs-alist '())
- ;; notify running job that it may have been preempted
- (if (and (listp gnus-picons-job-already-running)
- gnus-picons-job-already-running)
- (setq gnus-picons-job-already-running t)))
-
-(defun gnus-get-buffer-name (variable)
- "Returns the buffer name associated with the contents of a variable."
- (buffer-name (get-buffer (gnus-window-to-buffer-helper variable))))
-
-(defun gnus-picons-buffer-name ()
- (cond ((or (stringp gnus-picons-display-where)
- (bufferp gnus-picons-display-where))
- gnus-picons-display-where)
- ((eq gnus-picons-display-where 'picons)
- (if gnus-single-article-buffer
- "*Picons*"
- (concat "*Picons " gnus-newsgroup-name "*")))
- (t
- (gnus-get-buffer-name gnus-picons-display-where))))
-
-(defun gnus-picons-kill-buffer ()
- (let ((buf (get-buffer (gnus-picons-buffer-name))))
- (if (buffer-live-p buf)
- (kill-buffer buf))))
-
-(defun gnus-picons-setup-buffer ()
- (let ((name (gnus-picons-buffer-name)))
- (save-excursion
- (if (get-buffer name)
- (set-buffer name)
- (set-buffer (get-buffer-create name))
- (buffer-disable-undo)
- (setq buffer-read-only t)
- (gnus-add-current-to-buffer-list)
- (add-hook 'gnus-summary-prepare-exit-hook 'gnus-picons-kill-buffer))
- (current-buffer))))
-
-(defun gnus-picons-set-buffer ()
- (set-buffer (gnus-picons-setup-buffer))
- (goto-char (point-min))
- (if (and (eq gnus-picons-display-where 'article)
- gnus-picons-display-article-move-p)
- (if (search-forward "\n\n" nil t)
- (forward-line -1)
- (goto-char (point-max)))
- (setq buffer-read-only t)
- (unless gnus-picons-has-modeline-p
- (set-specifier has-modeline-p
- (list (list (current-buffer)
- (cons nil gnus-picons-has-modeline-p)))))))
-
-(defun gnus-picons-prepare-for-annotations ()
- "Prepare picons buffer for putting annotations."
- ;; let drawing catch up
- (when gnus-picons-refresh-before-display
- (sit-for 0))
- (gnus-picons-set-buffer)
- (gnus-picons-remove-all))
-
-(defun gnus-picons-make-annotation (&rest args)
- (let ((annot (apply 'make-annotation args)))
- (set-extent-property annot 'gnus-picon t)
- (set-extent-property annot 'duplicable t)
- annot))
-
-(defun gnus-picons-article-display-x-face ()
projects / gnus / blobdiff