X-Git-Url: http://cgit.sxemacs.org/?p=gnus;a=blobdiff_plain;f=lisp%2Fgnus-picon.el;h=d24f04e0215036fb722588849411f80454dfd955;hp=faabc56c1fe2466507800716edbc99e90d0dd795;hb=eb137e24d3fbda2449393a38761845e85dcb4d81;hpb=43ae6596cb9b54f7e14f4671f4e76a6a2554ff54 diff --git a/lisp/gnus-picon.el b/lisp/gnus-picon.el index faabc56c1..d24f04e02 100644 --- a/lisp/gnus-picon.el +++ b/lisp/gnus-picon.el @@ -1,27 +1,25 @@ ;;; gnus-picon.el --- displaying pretty icons in Gnus -;; Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001 -;; Free Software Foundation, Inc. +;; Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, +;; 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc. -;; Author: Wes Hardaker +;; Author: Lars Magne Ingebrigtsen ;; 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 . ;;; Commentary: @@ -35,44 +33,37 @@ ;; domain/dom/subdomain/unknown/face.gif ;; Groups: comp.lang.lisp ;; news/comp/lang/lisp/unknown/face.gif - +;; +;; Original implementation by Wes Hardaker . +;; ;;; 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"))) @@ -83,22 +74,29 @@ Some people may want to add \"unknown\" to this list." 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: @@ -110,29 +108,30 @@ List of pairs (KEY . GLYPH) where KEY is either a filename or an URL.") (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 (directory) (let ((types gnus-picon-file-types) @@ -144,97 +143,174 @@ List of pairs (KEY . GLYPH) where KEY is either a filename or an URL.") file nil))) -(defun gnus-picon-insert-glyph (glyph) +(defun gnus-picon-insert-glyph (glyph category &optional nostring) "Insert GLYPH into the buffer. -GLYPH can be either a glyph or a string." +GLYPH can be either a glyph or a string. When NOSTRING, no textual +replacement is added." + ;; Using NOSTRING prevents wrong BBDB entries with `gnus-picon-style' set to + ;; 'right. (if (stringp glyph) (insert glyph) - (gnus-put-image glyph))) + (gnus-add-wash-type category) + (gnus-add-image category (car glyph)) + (gnus-put-image (car glyph) (unless nostring (cdr glyph)) category))) (defun gnus-picon-create-glyph (file) (or (cdr (assoc file gnus-picon-glyph-alist)) - (cdar (push (cons file (gnus-create-image file)) + (cdar (push (cons file (gnus-create-image + file nil nil + :color-symbols '(("None" . "white")))) gnus-picon-glyph-alist)))) ;;; Functions that does picon transformations: -(defun gnus-picon-transform-address (header) - (interactive) +(declare-function image-size "image.c" (spec &optional pixels frame)) + +(defun gnus-picon-transform-address (header category) (gnus-with-article-headers - (let ((addresses - (mail-header-parse-addresses (mail-fetch-field header))) - first spec file) - (dolist (address addresses) - (setq address (car address) - first t) - (when (and (stringp address) - (setq spec (gnus-picon-split-address address))) - (when (setq file (gnus-picon-find-face - address gnus-picon-user-directories)) - (setcar spec (gnus-picon-create-glyph file))) - (dotimes (i (1- (length spec))) - (when (setq file (gnus-picon-find-face - (concat "unknown@" - (mapconcat - 'identity (nthcdr (1+ i) spec) ".")) - gnus-picon-domain-directories t)) - (setcar (nthcdr (1+ i) spec) (gnus-picon-create-glyph file)))) - - (gnus-article-goto-header header) - (mail-header-narrow-to-field) - (when (search-forward address nil t) - (delete-region (match-beginning 0) (match-end 0)) - (while spec - (gnus-picon-insert-glyph (pop spec)) - (when spec - (if (not first) - (insert ".") - (insert "@") - (setq first nil)))))))))) + (let ((addresses + (mail-header-parse-addresses + ;; mail-header-parse-addresses does not work (reliably) on + ;; decoded headers. + (or + (ignore-errors + (mail-encode-encoded-word-string + (or (mail-fetch-field header) ""))) + (mail-fetch-field header)))) + spec file point cache len) + (dolist (address addresses) + (setq address (car address)) + (when (and (stringp address) + (setq spec (gnus-picon-split-address address))) + (if (setq cache (cdr (assoc address gnus-picon-cache))) + (setq spec cache) + (when (setq file (or (gnus-picon-find-face + address gnus-picon-user-directories) + (gnus-picon-find-face + (concat "unknown@" + (mapconcat + 'identity (cdr spec) ".")) + gnus-picon-user-directories))) + (setcar spec (cons (gnus-picon-create-glyph file) + (car spec)))) + + (dotimes (i (- (length spec) + (if gnus-picon-inhibit-top-level-domains + 2 1))) + (when (setq file (gnus-picon-find-face + (concat "unknown@" + (mapconcat + 'identity (nthcdr (1+ i) spec) ".")) + gnus-picon-domain-directories t)) + (setcar (nthcdr (1+ i) spec) + (cons (gnus-picon-create-glyph file) + (nth (1+ i) spec))))) + (setq spec (nreverse spec)) + (push (cons address spec) gnus-picon-cache)) + + (gnus-article-goto-header header) + (mail-header-narrow-to-field) + (case gnus-picon-style + (right + (when (= (length addresses) 1) + (setq len (apply '+ (mapcar (lambda (x) + (condition-case nil + (car (image-size (car x))) + (error 0))) spec))) + (when (> len 0) + (goto-char (point-at-eol)) + (insert (propertize + " " 'display + (cons 'space + (list :align-to (- (window-width) 1 len)))))) + (goto-char (point-at-eol)) + (setq point (point-at-eol)) + (dolist (image spec) + (unless (stringp image) + (goto-char point) + (gnus-picon-insert-glyph image category 'nostring))))) + (inline + (when (search-forward address nil t) + (delete-region (match-beginning 0) (match-end 0)) + (setq point (point)) + (while spec + (goto-char point) + (if (> (length spec) 2) + (insert ".") + (if (= (length spec) 2) + (insert "@"))) + (gnus-picon-insert-glyph (pop spec) category)))))))))) (defun gnus-picon-transform-newsgroups (header) (interactive) (gnus-with-article-headers - (let ((groups - (sort - (message-tokenize-header (mail-fetch-field header)) - (lambda (g1 g2) (> (length g1) (length g2))))) - spec file) - (dolist (group groups) - (setq spec (nreverse (split-string group "[.]"))) - (dotimes (i (length spec)) - (when (setq file (gnus-picon-find-face - (concat "unknown@" - (mapconcat - 'identity (nthcdr i spec) ".")) - gnus-picon-news-directories t)) - (setcar (nthcdr i spec) (gnus-picon-create-glyph file)))) - - (gnus-article-goto-header header) - (mail-header-narrow-to-field) - (when (search-forward group nil t) - (delete-region (match-beginning 0) (match-end 0)) - (setq spec (nreverse spec)) - (while spec - (gnus-picon-insert-glyph (pop spec)) - (when spec - (insert ".")))))))) + (gnus-article-goto-header header) + (mail-header-narrow-to-field) + (let ((groups (message-tokenize-header (mail-fetch-field header))) + spec file point) + (dolist (group groups) + (unless (setq spec (cdr (assoc group gnus-picon-cache))) + (setq spec (nreverse (split-string group "[.]"))) + (dotimes (i (length spec)) + (when (setq file (gnus-picon-find-face + (concat "unknown@" + (mapconcat + 'identity (nthcdr i spec) ".")) + gnus-picon-news-directories t)) + (setcar (nthcdr i spec) + (cons (gnus-picon-create-glyph file) + (nth i spec))))) + (push (cons group spec) gnus-picon-cache)) + (when (search-forward group nil t) + (delete-region (match-beginning 0) (match-end 0)) + (save-restriction + (narrow-to-region (point) (point)) + (while spec + (goto-char (point-min)) + (if (> (length spec) 1) + (insert ".")) + (gnus-picon-insert-glyph (pop spec) 'newsgroups-picon)) + (goto-char (point-max)))))))) ;;; Commands: +;; #### NOTE: the test for buffer-read-only is the same as in +;; article-display-[x-]face. See the comment up there. + +;;;###autoload (defun gnus-treat-from-picon () + "Display picons in the From header. +If picons are already displayed, remove them." (interactive) - (gnus-picon-transform-address "from")) + (let ((wash-picon-p buffer-read-only)) + (gnus-with-article-buffer + (if (and wash-picon-p (memq 'from-picon gnus-article-wash-types)) + (gnus-delete-images 'from-picon) + (gnus-picon-transform-address "from" 'from-picon))))) +;;;###autoload (defun gnus-treat-mail-picon () + "Display picons in the Cc and To headers. +If picons are already displayed, remove them." (interactive) - (gnus-picon-transform-address "cc") - (gnus-picon-transform-address "to")) - + (let ((wash-picon-p buffer-read-only)) + (gnus-with-article-buffer + (if (and wash-picon-p (memq 'mail-picon gnus-article-wash-types)) + (gnus-delete-images 'mail-picon) + (gnus-picon-transform-address "cc" 'mail-picon) + (gnus-picon-transform-address "to" 'mail-picon))))) + +;;;###autoload (defun gnus-treat-newsgroups-picon () + "Display picons in the Newsgroups and Followup-To headers. +If picons are already displayed, remove them." (interactive) - (gnus-picon-transform-newsgroups "newsgroups") - (gnus-picon-transform-newsgroups "followup-to")) + (let ((wash-picon-p buffer-read-only)) + (gnus-with-article-buffer + (if (and wash-picon-p (memq 'newsgroups-picon gnus-article-wash-types)) + (gnus-delete-images 'newsgroups-picon) + (gnus-picon-transform-newsgroups "newsgroups") + (gnus-picon-transform-newsgroups "followup-to"))))) (provide 'gnus-picon)