Require 'timezone.

(lsdb-entry-type-alist): Add setting for 'last-date.
(lsdb-after-update-record-functions): Rename from lsdb-update-record-functions.
(lsdb-after-delete-record-functions): Rename from lsdb-delete-record-functions.
(lsdb-strip-address): New user option.
(lsdb-update-records-and-display): Move belong-to-user logic to
lsdb-display-record.
(lsdb-gnus-update-record): If an article's Date: field is older than
'last-date, don't attempt to collect information from the article.

diff --git a/lsdb.el b/lsdb.el
index 72a8405..4f8fa9b 100644 (file)
--- a/lsdb.el
+++ b/lsdb.el
@@ -61,6 +61,7 @@
 (require 'pces)
 (require 'mime)
 (require 'static)
 (require 'pces)
 (require 'mime)
 (require 'static)

+(require 'timezone)

 
 ;;;_* USER CUSTOMIZATION VARIABLES:
 (defgroup lsdb nil
 
 ;;;_* USER CUSTOMIZATION VARIABLES:
 (defgroup lsdb nil

@@ -119,7 +120,8 @@ where the last three elements are optional."
     (aka 4 ?,)
     (score -1)
     (x-face -1)
     (aka 4 ?,)
     (score -1)
     (x-face -1)

-    (sender -1))
+    (sender -1)
+    (last-date -1))

   "Alist of entry types for presentation.
 The format of elements of this list should be
      (ENTRY SCORE [CLASS READ-ONLY])
   "Alist of entry types for presentation.
 The format of elements of this list should be
      (ENTRY SCORE [CLASS READ-ONLY])

@@ -151,14 +153,14 @@ The sender is passed to each function as the argument."
   :group 'lsdb
   :type 'hook)
 
   :group 'lsdb
   :type 'hook)
 

-(defcustom lsdb-update-record-functions
+(defcustom lsdb-after-update-record-functions

   '(lsdb-update-address-cache)
   "List of functions called after a record is updated.
 The updated record is passed to each function as the argument."
   :group 'lsdb
   :type 'hook)
 
   '(lsdb-update-address-cache)
   "List of functions called after a record is updated.
 The updated record is passed to each function as the argument."
   :group 'lsdb
   :type 'hook)
 

-(defcustom lsdb-delete-record-functions
+(defcustom lsdb-after-delete-record-functions

   '(lsdb-delete-address-cache)
   "List of functions called after a record is removed.
 The removed record is passed to each function as the argument."
   '(lsdb-delete-address-cache)
   "List of functions called after a record is removed.
 The removed record is passed to each function as the argument."

@@ -251,6 +253,11 @@ Bourne shell or its equivalent \(not tcsh) is needed for \"2>\"."
   :type 'boolean
   :group 'lsdb)
 
   :type 'boolean
   :group 'lsdb)
 

+(defcustom lsdb-strip-address nil
+  "If non-nil, strip display-name from sender address before completion."
+  :group 'lsdb
+  :type 'boolean)
+

 ;;;_. Faces
 (defface lsdb-header-face
   '((t (:underline t)))
 ;;;_. Faces
 (defface lsdb-header-face
   '((t (:underline t)))

@@ -535,7 +542,7 @@ This is the current number of slots in HASH-TABLE, whether occupied or not."
       (lsdb-maphash
        (lambda (key value)
         (run-hook-with-args
       (lsdb-maphash
        (lambda (key value)
         (run-hook-with-args

-         'lsdb-update-record-functions
+         'lsdb-after-update-record-functions

          (cons key value)))
        lsdb-hash-table)))
 
          (cons key value)))
        lsdb-hash-table)))
 

@@ -629,11 +636,11 @@ This is the current number of slots in HASH-TABLE, whether occupied or not."
                               (cdr record)))))
       (lsdb-puthash (car record) (cdr record)
                    lsdb-hash-table)
                               (cdr record)))))
       (lsdb-puthash (car record) (cdr record)
                    lsdb-hash-table)

-      (run-hook-with-args 'lsdb-update-record-functions record)
+      (run-hook-with-args 'lsdb-after-update-record-functions record)

       (setq lsdb-hash-tables-are-dirty t))
     record))
 
       (setq lsdb-hash-tables-are-dirty t))
     record))
 

-(defun lsdb-update-records ()
+(defun lsdb-update-records (&optional last-date)

   (lsdb-maybe-load-hash-tables)
   (let (senders recipients interesting alist records bodies entry)
     (save-restriction
   (lsdb-maybe-load-hash-tables)
   (let (senders recipients interesting alist records bodies entry)
     (save-restriction

@@ -667,6 +674,8 @@ This is the current number of slots in HASH-TABLE, whether occupied or not."
                        bodies))
                interesting))
        (setq alist (cdr alist))))
                        bodies))
                interesting))
        (setq alist (cdr alist))))

+    (if last-date
+       (push (cons 'last-date last-date) interesting))

     (if senders
        (setq records (list (lsdb-update-record (pop senders) interesting))))
     (setq alist (nconc senders recipients))
     (if senders
        (setq records (list (lsdb-update-record (pop senders) interesting))))
     (setq alist (nconc senders recipients))

@@ -717,23 +726,17 @@ This is the current number of slots in HASH-TABLE, whether occupied or not."
        (lsdb-fit-window-to-buffer window)))))
 
 (defun lsdb-update-records-and-display ()
        (lsdb-fit-window-to-buffer window)))))
 
 (defun lsdb-update-records-and-display ()

-  (let ((records (lsdb-update-records)))
-    (if lsdb-display-records-belong-to-user
-       (if records
-           (lsdb-display-record (car records))
-         (lsdb-hide-buffer))
-      (catch 'lsdb-show-record
-       (while records
-         (if (member user-mail-address (cdr (assq 'net (car records))))
-             (setq records (cdr records))
-           (lsdb-display-record (car records))
-           (throw 'lsdb-show-record t)))
-       (lsdb-hide-buffer)))))
+  (lsdb-maybe-load-hash-tables)
+  (lsdb-display-record (car (lsdb-update-records))))

 
 (defun lsdb-display-record (record)
   "Display only one RECORD, then shrink the window as possible."
 
 (defun lsdb-display-record (record)
   "Display only one RECORD, then shrink the window as possible."

-  (let ((temp-buffer-show-function lsdb-temp-buffer-show-function))
-    (lsdb-display-records (list record))))
+  (if (and record
+          (or lsdb-display-records-belong-to-user
+              (member user-mail-address (cdr (assq 'net record)))))
+      (let ((temp-buffer-show-function lsdb-temp-buffer-show-function))
+       (lsdb-display-records (list record)))
+    (lsdb-hide-buffer)))

 
 (defun lsdb-display-records (records)
   (with-current-buffer (get-buffer-create lsdb-buffer-name)
 
 (defun lsdb-display-records (records)
   (with-current-buffer (get-buffer-create lsdb-buffer-name)

@@ -850,8 +853,10 @@ This is the current number of slots in HASH-TABLE, whether occupied or not."
                                 (lambda (candidate)
                                   (if (string-match pattern candidate)
                                       candidate))
                                 (lambda (candidate)
                                   (if (string-match pattern candidate)
                                       candidate))

-                                (append (cdr (assq 'net value))
-                                        (cdr (assq 'sender value))))))))
+                                (if lsdb-strip-address
+                                    (cdr (assq 'net value))
+                                  (append (cdr (assq 'net value))
+                                          (cdr (assq 'sender value)))))))))

        lsdb-hash-table)
       ;; Sort candidates by the position where the pattern occurred.
       (setq lsdb-last-candidates
        lsdb-hash-table)
       ;; Sort candidates by the position where the pattern occurred.
       (setq lsdb-last-candidates

@@ -1012,7 +1017,7 @@ Modify whole identification by side effect."
 (defun lsdb-delete-record (record)
   "Delete given RECORD."
   (lsdb-remhash (car record) lsdb-hash-table)
 (defun lsdb-delete-record (record)
   "Delete given RECORD."
   (lsdb-remhash (car record) lsdb-hash-table)

-  (run-hook-with-args 'lsdb-delete-record-functions record)
+  (run-hook-with-args 'lsdb-after-delete-record-functions record)

   (setq lsdb-hash-tables-are-dirty t))
 
 (defun lsdb-current-entry ()
   (setq lsdb-hash-tables-are-dirty t))
 
 (defun lsdb-current-entry ()

@@ -1041,7 +1046,7 @@ Modify whole identification by side effect."
   (setcdr record (delq entry (cdr record)))
   (lsdb-puthash (car record) (cdr record)
                lsdb-hash-table)
   (setcdr record (delq entry (cdr record)))
   (lsdb-puthash (car record) (cdr record)
                lsdb-hash-table)

-  (run-hook-with-args 'lsdb-update-record-functions record)
+  (run-hook-with-args 'lsdb-after-update-record-functions record)

   (setq lsdb-hash-tables-are-dirty t))
 
 (defun lsdb-mode-add-entry (entry-name)
   (setq lsdb-hash-tables-are-dirty t))
 
 (defun lsdb-mode-add-entry (entry-name)

@@ -1068,7 +1073,7 @@ Modify whole identification by side effect."
              (setcdr record (cons (cons ',entry-name form) (cdr record)))
              (lsdb-puthash (car record) (cdr record)
                            lsdb-hash-table)
              (setcdr record (cons (cons ',entry-name form) (cdr record)))
              (lsdb-puthash (car record) (cdr record)
                            lsdb-hash-table)

-             (run-hook-with-args 'lsdb-update-record-functions record)
+             (run-hook-with-args 'lsdb-after-update-record-functions record)

              (setq lsdb-hash-tables-are-dirty t)
              (beginning-of-line 2)
              (add-text-properties
              (setq lsdb-hash-tables-are-dirty t)
              (beginning-of-line 2)
              (add-text-properties

@@ -1155,7 +1160,7 @@ then the entire entry will be deleted."
                 (entry (assq entry-name (cdr record))))
            (unless (equal form (cdr entry))
              (setcdr entry form)
                 (entry (assq entry-name (cdr record))))
            (unless (equal form (cdr entry))
              (setcdr entry form)

-             (run-hook-with-args 'lsdb-update-record-functions record)
+             (run-hook-with-args 'lsdb-after-update-record-functions record)

              (setq lsdb-hash-tables-are-dirty t)
              (with-current-buffer lsdb-buffer-name
                (let ((inhibit-read-only t)
              (setq lsdb-hash-tables-are-dirty t)
              (with-current-buffer lsdb-buffer-name
                (let ((inhibit-read-only t)

@@ -1190,7 +1195,7 @@ then the entire entry will be deleted."
            (lsdb-delete-record record)
            (setcar record new-name)
            (lsdb-puthash new-name (cdr record) lsdb-hash-table)
            (lsdb-delete-record record)
            (setcar record new-name)
            (lsdb-puthash new-name (cdr record) lsdb-hash-table)

-           (run-hook-with-args 'lsdb-update-record-functions record)
+           (run-hook-with-args 'lsdb-after-update-record-functions record)

            (setq lsdb-hash-tables-are-dirty t)
            (with-current-buffer lsdb-buffer-name
              (let ((inhibit-read-only t)
            (setq lsdb-hash-tables-are-dirty t)
            (with-current-buffer lsdb-buffer-name
              (let ((inhibit-read-only t)

@@ -1430,6 +1435,11 @@ of the buffer."
     (set-window-configuration window-configuration)))
 
 ;;;_. Interface to Semi-gnus
     (set-window-configuration window-configuration)))
 
 ;;;_. Interface to Semi-gnus

+(eval-when-compile
+  (condition-case nil
+      (require 'nnheader)
+    (error)))
+

 ;;;###autoload
 (defun lsdb-gnus-insinuate ()
   "Call this function to hook LSDB into Semi-gnus."
 ;;;###autoload
 (defun lsdb-gnus-insinuate ()
   "Call this function to hook LSDB into Semi-gnus."

@@ -1438,10 +1448,30 @@ of the buffer."
 
 (defvar gnus-article-current-summary)
 (defvar gnus-original-article-buffer)
 
 (defvar gnus-article-current-summary)
 (defvar gnus-original-article-buffer)

+(defvar gnus-current-headers)

 (defun lsdb-gnus-update-record ()
   (with-current-buffer (with-current-buffer gnus-article-current-summary
                         gnus-original-article-buffer)
 (defun lsdb-gnus-update-record ()
   (with-current-buffer (with-current-buffer gnus-article-current-summary
                         gnus-original-article-buffer)

-    (lsdb-update-records-and-display)))
+    (lsdb-maybe-load-hash-tables)
+    (let* ((sender (lsdb-extract-address-components
+                   (mail-header-from gnus-current-headers)))
+          (date (mail-header-date gnus-current-headers))
+          (current-date (format-time-string "%Y%m%d%H:%M:%S"))
+          (record (lsdb-gethash (car sender) lsdb-hash-table))
+          (last-date (or (cdr (assq 'last-date record))
+                         current-date))
+          article-date)
+      (if (or (null record)
+             (null date)               ;Without Date: header?
+             (and (string-lessp (setq article-date
+                                      (timezone-make-date-sortable date))
+                                current-date)
+                  (string-lessp last-date article-date)))
+         (setq record (car (lsdb-update-records
+                            (or article-date current-date)))))
+      (lsdb-display-record (if (stringp (car record)) ;Record is up to date.
+                              record
+                            (cons (car sender) record))))))

 
 ;;;_. Interface to Wanderlust
 ;;;###autoload
 
 ;;;_. Interface to Wanderlust
 ;;;###autoload

@@ -1582,7 +1612,7 @@ always hide."
                                    (cdr (car records))))
        (lsdb-puthash (car (car records)) (cdr (car records))
                      lsdb-hash-table)
                                    (cdr (car records))))
        (lsdb-puthash (car (car records)) (cdr (car records))
                      lsdb-hash-table)

-       (run-hook-with-args 'lsdb-update-record-functions (car records))
+       (run-hook-with-args 'lsdb-after-update-record-functions (car records))

        (setq lsdb-hash-tables-are-dirty t)))))
 
 (defun lsdb-mu-get-prefix-method ()
        (setq lsdb-hash-tables-are-dirty t)))))
 
 (defun lsdb-mu-get-prefix-method ()