1;;; gnus-picon.el --- displaying pretty icons in Gnus 2 3;; Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 4;; 2005, 2006, 2007 Free Software Foundation, Inc. 5 6;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org> 7;; Keywords: news xpm annotation glyph faces 8 9;; This file is part of GNU Emacs. 10 11;; GNU Emacs is free software; you can redistribute it and/or modify 12;; it under the terms of the GNU General Public License as published by 13;; the Free Software Foundation; either version 2, or (at your option) 14;; any later version. 15 16;; GNU Emacs is distributed in the hope that it will be useful, 17;; but WITHOUT ANY WARRANTY; without even the implied warranty of 18;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 19;; GNU General Public License for more details. 20 21;; You should have received a copy of the GNU General Public License 22;; along with GNU Emacs; see the file COPYING. If not, write to the 23;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, 24;; Boston, MA 02110-1301, USA. 25 26;;; Commentary: 27 28;; There are three picon types relevant to Gnus: 29;; 30;; Persons: person@subdomain.dom 31;; users/dom/subdomain/person/face.gif 32;; usenix/dom/subdomain/person/face.gif 33;; misc/MISC/person/face.gif 34;; Domains: subdomain.dom 35;; domain/dom/subdomain/unknown/face.gif 36;; Groups: comp.lang.lisp 37;; news/comp/lang/lisp/unknown/face.gif 38;; 39;; Original implementation by Wes Hardaker <hardaker@ece.ucdavis.edu>. 40;; 41;;; Code: 42 43(eval-when-compile (require 'cl)) 44 45(require 'gnus) 46(require 'gnus-art) 47 48;;; User variables: 49 50(defcustom gnus-picon-news-directories '("news") 51 "*List of directories to search for newsgroups faces." 52 :type '(repeat string) 53 :group 'gnus-picon) 54 55(defcustom gnus-picon-user-directories '("users" "usenix" "local" "misc") 56 "*List of directories to search for user faces." 57 :type '(repeat string) 58 :group 'gnus-picon) 59 60(defcustom gnus-picon-domain-directories '("domains") 61 "*List of directories to search for domain faces. 62Some people may want to add \"unknown\" to this list." 63 :type '(repeat string) 64 :group 'gnus-picon) 65 66(defcustom gnus-picon-file-types 67 (let ((types (list "xbm"))) 68 (when (gnus-image-type-available-p 'gif) 69 (push "gif" types)) 70 (when (gnus-image-type-available-p 'xpm) 71 (push "xpm" types)) 72 types) 73 "*List of suffixes on picon file names to try." 74 :type '(repeat string) 75 :group 'gnus-picon) 76 77(defface gnus-picon-xbm '((t (:foreground "black" :background "white"))) 78 "Face to show xbm picon in." 79 :group 'gnus-picon) 80;; backward-compatibility alias 81(put 'gnus-picon-xbm-face 'face-alias 'gnus-picon-xbm) 82 83(defface gnus-picon '((t (:foreground "black" :background "white"))) 84 "Face to show picon in." 85 :group 'gnus-picon) 86;; backward-compatibility alias 87(put 'gnus-picon-face 'face-alias 'gnus-picon) 88 89;;; Internal variables: 90 91(defvar gnus-picon-setup-p nil) 92(defvar gnus-picon-glyph-alist nil 93 "Picon glyphs cache. 94List of pairs (KEY . GLYPH) where KEY is either a filename or an URL.") 95(defvar gnus-picon-cache nil) 96 97;;; Functions: 98 99(defsubst gnus-picon-split-address (address) 100 (setq address (split-string address "@")) 101 (if (stringp (cadr address)) 102 (cons (car address) (split-string (cadr address) "\\.")) 103 (if (stringp (car address)) 104 (split-string (car address) "\\.")))) 105 106(defun gnus-picon-find-face (address directories &optional exact) 107 (let* ((address (gnus-picon-split-address address)) 108 (user (pop address)) 109 (faddress address) 110 database directory result instance base) 111 (catch 'found 112 (dolist (database gnus-picon-databases) 113 (dolist (directory directories) 114 (setq address faddress 115 base (expand-file-name directory database)) 116 (while address 117 (when (setq result (gnus-picon-find-image 118 (concat base "/" (mapconcat 'downcase 119 (reverse address) 120 "/") 121 "/" (downcase user) "/"))) 122 (throw 'found result)) 123 (if exact 124 (setq address nil) 125 (pop address))) 126 ;; Kludge to search MISC as well. But not in "news". 127 (unless (string= directory "news") 128 (when (setq result (gnus-picon-find-image 129 (concat base "/MISC/" user "/"))) 130 (throw 'found result)))))))) 131 132(defun gnus-picon-find-image (directory) 133 (let ((types gnus-picon-file-types) 134 found type file) 135 (while (and (not found) 136 (setq type (pop types))) 137 (setq found (file-exists-p (setq file (concat directory "face." type))))) 138 (if found 139 file 140 nil))) 141 142(defun gnus-picon-insert-glyph (glyph category) 143 "Insert GLYPH into the buffer. 144GLYPH can be either a glyph or a string." 145 (if (stringp glyph) 146 (insert glyph) 147 (gnus-add-wash-type category) 148 (gnus-add-image category (car glyph)) 149 (gnus-put-image (car glyph) (cdr glyph) category))) 150 151(defun gnus-picon-create-glyph (file) 152 (or (cdr (assoc file gnus-picon-glyph-alist)) 153 (cdar (push (cons file (gnus-create-image file)) 154 gnus-picon-glyph-alist)))) 155 156;;; Functions that does picon transformations: 157 158(defun gnus-picon-transform-address (header category) 159 (gnus-with-article-headers 160 (let ((addresses 161 (mail-header-parse-addresses 162 ;; mail-header-parse-addresses does not work (reliably) on 163 ;; decoded headers. 164 (or 165 (ignore-errors 166 (mail-encode-encoded-word-string 167 (or (mail-fetch-field header) ""))) 168 (mail-fetch-field header)))) 169 spec file point cache) 170 (dolist (address addresses) 171 (setq address (car address)) 172 (when (and (stringp address) 173 (setq spec (gnus-picon-split-address address))) 174 (if (setq cache (cdr (assoc address gnus-picon-cache))) 175 (setq spec cache) 176 (when (setq file (or (gnus-picon-find-face 177 address gnus-picon-user-directories) 178 (gnus-picon-find-face 179 (concat "unknown@" 180 (mapconcat 181 'identity (cdr spec) ".")) 182 gnus-picon-user-directories))) 183 (setcar spec (cons (gnus-picon-create-glyph file) 184 (car spec)))) 185 186 (dotimes (i (1- (length spec))) 187 (when (setq file (gnus-picon-find-face 188 (concat "unknown@" 189 (mapconcat 190 'identity (nthcdr (1+ i) spec) ".")) 191 gnus-picon-domain-directories t)) 192 (setcar (nthcdr (1+ i) spec) 193 (cons (gnus-picon-create-glyph file) 194 (nth (1+ i) spec))))) 195 (setq spec (nreverse spec)) 196 (push (cons address spec) gnus-picon-cache)) 197 198 (gnus-article-goto-header header) 199 (mail-header-narrow-to-field) 200 (when (search-forward address nil t) 201 (delete-region (match-beginning 0) (match-end 0)) 202 (setq point (point)) 203 (while spec 204 (goto-char point) 205 (if (> (length spec) 2) 206 (insert ".") 207 (if (= (length spec) 2) 208 (insert "@"))) 209 (gnus-picon-insert-glyph (pop spec) category)))))))) 210 211(defun gnus-picon-transform-newsgroups (header) 212 (interactive) 213 (gnus-with-article-headers 214 (gnus-article-goto-header header) 215 (mail-header-narrow-to-field) 216 (let ((groups (message-tokenize-header (mail-fetch-field header))) 217 spec file point) 218 (dolist (group groups) 219 (unless (setq spec (cdr (assoc group gnus-picon-cache))) 220 (setq spec (nreverse (split-string group "[.]"))) 221 (dotimes (i (length spec)) 222 (when (setq file (gnus-picon-find-face 223 (concat "unknown@" 224 (mapconcat 225 'identity (nthcdr i spec) ".")) 226 gnus-picon-news-directories t)) 227 (setcar (nthcdr i spec) 228 (cons (gnus-picon-create-glyph file) 229 (nth i spec))))) 230 (push (cons group spec) gnus-picon-cache)) 231 (when (search-forward group nil t) 232 (delete-region (match-beginning 0) (match-end 0)) 233 (save-restriction 234 (narrow-to-region (point) (point)) 235 (while spec 236 (goto-char (point-min)) 237 (if (> (length spec) 1) 238 (insert ".")) 239 (gnus-picon-insert-glyph (pop spec) 'newsgroups-picon)) 240 (goto-char (point-max)))))))) 241 242;;; Commands: 243 244;; #### NOTE: the test for buffer-read-only is the same as in 245;; article-display-[x-]face. See the comment up there. 246 247;;;###autoload 248(defun gnus-treat-from-picon () 249 "Display picons in the From header. 250If picons are already displayed, remove them." 251 (interactive) 252 (let ((wash-picon-p buffer-read-only)) 253 (gnus-with-article-buffer 254 (if (and wash-picon-p (memq 'from-picon gnus-article-wash-types)) 255 (gnus-delete-images 'from-picon) 256 (gnus-picon-transform-address "from" 'from-picon))) 257 )) 258 259;;;###autoload 260(defun gnus-treat-mail-picon () 261 "Display picons in the Cc and To headers. 262If picons are already displayed, remove them." 263 (interactive) 264 (let ((wash-picon-p buffer-read-only)) 265 (gnus-with-article-buffer 266 (if (and wash-picon-p (memq 'mail-picon gnus-article-wash-types)) 267 (gnus-delete-images 'mail-picon) 268 (gnus-picon-transform-address "cc" 'mail-picon) 269 (gnus-picon-transform-address "to" 'mail-picon))) 270 )) 271 272;;;###autoload 273(defun gnus-treat-newsgroups-picon () 274 "Display picons in the Newsgroups and Followup-To headers. 275If picons are already displayed, remove them." 276 (interactive) 277 (let ((wash-picon-p buffer-read-only)) 278 (gnus-with-article-buffer 279 (if (and wash-picon-p (memq 'newsgroups-picon gnus-article-wash-types)) 280 (gnus-delete-images 'newsgroups-picon) 281 (gnus-picon-transform-newsgroups "newsgroups") 282 (gnus-picon-transform-newsgroups "followup-to"))) 283 )) 284 285(provide 'gnus-picon) 286 287;;; arch-tag: fe9aede0-1b1b-463a-b4ab-807f98bcb31f 288;;; gnus-picon.el ends here 289