From: ueno <ueno>
Date: Fri, 26 Apr 2002 02:13:03 +0000 (+0000)
Subject: * lsdb.el (lsdb-interesting-header-alist): Collect X-URL, X-URI and X-Face.
X-Git-Tag: lsdb-0_1~10
X-Git-Url: http://git.chise.org/gitweb/?a=commitdiff_plain;h=1f9261104fc758dccd3c48ccca62eaee5526ad34;p=elisp%2Flsdb.git

* lsdb.el (lsdb-interesting-header-alist): Collect X-URL, X-URI and X-Face.
(lsdb-entry-type-alist): Increase the score of 'www.
(lsdb-insert-x-face-function): New user option.
(lsdb-display-record-hook): New user option.
(lsdb-font-lock-keywords): Stop highlighting when a runaway "\r" is found.
(lsdb-display-records): New function.
(lsdb-display-record): Use it.
(lsdb-entry-score): New inline function.
(lsdb-print-record): Use it.
(lsdb-expose-x-face): New function.
(lsdb-x-face-scale-factor): New variable.
(lsdb-insert-x-face-with-x-face-e21): New function.
---

diff --git a/lsdb.el b/lsdb.el
index e19fd96..8289095 100644
--- a/lsdb.el
+++ b/lsdb.el
@@ -76,7 +76,9 @@
   '(("Organization" nil organization)
     ("\\(X-\\)?User-Agent\\|X-Mailer" nil user-agent)
     ("\\(X-\\)?ML-Name" nil mailing-list)
-    ("X-Attribution\\|X-cite-me" nil attribution))
+    ("\\(X-URL\\|X-URI\\)" nil www)
+    ("X-Attribution\\|X-cite-me" nil attribution)
+    ("X-Face" nil x-face))
   "Alist of headers we are interested in.
 The format of elements of this list should be
      (FIELD-NAME REGEXP ENTRY STRING)
@@ -87,11 +89,13 @@ where the last three elements are optional."
 (defcustom lsdb-entry-type-alist
   '((net 5 ?,)
     (creation-date 2)
-    (last-modified 2)
-    (mailing-list 3 ?,)
-    (attribution 3 ?.)
-    (organization 3)
-    (score -1))
+    (last-modified 3)
+    (mailing-list 4 ?,)
+    (attribution 4 ?.)
+    (organization 4)
+    (www 1)
+    (score -1)
+    (x-face -1))
   "Alist of entries to display.
 The format of elements of this list should be
      (ENTRY SCORE CLASS)
@@ -121,6 +125,21 @@ where the last element is optional."
   :group 'lsdb
   :type 'integer)
 
+(defcustom lsdb-insert-x-face-function
+  (if (and (>= emacs-major-version 21)
+	   (locate-library "x-face-e21"))
+      #'lsdb-insert-x-face-with-x-face-e21)
+  "Function to display X-Face."
+  :group 'lsdb
+  :type 'function)
+
+(defcustom lsdb-display-record-hook
+  (if lsdb-insert-x-face-function
+      #'lsdb-expose-x-face)
+  "A hook called after a record is displayed."
+  :group 'lsdb
+  :type 'function)
+
 ;;;_. Faces
 (defface lsdb-header-face
   '((t (:underline t)))
@@ -145,7 +164,7 @@ where the last element is optional."
 (defvar lsdb-field-body-face 'lsdb-field-body-face)
 
 (defconst lsdb-font-lock-keywords
-  '(("^\\sw.*$"
+  '(("^\\sw[^\r\n]*"
      (0 lsdb-header-face))
     ("^\t\t.*$"
      (0 lsdb-field-body-face))
@@ -430,32 +449,50 @@ This is the current number of slots in HASH-TABLE, whether occupied or not."
 	  (shrink-window-if-larger-than-buffer)))))
 
 (defun lsdb-display-record (record)
+  "Display only one RECORD, then shrink the window as possible."
   (let ((temp-buffer-show-function
 	 (function lsdb-temp-buffer-show-function)))
-    (with-output-to-temp-buffer lsdb-buffer-name
-      (set-buffer standard-output)
-      (funcall lsdb-print-record-function record)
-      (lsdb-mode))))
+    (lsdb-display-records (list record))))
+
+(defun lsdb-display-records (records)
+  (with-output-to-temp-buffer lsdb-buffer-name
+    (set-buffer standard-output)
+    (while records
+      (save-restriction
+	(narrow-to-region (point) (point))
+	(funcall lsdb-print-record-function (car records))
+	(add-text-properties (point-min) (point-max)
+			     (list 'lsdb-record (car records)
+				   ;; Forbid to expand the area the
+				   ;; text properties are effective.
+				   'start-open t ;XEmacs
+				   'rear-nonsticky t ;GNU Emacs
+				   ))
+	(run-hooks 'lsdb-display-record-hook))
+      (setq records (cdr records)))
+    (lsdb-mode)))
+
+(defsubst lsdb-entry-score (entry)
+  (or (nth 1 (assq (car entry) lsdb-entry-type-alist)) 0))
 
 (defun lsdb-print-record (record)
   (insert (car record) "\n")
   (let ((entries
 	 (sort (cdr record)
 	       (lambda (entry1 entry2)
-		 (> (or (nth 1 (assq (car entry1) lsdb-entry-type-alist))
-			0)
-		    (or (nth 1 (assq (car entry2) lsdb-entry-type-alist))
-			0))))))
+		 (> (lsdb-entry-score entry1) (lsdb-entry-score entry2))))))
     (while entries
-      (insert "\t" (capitalize (symbol-name (car (car entries)))) ": "
-	      (if (listp (cdr (car entries)))
-		  (mapconcat #'identity (cdr (car entries))
-			     (if (eq ?, (nth 2 (assq (car (car entries))
-						     lsdb-entry-type-alist)))
-				 ", "
-			       "\n\t\t"))
-		(cdr (car entries)))
-	      "\n")
+      (if (>= (lsdb-entry-score (car entries)) 0)
+	  (insert "\t" (capitalize (symbol-name (car (car entries)))) ": "
+		  (if (listp (cdr (car entries)))
+		      (mapconcat
+		       #'identity (cdr (car entries))
+		       (if (eq ?, (nth 2 (assq (car (car entries))
+					       lsdb-entry-type-alist)))
+			   ", "
+			 "\n\t\t"))
+		    (cdr (car entries)))
+		  "\n"))
       (setq entries (cdr entries)))))
 
 ;;;_. Completion
@@ -551,6 +588,28 @@ This is the current number of slots in HASH-TABLE, whether occupied or not."
     (if window
 	(delete-window window))))
 
+;;;_. X-Face Rendering
+(defun lsdb-expose-x-face ()
+  (let* ((record (get-text-property (point-min) 'lsdb-record))
+	 (x-face (cdr (assq 'x-face (cdr record)))))
+    (when (and lsdb-insert-x-face-function
+	       x-face)
+      (goto-char (point-min))
+      (end-of-line)
+      (insert (propertize "\r" 'invisible t) " ")
+      (while x-face
+	(funcall lsdb-insert-x-face-function (pop x-face))))))
+
+;; stolen (and renamed) from gnus-summary-x-face.el written by Akihiro Arisawa.
+(defvar lsdb-x-face-scale-factor 0.5
+  "A number of scale factor used to scale down X-face image.
+See also `x-face-scale-factor'.")
+
+(defun lsdb-insert-x-face-with-x-face-e21 (x-face)
+  (require 'x-face-e21)
+  (insert-image (x-face-create-image
+		 x-face :scale-factor lsdb-x-face-scale-factor)))
+
 (provide 'lsdb)
 
 ;;;_* Local emacs vars.