X-Git-Url: http://git.chise.org/gitweb/?a=blobdiff_plain;f=lsdb.el;h=2375d8f61843bcb9eaf816bd0b297df418873a98;hb=8bd153a87b98aaf799d8db495d133691bb918c36;hp=788783e5b57504785e289233ae88cd8beb58a949;hpb=cfd89faa01c1fb3a5a449491b6abbe46b1217086;p=elisp%2Flsdb.git diff --git a/lsdb.el b/lsdb.el index 788783e..2375d8f 100644 --- a/lsdb.el +++ b/lsdb.el @@ -83,8 +83,11 @@ (defcustom lsdb-interesting-header-alist '(("Organization" nil organization) - ("\\(X-\\)?User-Agent\\|X-Mailer" nil user-agent) + ("\\(X-\\)?User-Agent\\|X-Mailer\\|X-Newsreader" nil user-agent) ("\\(X-\\)?ML-Name" nil mailing-list) + ("List-Id" "\\(.*\\)[ \t]+<[^>]+>\\'" mailing-list "\\1") + ("X-Sequence" "\\(.*\\)[ \t]+[0-9]+\\'" mailing-list "\\1") + ("Delivered-To" "mailing list[ \t]+\\([^@]+\\)@.*" mailing-list "\\1") ("\\(X-URL\\|X-URI\\)" nil www) ("X-Attribution\\|X-cite-me" nil attribution) ("X-Face" nil x-face)) @@ -97,18 +100,25 @@ where the last three elements are optional." (defcustom lsdb-entry-type-alist '((net 5 ?,) - (creation-date 2) - (last-modified 3) + (creation-date 2 ?. t) + (last-modified 3 ?. t) (mailing-list 4 ?,) (attribution 4 ?.) (organization 4) - (www 1) + (www 4) + (aka 4 ?,) (score -1) (x-face -1)) - "Alist of entries to display. + "Alist of entry types for presentation. The format of elements of this list should be - (ENTRY SCORE CLASS) -where the last element is optional." + (ENTRY SCORE [CLASS READ-ONLY]) +where the last two elements are optional. +Possible values for CLASS are `?.' and '?,'. If CLASS is `?.', the +entry takes a unique value which is overridden by newly assigned one +by `lsdb-mode-edit-entry' or such a command. If CLASS is `?,', the +entry can have multiple values separated by commas. +If the fourth element READ-ONLY is non-nil, it is assumed that the +entry cannot be modified." :group 'lsdb :type 'list) @@ -123,6 +133,26 @@ where the last element is optional." :group 'lsdb :type 'function) +(defcustom lsdb-lookup-full-name-functions + '(lsdb-lookup-full-name-from-address-cache) + "List of functions to pick up the existing full-name of the sender. +The sender is passed to each function as the argument." + :group 'lsdb + :type 'hook) + +(defcustom lsdb-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) + +(defcustom lsdb-secondary-hash-tables + '(lsdb-address-cache) + "List of the hash tables for reverse lookup" + :group 'lsdb + :type 'list) + (defcustom lsdb-window-max-height 7 "Maximum number of lines used to display LSDB record." :group 'lsdb @@ -158,7 +188,20 @@ The compressed face will be piped to this command." "A predicate to sort records." :group 'lsdb :type 'function) - + +(defcustom lsdb-temp-buffer-show-function + #'lsdb-temp-buffer-show-function + "Non-nil means call as function to display a help buffer. +The function is called with one argument, the buffer to be displayed. +Overrides `temp-buffer-show-function'." + :group 'lsdb + :type 'function) + +(defcustom lsdb-pop-up-windows t + "Non-nil means LSDB should make new windows to display records." + :group 'lsdb + :type 'boolean) + (defgroup lsdb-edit-form nil "A mode for editing forms." :group 'lsdb) @@ -218,11 +261,15 @@ Bourne shell or its equivalent \(not tcsh) is needed for \"2>\"." (defvar lsdb-hash-table nil "Internal hash table to hold LSDB records.") +(defvar lsdb-address-cache nil + "The reverse lookup table for `lsdb-hash-table'. +It represents address to full-name mapping.") + (defvar lsdb-buffer-name "*LSDB*" "Buffer name to display LSDB record.") -(defvar lsdb-hash-table-is-dirty nil - "Flag to indicate whether the hash table needs to be saved.") +(defvar lsdb-hash-tables-are-dirty nil + "Flag to indicate whether the internal hash tables need to be saved.") (defvar lsdb-known-entry-names (make-vector 29 0) @@ -287,61 +334,104 @@ This is the current number of slots in HASH-TABLE, whether occupied or not." (list 0 (make-vector (or (plist-get args :size) 29) 0)))) ;;;_. Hash Table Reader/Writer +(defconst lsdb-secondary-hash-table-start-format + ";;; %S\n") + +(defsubst lsdb-secondary-hash-table-start (hash-table) + (format lsdb-secondary-hash-table-start-format hash-table)) + (eval-and-compile (condition-case nil (progn ;; In XEmacs, hash tables can also be created by the lisp reader ;; using structure syntax. (read-from-string "#s(hash-table)") - (defun lsdb-load-file (file) - "Read the contents of FILE into a hash table." - (let ((buffer (find-file-noselect file))) - (unwind-protect - (save-excursion - (set-buffer buffer) - (re-search-forward "^#s") - (beginning-of-line) - (read (point-min-marker))) - (kill-buffer buffer))))) + (defalias 'lsdb-read 'read)) (invalid-read-syntax - (defun lsdb-load-file (file) - "Read the contents of FILE into a hash table." - (let* ((plist - (with-temp-buffer - (insert-file-contents file) - (save-excursion - (re-search-forward "^#s") - (replace-match "") - (beginning-of-line) - (cdr (read (point-marker)))))) - (size (plist-get plist 'size)) - (data (plist-get plist 'data)) - (hash-table (lsdb-make-hash-table :size size :test 'equal))) - (while data - (lsdb-puthash (pop data) (pop data) hash-table)) - hash-table))))) - -(defun lsdb-save-file (file hash-table) - "Write the entries within HASH-TABLE into FILE." - (let ((coding-system-for-write lsdb-file-coding-system)) - (with-temp-file file + (defun lsdb-read (&optional marker) + "Read one Lisp expression as text from MARKER, return as Lisp object." + (save-excursion + (goto-char marker) + (if (looking-at "^#s(") + (with-temp-buffer + (buffer-disable-undo) + (insert-buffer-substring (marker-buffer marker) marker) + (goto-char (point-min)) + (delete-char 2) + (let ((object (read (current-buffer))) + hash-table data) + (if (eq 'hash-table (car object)) + (progn + (setq hash-table + (lsdb-make-hash-table + :size (plist-get (cdr object) 'size) + :test 'equal) + data (plist-get (cdr object) 'data)) + (while data + (lsdb-puthash (pop data) (pop data) hash-table)) + hash-table) + object))))))))) + +(defun lsdb-load-hash-tables () + "Read the contents of `lsdb-file' into the internal hash tables." + (let ((buffer (find-file-noselect lsdb-file)) + tables) + (unwind-protect + (save-excursion + (set-buffer buffer) + (goto-char (point-min)) + (re-search-forward "^#s(") + (goto-char (match-beginning 0)) + (setq lsdb-hash-table (lsdb-read (point-marker))) + ;; Load the secondary hash tables following. + (setq tables lsdb-secondary-hash-tables) + (while tables + (if (re-search-forward + (concat "^" (lsdb-secondary-hash-table-start + (car tables))) + nil t) + (set (car tables) (lsdb-read (point-marker)))) + (setq tables (cdr tables)))) + (kill-buffer buffer)))) + +(defun lsdb-insert-hash-table (hash-table) + (insert "#s(hash-table size " + ;; Reduce the actual size of the close hash table, because + ;; XEmacs doesn't have a distinction between index-size and + ;; hash-table-size. + (number-to-string (lsdb-hash-table-count hash-table)) + " test equal data (") + (lsdb-maphash + (lambda (key value) + (insert (prin1-to-string key) " " (prin1-to-string value) " ")) + hash-table) + (insert "))")) + +(defun lsdb-save-hash-tables () + "Write the records within the internal hash tables into `lsdb-file'." + (let ((coding-system-for-write lsdb-file-coding-system) + tables) + (with-temp-file lsdb-file (if (and (or (featurep 'mule) (featurep 'file-coding)) lsdb-file-coding-system) - (insert ";;; -*- coding: " - (if (symbolp lsdb-file-coding-system) - (symbol-name lsdb-file-coding-system) - ;; XEmacs - (symbol-name (coding-system-name lsdb-file-coding-system))) - " -*-\n")) - (insert "#s(hash-table size " - (number-to-string (lsdb-hash-table-size hash-table)) - " test equal data (") - (lsdb-maphash - (lambda (key value) - (insert (prin1-to-string key) " " (prin1-to-string value) " ")) - hash-table) - (insert "))")))) + (let ((coding-system-name + (if (symbolp lsdb-file-coding-system) + (symbol-name lsdb-file-coding-system) + ;; XEmacs + (static-if (featurep 'xemacs) + (symbol-name (coding-system-name + lsdb-file-coding-system)))))) + (if coding-system-name + (insert ";;; -*- coding: " coding-system-name " -*-\n")))) + (lsdb-insert-hash-table lsdb-hash-table) + ;; Save the secondary hash tables following. + (setq tables lsdb-secondary-hash-tables) + (while tables + (insert "\n" (lsdb-secondary-hash-table-start + (car tables))) + (lsdb-insert-hash-table (symbol-value (car tables))) + (setq tables (cdr tables)))))) ;;;_. Mail Header Extraction (defun lsdb-fetch-field-bodies (regexp) @@ -366,9 +456,9 @@ This is the current number of slots in HASH-TABLE, whether occupied or not." (let ((components (std11-extract-address-components string))) (if (nth 1 components) (if (car components) - (list (nth 1 components) - (funcall lsdb-canonicalize-full-name-function - (car components))) + (list (funcall lsdb-canonicalize-full-name-function + (car components)) + (nth 1 components)) (list (nth 1 components) (nth 1 components)))))) ;; stolen (and renamed) from nnheader.el @@ -386,23 +476,96 @@ This is the current number of slots in HASH-TABLE, whether occupied or not." (set-buffer-multibyte multibyte)))) ;;;_. Record Management -(defun lsdb-maybe-load-file () +(defun lsdb-maybe-load-secondary-hash-tables () + (let ((tables lsdb-secondary-hash-tables)) + (while tables + (unless (symbol-value (car tables)) + (set (car tables) (lsdb-make-hash-table :test 'equal)) + (lsdb-maphash + (lambda (key value) + (run-hook-with-args + 'lsdb-update-record-functions + (cons key value))) + lsdb-hash-table) + (setq lsdb-hash-tables-are-dirty t)) + (setq tables (cdr tables))))) + +(defun lsdb-maybe-load-hash-tables () (unless lsdb-hash-table (if (file-exists-p lsdb-file) - (setq lsdb-hash-table (lsdb-load-file lsdb-file)) - (setq lsdb-hash-table (lsdb-make-hash-table :test 'equal))))) - + (lsdb-load-hash-tables) + (setq lsdb-hash-table (lsdb-make-hash-table :test 'equal))) + (lsdb-maybe-load-secondary-hash-tables))) + +;;;_ : Fallback Lookup Functions +;;;_ , #1 Address Cache +(defun lsdb-lookup-full-name-from-address-cache (sender) + (lsdb-gethash (nth 1 sender) lsdb-address-cache)) + +(defun lsdb-update-address-cache (record) + (let ((net (cdr (assq 'net record)))) + (while net + (lsdb-puthash (pop net) (car record) lsdb-address-cache)))) + +;;;_ , #2 Iterate on the All Records (very slow) +(defun lsdb-lookup-full-name-by-fuzzy-matching (sender) + (let ((names + (if (string-match + "\\`\\(.+\\)[ \t]+\\(/[ \t]+\\|(\\([^)]+\\))\\)" + (car sender)) + (if (match-beginning 3) + (list (match-string 1 (car sender)) + (match-string 3 (car sender))) + (list (match-string 1 (car sender)) + (substring (car sender) (match-end 0)))) + (list (car sender)))) + (case-fold-search t)) + (catch 'found + (lsdb-maphash + (lambda (key value) + (while names + (if (or (string-match + (concat "\\<" (regexp-quote (car names)) "\\>") + key) + (string-match + (concat + "\\<" + (regexp-quote + (mapconcat #'identity + (nreverse (split-string (car names))) + " ")) + "\\>") + key) + ;; Don't assume that we are using address cache. + (member (nth 1 sender) (cdr (assq 'net value)))) + (throw 'found key)) + (setq names (cdr names)))) + lsdb-hash-table)))) + +;;;_ : Update Records (defun lsdb-update-record (sender &optional interesting) - (let ((old (lsdb-gethash (nth 1 sender) lsdb-hash-table)) - (new (cons (cons 'net (list (car sender))) + (let ((old (lsdb-gethash (car sender) lsdb-hash-table)) + (new (cons (cons 'net (list (nth 1 sender))) interesting)) merged - record) + record + full-name) + ;; Look for the existing record from the reverse hash table. + ;; If it is found, regsiter the current full-name as AKA. + (unless old + (setq full-name + (run-hook-with-args-until-success + 'lsdb-lookup-full-name-functions + sender)) + (when full-name + (setq old (lsdb-gethash full-name lsdb-hash-table) + new (cons (list 'aka (car sender)) new)) + (setcar sender full-name))) (unless old (setq new (cons (cons 'creation-date (format-time-string "%Y-%m-%d")) new))) (setq merged (lsdb-merge-record-entries old new) - record (cons (nth 1 sender) merged)) + record (cons (car sender) merged)) (unless (equal merged old) (let ((entry (assq 'last-modified (cdr record))) (last-modified (format-time-string "%Y-%m-%d"))) @@ -412,11 +575,12 @@ 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) - (setq lsdb-hash-table-is-dirty t)) + (run-hook-with-args 'lsdb-update-record-functions record) + (setq lsdb-hash-tables-are-dirty t)) record)) (defun lsdb-update-records () - (lsdb-maybe-load-file) + (lsdb-maybe-load-hash-tables) (let (senders recipients interesting alist records bodies entry) (save-restriction (std11-narrow-to-header) @@ -431,13 +595,15 @@ This is the current number of slots in HASH-TABLE, whether occupied or not." (setq alist lsdb-interesting-header-alist) (while alist (setq bodies - (mapcar - (lambda (field-body) - (if (and (nth 1 (car alist)) - (string-match (nth 1 (car alist)) field-body)) - (replace-match (nth 3 (car alist)) nil nil field-body) - field-body)) - (lsdb-fetch-field-bodies (car (car alist))))) + (delq nil (mapcar + (lambda (field-body) + (if (nth 1 (car alist)) + (and (string-match (nth 1 (car alist)) + field-body) + (replace-match (nth 3 (car alist)) + nil nil field-body)) + field-body)) + (lsdb-fetch-field-bodies (car (car alist)))))) (when bodies (setq entry (or (nth 2 (car alist)) 'notes)) @@ -474,27 +640,30 @@ This is the current number of slots in HASH-TABLE, whether occupied or not." old) ;;;_. Display Management +(defun lsdb-fit-window-to-buffer (&optional window) + (save-selected-window + (if window + (select-window window)) + (unless (pos-visible-in-window-p (point-max)) + (enlarge-window (- lsdb-window-max-height (window-height)))) + (shrink-window-if-larger-than-buffer) + (let ((height (window-height))) + (if (> height lsdb-window-max-height) + (shrink-window (- height lsdb-window-max-height))) + (set-window-start window (point-min))))) + (defun lsdb-temp-buffer-show-function (buffer) (save-selected-window (let ((window (or (get-buffer-window lsdb-buffer-name) (progn (select-window (get-largest-window)) - (split-window-vertically)))) - height) + (split-window-vertically))))) (set-window-buffer window buffer) - (select-window window) - (unless (pos-visible-in-window-p (point-max)) - (enlarge-window (- lsdb-window-max-height (window-height)))) - (shrink-window-if-larger-than-buffer) - (if (> (setq height (window-height)) - lsdb-window-max-height) - (shrink-window (- height lsdb-window-max-height))) - (set-window-start window (point-min))))) + (lsdb-fit-window-to-buffer window)))) (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))) + (let ((temp-buffer-show-function lsdb-temp-buffer-show-function)) (lsdb-display-records (list record)))) (defun lsdb-display-records (records) @@ -549,10 +718,34 @@ This is the current number of slots in HASH-TABLE, whether occupied or not." (defvar lsdb-last-candidates nil) (defvar lsdb-last-candidates-pointer nil) +;;;_ : Matching Highlight +(defvar lsdb-last-highlight-overlay nil) + +(defun lsdb-complete-name-highlight (start end) + (make-local-hook 'pre-command-hook) + (add-hook 'pre-command-hook 'lsdb-complete-name-highlight-update nil t) + (save-excursion + (goto-char start) + (search-forward lsdb-last-completion end) + (setq lsdb-last-highlight-overlay + (make-overlay (match-beginning 0) (match-end 0))) + (overlay-put lsdb-last-highlight-overlay 'face + (or (find-face 'isearch-secondary) + (find-face 'isearch-lazy-highlight-face) + 'underline)))) + +(defun lsdb-complete-name-highlight-update () + (unless (eq 'this-command 'lsdb-complete-name) + (if lsdb-last-highlight-overlay + (delete-overlay lsdb-last-highlight-overlay)) + (remove-hook 'pre-command-hook + 'lsdb-complete-name-highlight-update t))) + +;;;_ : Name Completion (defun lsdb-complete-name () "Complete the user full-name or net-address before point" (interactive) - (lsdb-maybe-load-file) + (lsdb-maybe-load-hash-tables) (let* ((start (save-excursion (re-search-backward "\\(\\`\\|[\n:,]\\)[ \t]*") @@ -565,7 +758,7 @@ This is the current number of slots in HASH-TABLE, whether occupied or not." (setq lsdb-last-candidates nil lsdb-last-candidates-pointer nil lsdb-last-completion (buffer-substring start (point)) - pattern (concat "\\<" lsdb-last-completion)) + pattern (concat "\\<" (regexp-quote lsdb-last-completion))) (lsdb-maphash (lambda (key value) (let ((net (cdr (assq 'net value)))) @@ -581,12 +774,21 @@ This is the current number of slots in HASH-TABLE, whether occupied or not." (if (string-match pattern (car net)) (push (car net) lsdb-last-candidates)) (setq net (cdr net)))))) - lsdb-hash-table)) + lsdb-hash-table) + ;; Sort candidates by the position where the pattern occurred. + (setq lsdb-last-candidates + (sort lsdb-last-candidates + (lambda (cand1 cand2) + (< (if (string-match pattern cand1) + (match-beginning 0)) + (if (string-match pattern cand2) + (match-beginning 0))))))) (unless lsdb-last-candidates-pointer (setq lsdb-last-candidates-pointer lsdb-last-candidates)) (when lsdb-last-candidates-pointer (delete-region start (point)) - (insert (pop lsdb-last-candidates-pointer))))) + (insert (pop lsdb-last-candidates-pointer)) + (lsdb-complete-name-highlight start (point))))) ;;;_. Major Mode (`lsdb-mode') Implementation ;;;_ : Modeline Buffer Identification @@ -686,14 +888,14 @@ Modify whole identification by side effect." (define-derived-mode lsdb-mode fundamental-mode "LSDB" "Major mode for browsing LSDB records." (setq buffer-read-only t) - (if (featurep 'xemacs) + (static-if (featurep 'xemacs) ;; In XEmacs, setting `font-lock-defaults' only affects on ;; `find-file-hooks'. (font-lock-set-defaults) (set (make-local-variable 'font-lock-defaults) '(lsdb-font-lock-keywords t))) - (make-local-variable 'post-command-hook) - (setq post-command-hook 'lsdb-modeline-update) + (make-local-hook 'post-command-hook) + (add-hook 'post-command-hook 'lsdb-modeline-update nil t) (make-local-variable 'lsdb-modeline-string) (setq mode-line-buffer-identification (lsdb-modeline-buffer-identification @@ -771,7 +973,8 @@ the current record." (setcdr record (cons (cons ',entry-name form) (cdr record))) (lsdb-puthash (car record) (cdr record) lsdb-hash-table) - (setq lsdb-hash-table-is-dirty t) + (run-hook-with-args 'lsdb-update-record-functions record) + (setq lsdb-hash-tables-are-dirty t) (beginning-of-line 2) (add-text-properties (point) @@ -793,7 +996,8 @@ the current record." (setcdr record (delq entry (cdr record))) (lsdb-puthash (car record) (cdr record) lsdb-hash-table) - (setq lsdb-hash-table-is-dirty t)) + (run-hook-with-args 'lsdb-update-record-functions record) + (setq lsdb-hash-tables-are-dirty t)) (save-restriction (lsdb-narrow-to-record) (let ((case-fold-search t) @@ -830,7 +1034,8 @@ the current record." (inhibit-read-only t) buffer-read-only) (setcdr entry form) - (setq lsdb-hash-table-is-dirty t) + (run-hook-with-args 'lsdb-update-record-functions record) + (setq lsdb-hash-tables-are-dirty t) (lsdb-mode-delete-entry (symbol-name ',entry-name) t) (beginning-of-line) (add-text-properties @@ -843,13 +1048,13 @@ the current record." (defun lsdb-mode-save (&optional dont-ask) "Save LSDB hash table into `lsdb-file'." (interactive) - (if (not lsdb-hash-table-is-dirty) + (if (not lsdb-hash-tables-are-dirty) (message "(No changes need to be saved)") (when (or (interactive-p) dont-ask (y-or-n-p "Save the LSDB now?")) - (lsdb-save-file lsdb-file lsdb-hash-table) - (setq lsdb-hash-table-is-dirty nil) + (lsdb-save-hash-tables) + (setq lsdb-hash-tables-are-dirty nil) (message "The LSDB was saved successfully.")))) (defun lsdb-mode-quit-window (&optional kill window) @@ -873,6 +1078,14 @@ It partially emulates the GNU Emacs' of `quit-window'." (if window (lsdb-mode-quit-window nil window)))) +(defun lsdb-mode-show-buffer () + "Show the LSDB window." + (if (get-buffer lsdb-buffer-name) + (if lsdb-temp-buffer-show-function + (pop-to-buffer (get-buffer lsdb-buffer-name)) + (funcall lsdb-temp-buffer-show-function + (get-buffer lsdb-buffer-name))))) + (defun lsdb-lookup-records (regexp &optional entry-name) "Return the all records in the LSDB matching the REGEXP. If the optional 2nd argument ENTRY-NAME is given, matching only @@ -918,7 +1131,7 @@ performed against the entry field." "Search records regexp: ") nil nil nil 'lsdb-mode-lookup-history) entry-name))) - (lsdb-maybe-load-file) + (lsdb-maybe-load-hash-tables) (let ((records (lsdb-lookup-records regexp entry-name))) (if records (lsdb-display-records records)))) @@ -1036,7 +1249,7 @@ of the buffer." (buffer-disable-undo) (mime-insert-entity entity) (setq records (lsdb-update-records)) - (when records + (when (and records lsdb-pop-up-windows) (lsdb-display-record (car records)))))) ;;;_. Interface to Wanderlust @@ -1045,7 +1258,13 @@ of the buffer." "Call this function to hook LSDB into Wanderlust." (add-hook 'wl-message-redisplay-hook 'lsdb-wl-update-record) (add-hook 'wl-summary-exit-hook 'lsdb-mode-hide-buffer) - (add-hook 'wl-exit-hook 'lsdb-mode-save)) + (add-hook 'wl-summary-toggle-disp-off-hook 'lsdb-mode-hide-buffer) + (add-hook 'wl-summary-toggle-disp-folder-on-hook 'lsdb-mode-hide-buffer) + (add-hook 'wl-summary-toggle-disp-folder-off-hook 'lsdb-mode-hide-buffer) + (add-hook 'wl-summary-toggle-disp-folder-message-resumed-hook + 'lsdb-mode-show-buffer) + (add-hook 'wl-exit-hook 'lsdb-mode-save) + (add-hook 'wl-save-hook 'lsdb-mode-save)) (eval-when-compile (autoload 'wl-message-get-original-buffer "wl-message")) @@ -1053,12 +1272,34 @@ of the buffer." (save-excursion (set-buffer (wl-message-get-original-buffer)) (let ((records (lsdb-update-records))) - (when records - (lsdb-display-record (car records)))))) + (when (and records lsdb-pop-up-windows) + (let ((lsdb-temp-buffer-show-function + #'lsdb-wl-temp-buffer-show-function)) + (lsdb-display-record (car records))))))) + +(defvar wl-current-summary-buffer) +(defvar wl-message-buffer) +(defun lsdb-wl-temp-buffer-show-function (buffer) + (save-selected-window + (let ((window (or (get-buffer-window lsdb-buffer-name) + (progn + (select-window + (or (save-excursion + (if (buffer-live-p wl-current-summary-buffer) + (set-buffer wl-current-summary-buffer)) + (get-buffer-window wl-message-buffer)) + (get-largest-window))) + (split-window-vertically))))) + (set-window-buffer window buffer) + (lsdb-fit-window-to-buffer window)))) ;;;_. Interface to Mew written by Hideyuki SHIRAI (eval-when-compile - (ignore-errors (require 'mew))) + (autoload 'mew-sinfo-get-disp-msg "mew") + (autoload 'mew-current-get-fld "mew") + (autoload 'mew-current-get-msg "mew") + (autoload 'mew-frame-id "mew") + (autoload 'mew-cache-hit "mew")) ;;;###autoload (defun lsdb-mew-insinuate () @@ -1084,7 +1325,8 @@ of the buffer." (lambda (body name) (set-text-properties 0 (length body) nil body) body)) - (when (setq records (lsdb-update-records)) + (when (and (setq records (lsdb-update-records)) + lsdb-pop-up-windows) (lsdb-display-record (car records)))))) ;;;_. Interface to MU-CITE @@ -1111,7 +1353,8 @@ of the buffer." (cdr (car records)))) (lsdb-puthash (car (car records)) (cdr (car records)) lsdb-hash-table) - (setq lsdb-hash-table-is-dirty t))))) + (run-hook-with-args 'lsdb-update-record-functions (car records)) + (setq lsdb-hash-tables-are-dirty t))))) (defun lsdb-mu-get-prefix-method () "A mu-cite method to return a prefix from LSDB or \">\". @@ -1201,11 +1444,15 @@ the user wants it." x-face) (goto-char (point-min)) (end-of-line) - (put-text-property 0 1 'invisible t delimiter) - (put-text-property 0 (length delimiter) 'lsdb-record record delimiter) - (insert delimiter) - (while x-face - (funcall lsdb-insert-x-face-function (pop x-face)))))) + (put-text-property 0 1 'invisible t delimiter) ;hide "\r" + (put-text-property + (point) + (progn + (insert delimiter) + (while x-face + (funcall lsdb-insert-x-face-function (pop x-face))) + (point)) + 'lsdb-record record)))) (defun lsdb-insert-x-face-image (data type marker) (static-if (featurep 'xemacs) @@ -1231,8 +1478,7 @@ the user wants it." 'lsdb-record record))))) (defun lsdb-insert-x-face-asynchronously (x-face) - (let* ((buffer (generate-new-buffer " *lsdb work*")) - (type (lsdb-x-face-available-image-type)) + (let* ((type (lsdb-x-face-available-image-type)) (shell-file-name lsdb-shell-file-name) (shell-command-switch lsdb-shell-command-switch) (process-connection-type nil) @@ -1243,7 +1489,7 @@ the user wants it." (lsdb-insert-x-face-image cached type marker) (setq process (start-process-shell-command - "lsdb-x-face-command" buffer + "lsdb-x-face-command" (generate-new-buffer " *lsdb work*") (concat "{ " (nth 1 (assq type lsdb-x-face-command-alist)) "; } 2> /dev/null"))) @@ -1252,21 +1498,23 @@ the user wants it." (set-process-sentinel process `(lambda (process string) - (when (equal string "finished\n") - (let ((data - (with-current-buffer ,buffer - (set-buffer-multibyte nil) - (buffer-string)))) - (lsdb-insert-x-face-image data ',type ,marker) - (lsdb-puthash ,x-face (list (cons ',type data)) - lsdb-x-face-cache))) - (kill-buffer ,buffer)))))) + (unwind-protect + (when (and (buffer-live-p (marker-buffer ,marker)) + (equal string "finished\n")) + (let ((data + (with-current-buffer (process-buffer process) + (set-buffer-multibyte nil) + (buffer-string)))) + (lsdb-insert-x-face-image data ',type ,marker) + (lsdb-puthash ,x-face (list (cons ',type data)) + lsdb-x-face-cache))) + (kill-buffer (process-buffer process)))))))) (require 'product) (provide 'lsdb) (product-provide 'lsdb - (product-define "LSDB" nil '(0 2))) + (product-define "LSDB" nil '(0 4))) ;;;_* Local emacs vars. ;;; The following `outline-layout' local variable setting: