X-Git-Url: http://git.chise.org/gitweb/?a=blobdiff_plain;f=lisp%2Fgnus-picon.el;h=e52752341accc5117fe86495c3631c3c30478a51;hb=2ee42624a6069cf91f228bdf578e3e5d1f044d5d;hp=cd85fbbf51cda74ce6547843580fc72fe801c0c1;hpb=b008f17a2c9cff5c7c0b0c669d54aba93c561a23;p=elisp%2Fgnus.git-
diff --git a/lisp/gnus-picon.el b/lisp/gnus-picon.el
index cd85fbb..e527523 100644
--- a/lisp/gnus-picon.el
+++ b/lisp/gnus-picon.el
@@ -25,6 +25,8 @@
;;; Code:
+(eval-when-compile (require 'cl))
+
(require 'gnus)
;; (require 'xpm)
(require 'annotations)
@@ -87,17 +89,6 @@ Some people may want to add \"unknown\" to this list."
: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
@@ -107,9 +98,9 @@ Some people may want to add \"unknown\" to this list."
(when (featurep 'x)
(let ((types (list "xbm")))
(when (featurep 'gif)
- (push "gif" types))
+ (setq types (cons "gif" types)))
(when (featurep 'xpm)
- (push "xpm" types))
+ (setq types (cons "xpm" types)))
types))
"*List of suffixes on picon file names to try."
:type '(repeat string)
@@ -258,48 +249,6 @@ arguments necessary for the job.")
(set-extent-property annot 'duplicable t)
annot))
-(defun gnus-picons-article-display-x-face ()
- "Display the x-face header bitmap in the 'gnus-picons-display-where buffer."
- (let ((gnus-article-x-face-command 'gnus-picons-display-x-face))
- (gnus-article-display-x-face)))
-
-(defun gnus-picons-x-face-sentinel (process event)
- (when (memq process gnus-picons-processes-alist)
- (setq gnus-picons-processes-alist
- (delq process gnus-picons-processes-alist))
- (gnus-picons-set-buffer)
- (gnus-picons-make-annotation
- (make-glyph gnus-picons-x-face-file-name) nil 'text)
- (when (file-exists-p gnus-picons-x-face-file-name)
- (delete-file gnus-picons-x-face-file-name))))
-
-(defun gnus-picons-display-x-face (beg end)
- "Function to display the x-face header in the picons window.
-To use: (setq gnus-article-x-face-command 'gnus-picons-display-x-face)"
- (interactive)
- (if (featurep 'xface)
- ;; Use builtin support
- (save-excursion
- ;; Don't remove this binding, it is really needed: when
- ;; `gnus-picons-set-buffer' changes buffer (like when it is
- ;; set to display picons outside of the article buffer), BEG
- ;; and END still refer the buffer current now !
- (let ((buf (current-buffer)))
- (gnus-picons-set-buffer)
- (gnus-picons-make-annotation
- (vector 'xface
- :data (concat "X-Face: " (buffer-substring beg end buf)))
- nil 'text nil nil nil t)))
- ;; convert the x-face header to a .xbm file
- (let* ((process-connection-type nil)
- (process (start-process-shell-command
- "gnus-x-face" nil gnus-picons-convert-x-face)))
- (push process gnus-picons-processes-alist)
- (process-kill-without-query process)
- (set-process-sentinel process 'gnus-picons-x-face-sentinel)
- (process-send-region process beg end)
- (process-send-eof process))))
-
(defun gnus-article-display-picons ()
"Display faces for an author and her domain in gnus-picons-display-where."
(interactive)
@@ -307,8 +256,9 @@ To use: (setq gnus-article-x-face-command 'gnus-picons-display-x-face)"
(when (and (featurep 'xpm)
(or (not (fboundp 'device-type)) (equal (device-type) 'x))
(setq from (mail-fetch-field "from"))
- (setq from (downcase (or (cadr (mail-extract-address-components
- from))
+ (setq from (downcase (or (cadr
+ (funcall gnus-extract-address-components
+ from))
"")))
(or (setq at-idx (string-match "@" from))
(setq at-idx (length from))))
@@ -374,7 +324,8 @@ To use: (setq gnus-article-x-face-command 'gnus-picons-display-x-face)"
(gnus-put-text-property
(match-beginning 0) (match-end 0)
'invisible t)
- (article-goto-body)
+ (let ((article-goto-body-goes-to-point-min-p nil))
+ (article-goto-body))
(unless (bobp)
(backward-char 1)))))
(if (null gnus-picons-piconsearch-url)
@@ -574,8 +525,8 @@ none, and whose CDR is the corresponding element of DOMAINS."
(defun gnus-picons-parse-value (name)
(goto-char (point-min))
(if (re-search-forward (concat ""
- (regexp-quote name)
- " *= * *\\([^ <][^<]*\\) *")
+ (regexp-quote name)
+ " *= * *\\([^ <][^<]*\\) *")
nil t)
(buffer-substring (match-beginning 1) (match-end 1))))
@@ -592,9 +543,10 @@ none, and whose CDR is the corresponding element of DOMAINS."
(setq start-re
(concat
;; dbs
- "^\\(" (mapconcat 'identity dbs "\\|") "\\)/"
+ "^\\(" (mapconcat 'regexp-quote dbs "\\|") "\\)/"
;; host
- "\\(\\(" (replace-in-string host "\\." "/\\|" t)
+ "\\(\\(" (mapconcat 'regexp-quote
+ (message-tokenize-header host ".") "/\\|")
"/\\|MISC/\\)*\\)"
;; user
"\\(" (regexp-quote user) "\\|unknown\\)/"
@@ -662,8 +614,9 @@ none, and whose CDR is the corresponding element of DOMAINS."
;;; search job functions
(defun gnus-picons-display-bar-p ()
- (and (not (eq gnus-picons-display-where 'article))
- gnus-picons-display-as-address))
+ (if (eq gnus-picons-display-where 'article)
+ gnus-picons-display-article-move-p
+ gnus-picons-display-as-address))
(defun gnus-picons-network-search-internal (user addrs dbs sym-ann right-p
marker &optional fnames)
@@ -744,8 +697,8 @@ none, and whose CDR is the corresponding element of DOMAINS."
(defun gnus-picons-network-search (user addrs dbs sym-ann right-p marker)
(let* ((host (mapconcat 'identity addrs "."))
(key (list (or user "unknown") host (if user
- gnus-picons-user-directories
- dbs)))
+ gnus-picons-user-directories
+ dbs)))
(cache (assoc key gnus-picons-url-alist)))
(if (null cache)
(gnus-picons-url-retrieve