X-Git-Url: https://cgit.sxemacs.org/?p=gnus;a=blobdiff_plain;f=lisp%2Fgnus-picon.el;h=dc6feeec0ab4172225107333bb4620b1e677ef64;hp=c73d5eab498f328f114f840af0d3965b211e844e;hb=034742263e7ca5aed088d9b9dcfe4c456d6a26ea;hpb=7606f06d8b9dea31ec5e113044b768c76665b52a diff --git a/lisp/gnus-picon.el b/lisp/gnus-picon.el index c73d5eab4..dc6feeec0 100644 --- a/lisp/gnus-picon.el +++ b/lisp/gnus-picon.el @@ -1,27 +1,24 @@ ;;; gnus-picon.el --- displaying pretty icons in Gnus -;; Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004 -;; Free Software Foundation, Inc. +;; Copyright (C) 1996-2011 Free Software Foundation, Inc. ;; 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: @@ -40,6 +37,10 @@ ;; ;;; 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) @@ -83,17 +84,14 @@ added right to the textual representation." (const right)) :group 'gnus-picon) -(defface gnus-picon-xbm-face '((t (:foreground "black" :background "white"))) - "Face to show xbm picon in." - :group 'gnus-picon) - -(defface gnus-picon-face '((t (:foreground "black" :background "white"))) - "Face to show picon in." +(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.") @@ -158,115 +156,120 @@ replacement is added." (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: +(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-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 (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) - (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))))) - ))))) + (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 - (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)))))))) + (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: @@ -280,10 +283,9 @@ If picons are already displayed, remove them." (interactive) (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))) - )) + (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 () @@ -292,11 +294,10 @@ If picons are already displayed, remove them." (interactive) (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))) - )) + (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 () @@ -305,11 +306,10 @@ If picons are already displayed, remove them." (interactive) (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"))) - )) + (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)