c2983098c944aae75ea54ec16020543802b4bc82
[elisp/lsdb.git] / lsdb.el
1 ;;; lsdb.el --- the Lovely Sister Database
2
3 ;; Copyright (C) 2002 Daiki Ueno
4
5 ;; Author: Daiki Ueno <ueno@unixuser.org>
6 ;; Keywords: adress book
7
8 ;; This file is part of the Lovely Sister Database.
9
10 ;; This program is free software; you can redistribute it and/or
11 ;; modify it under the terms of the GNU General Public License as
12 ;; published by the Free Software Foundation; either version 2, or (at
13 ;; your option) any later version.
14
15 ;; This program is distributed in the hope that it will be useful, but
16 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
18 ;; General Public License for more details.
19
20 ;; You should have received a copy of the GNU General Public License
21 ;; along with this program; see the file COPYING.  If not, write to the
22 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
23 ;; Boston, MA 02111-1307, USA.
24
25 ;;; Commentary:
26
27 ;;; For Semi-gnus:
28 ;;; (autoload 'lsdb-gnus-insinuate "lsdb")
29 ;;; (autoload 'lsdb-gnus-insinuate-message "lsdb")
30 ;;; (add-hook 'gnus-startup-hook 'lsdb-gnus-insinuate)
31 ;;; (add-hook 'message-setup-hook
32 ;;;           (lambda ()
33 ;;;             (define-key message-mode-map "\M-\t" 'lsdb-complete-name)))
34 ;;; (add-hook 'gnus-summary-mode-hook
35 ;;;           (lambda ()
36 ;;;             (define-key gnus-summary-mode-map ":" 'lsdb-toggle-buffer)))
37
38 ;;; For Wanderlust, put the following lines into your ~/.wl:
39 ;;; (require 'lsdb)
40 ;;; (lsdb-wl-insinuate)
41 ;;; (add-hook 'wl-draft-mode-hook
42 ;;;           (lambda ()
43 ;;;             (define-key wl-draft-mode-map "\M-\t" 'lsdb-complete-name)))
44 ;;; (add-hook 'wl-summary-mode-hook
45 ;;;           (lambda ()
46 ;;;             (define-key wl-summary-mode-map ":" 'lsdb-wl-toggle-buffer)))
47
48 ;;; For Mew, put the following lines into your ~/.mew:
49 ;;; (autoload 'lsdb-mew-insinuate "lsdb")
50 ;;; (add-hook 'mew-init-hook 'lsdb-mew-insinuate)
51 ;;; (add-hook 'mew-draft-mode-hook
52 ;;;           (lambda ()
53 ;;;             (define-key mew-draft-header-map "\M-I" 'lsdb-complete-name)))
54 ;;; (add-hook 'mew-summary-mode-hook
55 ;;;           (lambda ()
56 ;;;             (define-key mew-summary-mode-map ":" 'lsdb-toggle-buffer)))
57
58 ;;; Code:
59
60 (require 'poem)
61 (require 'pces)
62 (require 'mime)
63 (require 'static)
64
65 ;;;_* USER CUSTOMIZATION VARIABLES:
66 (defgroup lsdb nil
67   "The Lovely Sister Database."
68   :group 'news
69   :group 'mail)
70   
71 (defcustom lsdb-file (expand-file-name "~/.lsdb")
72   "The name of the Lovely Sister Database file."
73   :group 'lsdb
74   :type 'file)
75
76 (defcustom lsdb-file-coding-system (find-coding-system 'iso-2022-jp)
77   "Coding system for `lsdb-file'."
78   :group 'lsdb
79   :type 'symbol)
80
81 (defcustom lsdb-sender-headers
82   "From\\|Resent-From"
83   "List of headers to search for senders."
84   :group 'lsdb
85   :type 'list)
86
87 (defcustom lsdb-recipients-headers
88   "Resent-To\\|Resent-Cc\\|Reply-To\\|To\\|Cc\\|Bcc"
89   "List of headers to search for recipients."
90   :group 'lsdb
91   :type 'list)
92
93 (defcustom lsdb-interesting-header-alist
94   '(("Organization" nil organization)
95     ("\\(X-\\)?User-Agent\\|X-Mailer\\|X-Newsreader" nil user-agent)
96     ("\\(X-\\)?ML-Name" nil mailing-list)
97     ("List-Id" "\\(.*\\)[ \t]+<[^>]+>\\'" mailing-list "\\1")
98     ("X-Sequence" "\\(.*\\)[ \t]+[0-9]+\\'" mailing-list "\\1")
99     ("Delivered-To" "mailing list[ \t]+\\([^@]+\\)@.*" mailing-list "\\1")
100     ("\\(X-URL\\|X-URI\\)" nil www)
101     ("X-Attribution\\|X-cite-me" nil attribution)
102     ("X-Face" nil x-face))
103   "Alist of headers we are interested in.
104 The format of elements of this list should be
105      (FIELD-NAME REGEXP ENTRY STRING)
106 where the last three elements are optional."
107   :group 'lsdb
108   :type 'list)
109
110 (defcustom lsdb-entry-type-alist
111   '((net 5 ?,)
112     (creation-date 2 ?. t)
113     (last-modified 3 ?. t)
114     (mailing-list 4 ?,)
115     (attribution 4 ?.)
116     (organization 4)
117     (www 4)
118     (aka 4 ?,)
119     (score -1)
120     (x-face -1))
121   "Alist of entry types for presentation.
122 The format of elements of this list should be
123      (ENTRY SCORE [CLASS READ-ONLY])
124 where the last two elements are optional.
125 Possible values for CLASS are `?.' and '?,'.  If CLASS is `?.', the
126 entry takes a unique value which is overridden by newly assigned one
127 by `lsdb-mode-edit-entry' or such a command.  If CLASS is `?,', the
128 entry can have multiple values separated by commas.
129 If the fourth element READ-ONLY is non-nil, it is assumed that the
130 entry cannot be modified."
131   :group 'lsdb
132   :type 'list)
133
134 (defcustom lsdb-decode-field-body-function #'lsdb-decode-field-body
135   "Field body decoder."
136   :group 'lsdb
137   :type 'function)
138
139 (defcustom lsdb-canonicalize-full-name-function
140   #'lsdb-canonicalize-spaces-and-dots
141   "Way to canonicalize full name."
142   :group 'lsdb
143   :type 'function)
144
145 (defcustom lsdb-lookup-full-name-functions
146   '(lsdb-lookup-full-name-from-address-cache)
147   "List of functions to pick up the existing full-name of the sender.
148 The sender is passed to each function as the argument."
149   :group 'lsdb
150   :type 'hook)
151
152 (defcustom lsdb-update-record-functions
153   '(lsdb-update-address-cache)
154   "List of functions called after a record is updated.
155 The updated record is passed to each function as the argument."
156   :group 'lsdb
157   :type 'hook)
158
159 (defcustom lsdb-secondary-hash-tables
160   '(lsdb-address-cache)
161   "List of the hash tables for reverse lookup"
162   :group 'lsdb
163   :type 'list)
164
165 (defcustom lsdb-window-max-height 7
166   "Maximum number of lines used to display LSDB record."
167   :group 'lsdb
168   :type 'integer)
169
170 (defcustom lsdb-x-face-command-alist
171   '((pbm "{ echo '/* Width=48, Height=48 */'; uncompface; } | icontopbm | pnmscale 0.5")
172     (xpm "{ echo '/* Width=48, Height=48 */'; uncompface; } | icontopbm | pnmscale 0.5 | ppmtoxpm"))
173   "An alist from an image type to a command to be executed to display an X-Face header.
174 The command will be executed in a sub-shell asynchronously.
175 The compressed face will be piped to this command."
176   :group 'lsdb
177   :type 'list)
178
179 (defcustom lsdb-insert-x-face-function
180   (if (static-if (featurep 'xemacs)
181           (featurep 'xpm)
182         (and (>= emacs-major-version 21)
183              (fboundp 'image-type-available-p)
184              (or (image-type-available-p 'pbm)
185                  (image-type-available-p 'xpm))))
186       #'lsdb-insert-x-face-asynchronously)
187   "Function to display X-Face."
188   :group 'lsdb
189   :type 'function)
190
191 (defcustom lsdb-print-record-hook '(lsdb-expose-x-face)
192   "A hook called after a record is displayed."
193   :group 'lsdb
194   :type 'hook)
195
196 (defcustom lsdb-display-records-sort-predicate nil
197   "A predicate to sort records."
198   :group 'lsdb
199   :type 'function)
200
201 (defcustom lsdb-pop-up-windows t
202   "Non-nil means LSDB should make new windows to display records."
203   :group 'lsdb
204   :type 'boolean)
205
206 (defgroup lsdb-edit-form nil
207   "A mode for editing forms."
208   :group 'lsdb)
209
210 (defcustom lsdb-edit-form-mode-hook nil
211   "Hook run in `lsdb-edit-form-mode' buffers."
212   :group 'lsdb-edit-form
213   :type 'hook)
214
215 (defcustom lsdb-shell-file-name "/bin/sh"
216   "File name to load inferior shells from.
217 Bourne shell or its equivalent \(not tcsh) is needed for \"2>\"."
218   :group 'lsdb
219   :type 'string)
220
221 (defcustom lsdb-shell-command-switch "-c"
222   "Switch used to have the shell execute its command line argument."
223   :group 'lsdb
224   :type 'string)
225
226 ;;;_. Faces
227 (defface lsdb-header-face
228   '((t (:underline t)))
229   "Face for the file header line in `lsdb-mode'."
230   :group 'lsdb)
231 (defvar lsdb-header-face 'lsdb-header-face)
232
233 (defface lsdb-field-name-face
234   '((((class color) (background dark))
235      (:foreground "PaleTurquoise" :bold t))
236     (t (:bold t)))
237   "Face for the message header line in `lsdb-mode'."
238   :group 'lsdb)
239 (defvar lsdb-field-name-face 'lsdb-field-name-face)
240
241 (defface lsdb-field-body-face
242   '((((class color) (background dark))
243      (:foreground "turquoise" :italic t))
244     (t (:italic t)))
245   "Face for the message header line in `lsdb-mode'."
246   :group 'lsdb)
247 (defvar lsdb-field-body-face 'lsdb-field-body-face)
248
249 (defconst lsdb-font-lock-keywords
250   '(("^\\sw[^\r\n]*"
251      (0 lsdb-header-face))
252     ("^\t\t.*$"
253      (0 lsdb-field-body-face))
254     ("^\t\\([^\t:]+:\\)[ \t]*\\(.*\\)$"
255      (1 lsdb-field-name-face)
256      (2 lsdb-field-body-face))))
257
258 (put 'lsdb-mode 'font-lock-defaults '(lsdb-font-lock-keywords t))
259
260 ;;;_* CODE - no user customizations below
261 ;;;_. Internal Variables
262 (defvar lsdb-hash-table nil
263   "Internal hash table to hold LSDB records.")
264
265 (defvar lsdb-address-cache nil
266   "The reverse lookup table for `lsdb-hash-table'.
267 It represents address to full-name mapping.")
268
269 (defvar lsdb-buffer-name "*LSDB*"
270   "Buffer name to display LSDB record.")
271
272 (defvar lsdb-hash-tables-are-dirty nil
273   "Flag to indicate whether the internal hash tables need to be saved.")
274
275 (defvar lsdb-known-entry-names
276   (make-vector 29 0)
277   "An obarray used to complete an entry name.")
278
279 (defvar lsdb-temp-buffer-show-function
280   #'lsdb-temp-buffer-show-function
281   "Non-nil means call as function to display a help buffer.
282 The function is called with one argument, the buffer to be displayed.
283 Overrides `temp-buffer-show-function'.")
284
285 ;;;_. Hash Table Emulation
286 (if (and (fboundp 'make-hash-table)
287          (subrp (symbol-function 'make-hash-table)))
288     (progn
289       (defalias 'lsdb-puthash 'puthash)
290       (defalias 'lsdb-gethash 'gethash)
291       (defalias 'lsdb-remhash 'remhash)
292       (defalias 'lsdb-maphash 'maphash)
293       (defalias 'lsdb-hash-table-size 'hash-table-size)
294       (defalias 'lsdb-hash-table-count 'hash-table-count)
295       (defalias 'lsdb-make-hash-table 'make-hash-table))
296   (defun lsdb-puthash (key value hash-table)
297     "Hash KEY to VALUE in HASH-TABLE."
298     ;; Obarray is regarded as an open hash table, as a matter of
299     ;; fact, rehashing doesn't make sense.
300     (let (new-obarray)
301       (when (> (car hash-table)
302                (* (length (nth 1 hash-table)) 0.7))
303         (setq new-obarray (make-vector (* (length (nth 1 hash-table)) 2) 0))
304         (mapatoms
305          (lambda (symbol)
306            (set (intern (symbol-name symbol) new-obarray)
307                 (symbol-value symbol)))
308          (nth 1 hash-table))
309         (setcdr hash-table (list new-obarray)))
310       (set (intern key (nth 1 hash-table)) value)
311       (setcar hash-table (1+ (car hash-table)))))
312   (defun lsdb-gethash (key hash-table &optional default)
313     "Find hash value for KEY in HASH-TABLE.
314 If there is no corresponding value, return DEFAULT (which defaults to nil)."
315     (let ((symbol (intern-soft key (nth 1 hash-table))))
316       (if symbol
317           (symbol-value symbol)
318         default)))
319   (defun lsdb-remhash (key hash-table)
320     "Remove the entry for KEY from HASH-TABLE.
321 Do nothing if there is no entry for KEY in HASH-TABLE."
322     (unintern key (nth 1 hash-table))
323     (setcar hash-table (1- (car hash-table))))
324   (defun lsdb-maphash (function hash-table)
325     "Map FUNCTION over entries in HASH-TABLE, calling it with two args,
326 each key and value in HASH-TABLE.
327
328 FUNCTION may not modify HASH-TABLE, with the one exception that FUNCTION
329 may remhash or puthash the entry currently being processed by FUNCTION."
330     (mapatoms
331      (lambda (symbol)
332        (funcall function (symbol-name symbol) (symbol-value symbol)))
333      (nth 1 hash-table)))
334   (defun lsdb-hash-table-size (hash-table)
335     "Return the size of HASH-TABLE.
336 This is the current number of slots in HASH-TABLE, whether occupied or not."
337     (length (nth 1 hash-table)))
338   (defalias 'lsdb-hash-table-count 'car)
339   (defun lsdb-make-hash-table (&rest args)
340     "Return a new empty hash table object."
341     (list 0 (make-vector (or (plist-get args :size) 29) 0))))
342
343 ;;;_. Hash Table Reader/Writer
344 (defconst lsdb-secondary-hash-table-start-format
345   ";;; %S\n")
346
347 (defsubst lsdb-secondary-hash-table-start (hash-table)
348   (format lsdb-secondary-hash-table-start-format hash-table))
349
350 (eval-and-compile
351   (condition-case nil
352       (progn
353         ;; In XEmacs, hash tables can also be created by the lisp reader
354         ;; using structure syntax.
355         (read-from-string "#s(hash-table)")
356         (defalias 'lsdb-read 'read))
357     (invalid-read-syntax
358      (defun lsdb-read (&optional marker)
359        "Read one Lisp expression as text from MARKER, return as Lisp object."
360        (save-excursion
361          (goto-char marker)
362          (if (looking-at "^#s(")
363              (with-temp-buffer
364                (buffer-disable-undo)
365                (insert-buffer-substring (marker-buffer marker) marker)
366                (goto-char (point-min))
367                (delete-char 2)
368                (let ((object (read (current-buffer)))
369                      hash-table data)
370                  (if (eq 'hash-table (car object))
371                      (progn
372                        (setq hash-table
373                              (lsdb-make-hash-table
374                               :size (plist-get (cdr object) 'size)
375                               :test 'equal)
376                              data (plist-get (cdr object) 'data))
377                        (while data
378                          (lsdb-puthash (pop data) (pop data) hash-table))
379                        hash-table)
380                    object)))))))))
381
382 (defun lsdb-load-hash-tables ()
383   "Read the contents of `lsdb-file' into the internal hash tables."
384   (let ((buffer (find-file-noselect lsdb-file))
385         tables)
386     (unwind-protect
387         (save-excursion
388           (set-buffer buffer)
389           (goto-char (point-min))
390           (re-search-forward "^#s(")
391           (goto-char (match-beginning 0))
392           (setq lsdb-hash-table (lsdb-read (point-marker)))
393           ;; Load the secondary hash tables following.
394           (setq tables lsdb-secondary-hash-tables)
395           (while tables
396             (if (re-search-forward
397                  (concat "^" (lsdb-secondary-hash-table-start
398                               (car tables)))
399                  nil t)
400                 (set (car tables) (lsdb-read (point-marker))))
401             (setq tables (cdr tables))))
402       (kill-buffer buffer))))
403
404 (defun lsdb-insert-hash-table (hash-table)
405   (insert "#s(hash-table size "
406           ;; Reduce the actual size of the close hash table, because
407           ;; XEmacs doesn't have a distinction between index-size and
408           ;; hash-table-size.
409           (number-to-string (lsdb-hash-table-count hash-table))
410           " test equal data (")
411   (lsdb-maphash
412    (lambda (key value)
413      (insert (prin1-to-string key) " " (prin1-to-string value) " "))
414    hash-table)
415   (insert "))"))
416
417 (defun lsdb-save-hash-tables ()
418   "Write the records within the internal hash tables into `lsdb-file'."
419   (let ((coding-system-for-write lsdb-file-coding-system)
420         tables)
421     (with-temp-file lsdb-file
422       (if (and (or (featurep 'mule)
423                    (featurep 'file-coding))
424                lsdb-file-coding-system)
425           (let ((coding-system-name
426                  (if (symbolp lsdb-file-coding-system)
427                      (symbol-name lsdb-file-coding-system)
428                    ;; XEmacs
429                    (static-if (featurep 'xemacs)
430                        (symbol-name (coding-system-name
431                                      lsdb-file-coding-system))))))
432             (if coding-system-name
433                 (insert ";;; -*- coding: " coding-system-name " -*-\n"))))
434       (lsdb-insert-hash-table lsdb-hash-table)
435       ;; Save the secondary hash tables following.
436       (setq tables lsdb-secondary-hash-tables)
437       (while tables
438         (insert "\n" (lsdb-secondary-hash-table-start
439                       (car tables)))
440         (lsdb-insert-hash-table (symbol-value (car tables)))
441         (setq tables (cdr tables))))))
442
443 ;;;_. Mail Header Extraction
444 (defun lsdb-fetch-field-bodies (regexp)
445   (save-excursion
446     (goto-char (point-min))
447     (let ((case-fold-search t)
448           field-bodies)
449       (while (re-search-forward (concat "^\\(" regexp "\\):[ \t]*")
450                                 nil t)
451         (push (funcall lsdb-decode-field-body-function
452                              (buffer-substring (point) (std11-field-end))
453                              (match-string 1))
454                     field-bodies))
455       (nreverse field-bodies))))
456
457 (defun lsdb-canonicalize-spaces-and-dots (string)
458   (while (string-match "  +\\|[\f\t\n\r\v]+\\|\\." string)
459     (setq string (replace-match " " nil t string)))
460   string)
461
462 (defun lsdb-extract-address-components (string)
463   (let ((components (std11-extract-address-components string)))
464     (if (and (nth 1 components)
465              ;; When parsing a group address,
466              ;; std11-extract-address-components is likely to return
467              ;; the ("GROUP" "") form.
468              (not (equal (nth 1 components) "")))
469         (if (car components)
470             (list (funcall lsdb-canonicalize-full-name-function
471                            (car components))
472                   (nth 1 components))
473           (list (nth 1 components) (nth 1 components))))))
474
475 ;; stolen (and renamed) from nnheader.el
476 (defun lsdb-decode-field-body (field-body field-name
477                                           &optional mode max-column)
478   (let ((multibyte enable-multibyte-characters))
479     (unwind-protect
480         (progn
481           (set-buffer-multibyte t)
482           (mime-decode-field-body field-body
483                                   (if (stringp field-name)
484                                       (intern (capitalize field-name))
485                                     field-name)
486                                   mode max-column))
487       (set-buffer-multibyte multibyte))))
488
489 ;;;_. Record Management
490 (defun lsdb-rebuild-secondary-hash-tables (&optional force)
491   (let ((tables lsdb-secondary-hash-tables))
492     (while tables
493       (when (or force (not (symbol-value (car tables))))
494         (set (car tables) (lsdb-make-hash-table :test 'equal))
495         (lsdb-maphash
496          (lambda (key value)
497            (run-hook-with-args
498             'lsdb-update-record-functions
499             (cons key value)))
500          lsdb-hash-table)
501         (setq lsdb-hash-tables-are-dirty t))
502       (setq tables (cdr tables)))))
503
504 (defun lsdb-maybe-load-hash-tables ()
505   (unless lsdb-hash-table
506     (if (file-exists-p lsdb-file)
507         (lsdb-load-hash-tables)
508       (setq lsdb-hash-table (lsdb-make-hash-table :test 'equal)))
509     (lsdb-rebuild-secondary-hash-tables)))
510
511 ;;;_ : Fallback Lookup Functions
512 ;;;_  , #1 Address Cache
513 (defun lsdb-lookup-full-name-from-address-cache (sender)
514   (lsdb-gethash (nth 1 sender) lsdb-address-cache))
515
516 (defun lsdb-update-address-cache (record)
517   (let ((net (cdr (assq 'net record))))
518     (while net
519       (lsdb-puthash (pop net) (car record) lsdb-address-cache))))
520
521 ;;;_  , #2 Iterate on the All Records (very slow)
522 (defun lsdb-lookup-full-name-by-fuzzy-matching (sender)
523   (let ((names
524          (if (string-match
525               "\\`\\(.+\\)[ \t]+\\(/[ \t]+\\|(\\([^)]+\\))\\)"
526               (car sender))
527              (if (match-beginning 3)
528                  (list (match-string 1 (car sender))
529                        (match-string 3 (car sender)))
530                (list (match-string 1 (car sender))
531                      (substring (car sender) (match-end 0))))
532            (list (car sender))))
533         (case-fold-search t))
534     (catch 'found
535       (lsdb-maphash
536        (lambda (key value)
537          (while names
538            (if (or (string-match
539                     (concat "\\<" (regexp-quote (car names)) "\\>")
540                     key)
541                    (string-match
542                     (concat
543                      "\\<"
544                      (regexp-quote
545                       (mapconcat #'identity
546                                  (nreverse (split-string (car names)))
547                                  " "))
548                      "\\>")
549                     key)
550                    ;; Don't assume that we are using address cache.
551                    (member (nth 1 sender) (cdr (assq 'net value))))
552                (throw 'found key))
553            (setq names (cdr names))))
554        lsdb-hash-table))))
555
556 ;;;_ : Update Records
557 (defun lsdb-update-record (sender &optional interesting)
558   (let ((old (lsdb-gethash (car sender) lsdb-hash-table))
559         (new (cons (cons 'net (list (nth 1 sender)))
560                    interesting))
561         merged
562         record
563         full-name)
564     ;; Look for the existing record from the reverse hash table.
565     ;; If it is found, regsiter the current full-name as AKA.
566     (unless old
567       (setq full-name
568             (run-hook-with-args-until-success
569              'lsdb-lookup-full-name-functions
570              sender))
571       (when full-name
572         (setq old (lsdb-gethash full-name lsdb-hash-table)
573               new (cons (list 'aka (car sender)) new))
574         (setcar sender full-name)))
575     (unless old
576       (setq new (cons (cons 'creation-date (format-time-string "%Y-%m-%d"))
577                       new)))
578     (setq merged (lsdb-merge-record-entries old new)
579           record (cons (car sender) merged))
580     (unless (equal merged old)
581       (let ((entry (assq 'last-modified (cdr record)))
582             (last-modified (format-time-string "%Y-%m-%d")))
583         (if entry
584             (setcdr entry last-modified)
585           (setcdr record (cons (cons 'last-modified last-modified)
586                                (cdr record)))))
587       (lsdb-puthash (car record) (cdr record)
588                     lsdb-hash-table)
589       (run-hook-with-args 'lsdb-update-record-functions record)
590       (setq lsdb-hash-tables-are-dirty t))
591     record))
592
593 (defun lsdb-update-records ()
594   (lsdb-maybe-load-hash-tables)
595   (let (senders recipients interesting alist records bodies entry)
596     (save-restriction
597       (std11-narrow-to-header)
598       (setq senders
599             (delq nil (mapcar #'lsdb-extract-address-components
600                               (lsdb-fetch-field-bodies
601                                lsdb-sender-headers)))
602             recipients
603             (delq nil (mapcar #'lsdb-extract-address-components
604                               (lsdb-fetch-field-bodies
605                                lsdb-recipients-headers))))
606       (setq alist lsdb-interesting-header-alist)
607       (while alist
608         (setq bodies
609               (delq nil (mapcar
610                          (lambda (field-body)
611                            (if (nth 1 (car alist))
612                                (and (string-match (nth 1 (car alist))
613                                                   field-body)
614                                     (replace-match (nth 3 (car alist))
615                                                    nil nil field-body))
616                              field-body))
617                          (lsdb-fetch-field-bodies (car (car alist))))))
618         (when bodies
619           (setq entry (or (nth 2 (car alist))
620                           'notes))
621           (push (cons entry
622                       (if (eq ?. (nth 2 (assq entry lsdb-entry-type-alist)))
623                           (car bodies)
624                         bodies))
625                 interesting))
626         (setq alist (cdr alist))))
627     (if senders
628         (setq records (list (lsdb-update-record (pop senders) interesting))))
629     (setq alist (nconc senders recipients))
630     (while alist
631       (setq records (cons (lsdb-update-record (pop alist)) records)))
632     (nreverse records)))
633
634 (defun lsdb-merge-record-entries (old new)
635   (setq old (copy-sequence old))
636   (while new
637     (let ((entry (assq (car (car new)) old))
638           list pointer)
639       (if (null entry)
640           (setq old (nconc old (list (car new))))
641         (if (listp (cdr entry))
642             (progn
643               (setq list (cdr (car new)) pointer list)
644               (while pointer
645                 (if (member (car pointer) (cdr entry))
646                     (setq list (delq (car pointer) list)))
647                 (setq pointer (cdr pointer)))
648               (setcdr entry (nconc (cdr entry) list)))
649           (setcdr entry (cdr (car new))))))
650     (setq new (cdr new)))
651   old)
652
653 ;;;_. Display Management
654 (defun lsdb-fit-window-to-buffer (&optional window)
655   (save-selected-window
656     (if window
657         (select-window window))
658     (unless (pos-visible-in-window-p (point-max))
659       (enlarge-window (- lsdb-window-max-height (window-height))))
660     (shrink-window-if-larger-than-buffer)
661     (let ((height (window-height)))
662       (if (> height lsdb-window-max-height)
663           (shrink-window (- height lsdb-window-max-height)))
664       (set-window-start window (point-min)))))
665
666 (defun lsdb-temp-buffer-show-function (buffer)
667   (when lsdb-pop-up-windows
668     (save-selected-window
669       (let ((window (or (get-buffer-window lsdb-buffer-name)
670                         (progn
671                           (select-window (get-largest-window))
672                           (split-window-vertically)))))
673         (set-window-buffer window buffer)
674         (lsdb-fit-window-to-buffer window)))))
675
676 (defun lsdb-display-record (record)
677   "Display only one RECORD, then shrink the window as possible."
678   (let ((temp-buffer-show-function lsdb-temp-buffer-show-function))
679     (lsdb-display-records (list record))))
680
681 (defun lsdb-display-records (records)
682   (with-output-to-temp-buffer lsdb-buffer-name
683     (set-buffer standard-output)
684     (setq records
685           (sort (copy-sequence records)
686                 (or lsdb-display-records-sort-predicate
687                     (lambda (record1 record2)
688                       (string-lessp (car record1) (car record2))))))
689     (while records
690       (save-restriction
691         (narrow-to-region (point) (point))
692         (lsdb-print-record (car records)))
693       (goto-char (point-max))
694       (setq records (cdr records)))
695     (lsdb-mode)))
696
697 (defsubst lsdb-entry-score (entry)
698   (or (nth 1 (assq (car entry) lsdb-entry-type-alist)) 0))
699
700 (defun lsdb-insert-entry (entry)
701   (let ((entry-name (capitalize (symbol-name (car entry)))))
702     (intern entry-name lsdb-known-entry-names)
703     (if (>= (lsdb-entry-score entry) 0)
704         (insert "\t" entry-name ": "
705                 (if (listp (cdr entry))
706                     (mapconcat
707                      #'identity (cdr entry)
708                      (if (eq ?, (nth 2 (assq (car entry)
709                                              lsdb-entry-type-alist)))
710                          ", "
711                        "\n\t\t"))
712                   (cdr entry))
713                 "\n"))))
714
715 (defun lsdb-print-record (record)
716   (insert (car record) "\n")
717   (let ((entries
718          (sort (copy-sequence (cdr record))
719                (lambda (entry1 entry2)
720                  (> (lsdb-entry-score entry1) (lsdb-entry-score entry2))))))
721     (while entries
722       (lsdb-insert-entry (car entries))
723       (setq entries (cdr entries))))
724   (add-text-properties (point-min) (point-max)
725                        (list 'lsdb-record record))
726   (run-hooks 'lsdb-print-record-hook))
727
728 ;;;_. Completion
729 (defvar lsdb-last-completion nil)
730 (defvar lsdb-last-candidates nil)
731 (defvar lsdb-last-candidates-pointer nil)
732
733 ;;;_ : Matching Highlight
734 (defvar lsdb-last-highlight-overlay nil)
735
736 (defun lsdb-complete-name-highlight (start end)
737   (make-local-hook 'pre-command-hook)
738   (add-hook 'pre-command-hook 'lsdb-complete-name-highlight-update nil t)
739   (save-excursion
740     (goto-char start)
741     (search-forward lsdb-last-completion end)
742     (setq lsdb-last-highlight-overlay
743           (make-overlay (match-beginning 0) (match-end 0)))
744     (overlay-put lsdb-last-highlight-overlay 'face
745                  (or (find-face 'isearch-secondary)
746                      (find-face 'isearch-lazy-highlight-face)
747                      'underline))))
748
749 (defun lsdb-complete-name-highlight-update ()
750   (unless (eq 'this-command 'lsdb-complete-name)
751     (if lsdb-last-highlight-overlay
752         (delete-overlay lsdb-last-highlight-overlay))
753     (remove-hook 'pre-command-hook
754                  'lsdb-complete-name-highlight-update t)))
755
756 ;;;_ : Name Completion
757 (defun lsdb-complete-name ()
758   "Complete the user full-name or net-address before point"
759   (interactive)
760   (lsdb-maybe-load-hash-tables)
761   (let* ((start
762           (save-excursion
763             (re-search-backward "\\(\\`\\|[\n:,]\\)[ \t]*")
764             (goto-char (match-end 0))
765             (point)))
766          pattern
767          (case-fold-search t)
768          (completion-ignore-case t))
769     (unless (eq last-command this-command)
770       (setq lsdb-last-candidates nil
771             lsdb-last-candidates-pointer nil
772             lsdb-last-completion (buffer-substring start (point))
773             pattern (concat "\\<" (regexp-quote lsdb-last-completion)))
774       (lsdb-maphash
775        (lambda (key value)
776          (let ((net (cdr (assq 'net value))))
777            (if (string-match pattern key)
778                (setq lsdb-last-candidates
779                      (nconc lsdb-last-candidates
780                             (mapcar (lambda (address)
781                                       (if (equal key address)
782                                           key
783                                         (concat key " <" address ">")))
784                                     net)))
785              (while net
786                (if (string-match pattern (car net))
787                    (push (car net) lsdb-last-candidates))
788                (setq net (cdr net))))))
789        lsdb-hash-table)
790       ;; Sort candidates by the position where the pattern occurred.
791       (setq lsdb-last-candidates
792             (sort lsdb-last-candidates
793                   (lambda (cand1 cand2)
794                     (< (if (string-match pattern cand1)
795                            (match-beginning 0))
796                        (if (string-match pattern cand2)
797                            (match-beginning 0)))))))
798     (unless lsdb-last-candidates-pointer
799       (setq lsdb-last-candidates-pointer lsdb-last-candidates))
800     (when lsdb-last-candidates-pointer
801       (delete-region start (point))
802       (insert (pop lsdb-last-candidates-pointer))
803       (lsdb-complete-name-highlight start (point)))))
804
805 ;;;_. Major Mode (`lsdb-mode') Implementation
806 ;;;_ : Modeline Buffer Identification
807 (defconst lsdb-pointer-xpm
808   "/* XPM */
809 static char * lsdb_pointer_xpm[] = {
810 \"14 14 5 1\",
811 \"      c None\",
812 \"+     c #FF9696\",
813 \"@     c #FF0000\",
814 \"#     c #FF7575\",
815 \"$     c #FF5959\",
816 \"              \",
817 \"  +++   @@@   \",
818 \" +++## @@@@@  \",
819 \" ++### @@@@@  \",
820 \" +#####@@@@@  \",
821 \" +###$$@@@@@  \",
822 \" +###$$@@@@@  \",
823 \"  ##$$$@@@@   \",
824 \"   #$$$@@@    \",
825 \"    $$@@@     \",
826 \"     $@@      \",
827 \"      @       \",
828 \"              \",
829 \"              \"};")
830
831 (static-if (featurep 'xemacs)
832     (progn
833       (defvar lsdb-xemacs-modeline-left-extent
834         (copy-extent modeline-buffer-id-left-extent))
835
836       (defvar lsdb-xemacs-modeline-right-extent
837         (copy-extent modeline-buffer-id-right-extent))
838
839       (defun lsdb-modeline-buffer-identification (line)
840         "Decorate 1st element of `mode-line-buffer-identification' LINE.
841 Modify whole identification by side effect."
842         (let ((id (car line)) chopped)
843           (if (and (stringp id) (string-match "^LSDB:" id))
844               (progn
845                 (setq chopped (substring id 0 (match-end 0))
846                       id (substring id (match-end 0)))
847                 (nconc
848                  (list
849                   (let ((glyph
850                          (make-glyph
851                           (nconc
852                            (if (featurep 'xpm)
853                                (list (vector 'xpm :data lsdb-pointer-xpm)))
854                            (list (vector 'string :data chopped))))))
855                     (set-glyph-face glyph 'modeline-buffer-id)
856                     (cons lsdb-xemacs-modeline-left-extent glyph))
857                   (cons lsdb-xemacs-modeline-right-extent id))
858                  (cdr line)))
859             line))))
860   (condition-case nil
861       (progn
862         (require 'image)
863         (defun lsdb-modeline-buffer-identification (line)
864           "Decorate 1st element of `mode-line-buffer-identification' LINE.
865 Modify whole identification by side effect."
866           (let ((id (copy-sequence (car line)))
867                 (image
868                  (if (image-type-available-p 'xpm)
869                      (create-image lsdb-pointer-xpm 'xpm t :ascent 'center))))
870             (when (and image
871                        (stringp id) (string-match "^LSDB:" id))
872               (add-text-properties 0 (length id)
873                                    (list 'display image
874                                          'rear-nonsticky (list 'display))
875                                    id)
876               (setcar line id))
877             line)))
878     (error
879      (defalias 'lsdb-modeline-buffer-identification 'identity))))
880
881 (defvar lsdb-mode-map
882   (let ((keymap (make-sparse-keymap)))
883     (define-key keymap "a" 'lsdb-mode-add-entry)
884     (define-key keymap "d" 'lsdb-mode-delete-entry)
885     (define-key keymap "e" 'lsdb-mode-edit-entry)
886     (define-key keymap "l" 'lsdb-mode-load)
887     (define-key keymap "s" 'lsdb-mode-save)
888     (define-key keymap "q" 'lsdb-mode-quit-window)
889     (define-key keymap "g" 'lsdb-mode-lookup)
890     (define-key keymap "p" 'lsdb-mode-previous-record)
891     (define-key keymap "n" 'lsdb-mode-next-record)
892     (define-key keymap " " 'scroll-up)
893     (define-key keymap [delete] 'scroll-down)
894     (define-key keymap "\177" 'scroll-down)
895     (define-key keymap [backspace] 'scroll-down)
896     keymap)
897   "LSDB's keymap.")
898
899 (defvar lsdb-modeline-string "")
900
901 (define-derived-mode lsdb-mode fundamental-mode "LSDB"
902   "Major mode for browsing LSDB records."
903   (setq buffer-read-only t)
904   (static-if (featurep 'xemacs)
905       ;; In XEmacs, setting `font-lock-defaults' only affects on
906       ;; `find-file-hooks'.
907       (font-lock-set-defaults)
908     (set (make-local-variable 'font-lock-defaults)
909          '(lsdb-font-lock-keywords t)))
910   (make-local-hook 'post-command-hook)
911   (add-hook 'post-command-hook 'lsdb-modeline-update nil t)
912   (make-local-variable 'lsdb-modeline-string)
913   (setq mode-line-buffer-identification
914         (lsdb-modeline-buffer-identification
915          '("LSDB: " lsdb-modeline-string)))
916   (lsdb-modeline-update)
917   (force-mode-line-update))
918
919 (defun lsdb-modeline-update ()
920   (let ((record
921          (get-text-property (if (eobp) (point-min) (point)) 'lsdb-record))
922         net)
923     (if record
924         (progn
925           (setq net (car (cdr (assq 'net (cdr record)))))
926           (if (equal net (car record))
927               (setq lsdb-modeline-string net)
928             (setq lsdb-modeline-string (concat (car record) " <" net ">"))))
929       (setq lsdb-modeline-string ""))))
930
931 (defun lsdb-narrow-to-record ()
932   "Narrow to the current record."
933   (let ((end (next-single-property-change (point) 'lsdb-record nil
934                                           (point-max))))
935     (narrow-to-region
936      (previous-single-property-change (point) 'lsdb-record nil (point-min))
937      end)
938     (goto-char (point-min))))
939
940 (defun lsdb-current-record ()
941   "Return the current record name."
942   (let ((record (get-text-property (point) 'lsdb-record)))
943     (unless record
944       (error "There is nothing to follow here"))
945     record))
946
947 (defun lsdb-current-entry ()
948   "Return the current entry name.
949 If the point is not on a entry line, it prompts to select a entry in
950 the current record."
951   (save-excursion
952     (beginning-of-line)
953     (if (looking-at "^[^\t]")
954         (let ((record (lsdb-current-record))
955               (completion-ignore-case t))
956           (completing-read
957            "Which entry to modify: "
958            (mapcar (lambda (entry)
959                      (list (capitalize (symbol-name (car entry)))))
960                    (cdr record))))
961       (end-of-line)
962       (re-search-backward "^\t\\([^\t][^:]+\\):")
963       (match-string 1))))
964
965 (defun lsdb-mode-add-entry (entry-name)
966   "Add an entry on the current line."
967   (interactive
968    (let ((completion-ignore-case t))
969      (list (completing-read "Entry name: " lsdb-known-entry-names))))
970   (beginning-of-line)
971   (unless (symbolp entry-name)
972     (setq entry-name (intern (downcase entry-name))))
973   (when (assq entry-name (cdr (lsdb-current-record)))
974     (error "The entry already exists"))
975   (let ((marker (point-marker)))
976     (lsdb-edit-form
977      nil "Editing the entry."
978      `(lambda (form)
979         (when form
980           (save-excursion
981             (set-buffer lsdb-buffer-name)
982             (goto-char ,marker)
983             (let ((record (lsdb-current-record))
984                   (inhibit-read-only t)
985                   buffer-read-only)
986               (setcdr record (cons (cons ',entry-name form) (cdr record)))
987               (lsdb-puthash (car record) (cdr record)
988                             lsdb-hash-table)
989               (run-hook-with-args 'lsdb-update-record-functions record)
990               (setq lsdb-hash-tables-are-dirty t)
991               (beginning-of-line 2)
992               (add-text-properties
993                (point)
994                (progn
995                  (lsdb-insert-entry (cons ',entry-name form))
996                  (point))
997                (list 'lsdb-record record)))))))))
998
999 (defun lsdb-mode-delete-entry (&optional entry-name dont-update)
1000   "Delete the entry on the current line."
1001   (interactive)
1002   (let ((record (lsdb-current-record))
1003         entry)
1004     (or entry-name
1005         (setq entry-name (lsdb-current-entry)))
1006     (setq entry (assq (intern (downcase entry-name)) (cdr record)))
1007     (when (and entry
1008                (not dont-update))
1009       (setcdr record (delq entry (cdr record)))
1010       (lsdb-puthash (car record) (cdr record)
1011                     lsdb-hash-table)
1012       (run-hook-with-args 'lsdb-update-record-functions record)
1013       (setq lsdb-hash-tables-are-dirty t))
1014     (save-restriction
1015       (lsdb-narrow-to-record)
1016       (let ((case-fold-search t)
1017             (inhibit-read-only t)
1018             buffer-read-only)
1019         (goto-char (point-min))
1020         (if (re-search-forward
1021              (concat "^\t" (or entry-name
1022                                (lsdb-current-entry))
1023                      ":")
1024              nil t)
1025             (delete-region (match-beginning 0)
1026                            (if (re-search-forward
1027                                 "^\t[^\t][^:]+:" nil t)
1028                                (match-beginning 0)
1029                              (point-max))))))))
1030
1031 (defun lsdb-mode-edit-entry ()
1032   "Edit the entry on the current line."
1033   (interactive)
1034   (let* ((record (lsdb-current-record))
1035          (entry-name (intern (downcase (lsdb-current-entry))))
1036          (entry (assq entry-name (cdr record)))
1037          (marker (point-marker)))
1038     (lsdb-edit-form
1039      (cdr entry) "Editing the entry."
1040      `(lambda (form)
1041         (unless (equal form ',(cdr entry))
1042           (save-excursion
1043             (set-buffer lsdb-buffer-name)
1044             (goto-char ,marker)
1045             (let* ((record (lsdb-current-record))
1046                    (entry (assq ',entry-name (cdr record)))
1047                    (inhibit-read-only t)
1048                    buffer-read-only)
1049               (setcdr entry form)
1050               (run-hook-with-args 'lsdb-update-record-functions record)
1051               (setq lsdb-hash-tables-are-dirty t)
1052               (lsdb-mode-delete-entry (symbol-name ',entry-name) t)
1053               (beginning-of-line)
1054               (add-text-properties
1055                (point)
1056                (progn
1057                  (lsdb-insert-entry (cons ',entry-name form))
1058                  (point))
1059                (list 'lsdb-record record)))))))))
1060
1061 (defun lsdb-mode-save (&optional dont-ask)
1062   "Save LSDB hash table into `lsdb-file'."
1063   (interactive)
1064   (if (not lsdb-hash-tables-are-dirty)
1065       (message "(No changes need to be saved)")
1066     (when (or (interactive-p)
1067               dont-ask
1068               (y-or-n-p "Save the LSDB now?"))
1069       (lsdb-save-hash-tables)
1070       (setq lsdb-hash-tables-are-dirty nil)
1071       (message "The LSDB was saved successfully."))))
1072
1073 (defun lsdb-mode-load ()
1074   "Load LSDB hash table from `lsdb-file'."
1075   (interactive)
1076   (let (lsdb-secondary-hash-tables)
1077     (lsdb-load-hash-tables))
1078   (message "Rebuilding secondary hash tables...")
1079   (lsdb-rebuild-secondary-hash-tables t)
1080   (message "Rebuilding secondary hash tables...done"))
1081
1082 (defun lsdb-mode-quit-window (&optional kill window)
1083   "Quit the current buffer.
1084 It partially emulates the GNU Emacs' of `quit-window'."
1085   (interactive "P")
1086   (unless window
1087     (setq window (selected-window)))
1088   (let ((buffer (window-buffer window)))
1089     (unless (save-selected-window
1090               (select-window window)
1091               (one-window-p))
1092       (delete-window window))
1093     (if kill
1094         (kill-buffer buffer)
1095       (bury-buffer buffer))))
1096
1097 (defun lsdb-hide-buffer ()
1098   "Hide the LSDB window."
1099   (let ((window (get-buffer-window lsdb-buffer-name)))
1100     (if window
1101         (lsdb-mode-quit-window nil window))))
1102
1103 (defun lsdb-show-buffer ()
1104   "Show the LSDB window."
1105   (if (get-buffer lsdb-buffer-name)
1106       (if lsdb-temp-buffer-show-function
1107           (let ((lsdb-pop-up-windows t))
1108             (funcall lsdb-temp-buffer-show-function lsdb-buffer-name))
1109         (pop-to-buffer lsdb-buffer-name))))
1110
1111 (defun lsdb-toggle-buffer (&optional arg)
1112   "Toggle hiding of the LSDB window.
1113 If given a negative prefix, always show; if given a positive prefix,
1114 always hide."
1115   (interactive
1116    (list (if current-prefix-arg
1117              (prefix-numeric-value current-prefix-arg)
1118            0)))
1119   (unless arg                           ;called noninteractively?
1120     (setq arg 0))
1121   (cond
1122    ((or (< arg 0)
1123         (and (zerop arg)
1124              (not (get-buffer-window lsdb-buffer-name))))
1125     (lsdb-show-buffer))
1126    ((or (> arg 0)
1127         (and (zerop arg)
1128              (get-buffer-window lsdb-buffer-name)))
1129     (lsdb-hide-buffer))))
1130
1131 (defun lsdb-lookup-records (regexp &optional entry-name)
1132   "Return the all records in the LSDB matching the REGEXP.
1133 If the optional 2nd argument ENTRY-NAME is given, matching only
1134 performed against the entry field."
1135   (let (records)
1136     (lsdb-maphash
1137      (if entry-name
1138          (progn
1139            (unless (symbolp entry-name)
1140              (setq entry-name (intern (downcase entry-name))))
1141            (lambda (key value)
1142              (let ((entry (cdr (assq entry-name value)))
1143                    found)
1144                (unless (listp entry)
1145                  (setq entry (list entry)))
1146                (while (and (not found) entry)
1147                  (if (string-match regexp (pop entry))
1148                      (setq found t)))
1149                (if found
1150                    (push (cons key value) records)))))
1151        (lambda (key value)
1152          (if (string-match regexp key)
1153              (push (cons key value) records))))
1154      lsdb-hash-table)
1155     records))
1156
1157 (defvar lsdb-mode-lookup-history nil)
1158
1159 (defun lsdb-mode-lookup (regexp &optional entry-name)
1160   "Display the all records in the LSDB matching the REGEXP.
1161 If the optional 2nd argument ENTRY-NAME is given, matching only
1162 performed against the entry field."
1163   (interactive
1164    (let* ((completion-ignore-case t)
1165           (entry-name
1166            (if current-prefix-arg
1167                (completing-read "Entry name: "
1168                                 lsdb-known-entry-names))))
1169      (list
1170       (read-from-minibuffer
1171        (if entry-name
1172            (format "Search records `%s' regexp: " entry-name)
1173          "Search records regexp: ")
1174        nil nil nil 'lsdb-mode-lookup-history)
1175       entry-name)))
1176   (lsdb-maybe-load-hash-tables)
1177   (let ((records (lsdb-lookup-records regexp entry-name)))
1178     (if records
1179         (lsdb-display-records records))))
1180
1181 ;;;###autoload
1182 (defalias 'lsdb 'lsdb-mode-lookup)
1183
1184 (defun lsdb-mode-next-record (&optional arg)
1185   "Go to the next record."
1186   (interactive "p")
1187   (unless arg                           ;called noninteractively?
1188     (setq arg 1))
1189   (if (< arg 0)
1190       (lsdb-mode-previous-record (- arg))
1191     (while (> arg 0)
1192       (goto-char (next-single-property-change
1193                   (point) 'lsdb-record nil (point-max)))
1194       (setq arg (1- arg)))))
1195
1196 (defun lsdb-mode-previous-record (&optional arg)
1197   "Go to the previous record."
1198   (interactive "p")
1199   (unless arg                           ;called noninteractively?
1200     (setq arg 1))
1201   (if (< arg 0)
1202       (lsdb-mode-next-record (- arg))
1203     (while (> arg 0)
1204       (goto-char (previous-single-property-change
1205                   (point) 'lsdb-record nil (point-min)))
1206       (setq arg (1- arg)))))
1207
1208 ;;;_ : Edit Forms -- stolen (and renamed) from gnus-eform.el
1209 (defvar lsdb-edit-form-buffer "*LSDB edit form*")
1210 (defvar lsdb-edit-form-done-function nil)
1211 (defvar lsdb-previous-window-configuration nil)
1212
1213 (defvar lsdb-edit-form-mode-map
1214   (let ((keymap (make-sparse-keymap)))
1215     (set-keymap-parent keymap emacs-lisp-mode-map)
1216     (define-key keymap "\C-c\C-c" 'lsdb-edit-form-done)
1217     (define-key keymap "\C-c\C-k" 'lsdb-edit-form-exit)
1218     keymap)
1219   "Edit form's keymap.")
1220
1221 (defun lsdb-edit-form-mode ()
1222   "Major mode for editing forms.
1223 It is a slightly enhanced emacs-lisp-mode.
1224
1225 \\{lsdb-edit-form-mode-map}"
1226   (interactive)
1227   (kill-all-local-variables)
1228   (setq major-mode 'lsdb-edit-form-mode
1229         mode-name "LSDB Edit Form")
1230   (use-local-map lsdb-edit-form-mode-map)
1231   (make-local-variable 'lsdb-edit-form-done-function)
1232   (make-local-variable 'lsdb-previous-window-configuration)
1233   (run-hooks 'lsdb-edit-form-mode-hook))
1234
1235 (defun lsdb-edit-form (form documentation exit-func)
1236   "Edit FORM in a new buffer.
1237 Call EXIT-FUNC on exit.  Display DOCUMENTATION in the beginning
1238 of the buffer."
1239   (let ((window-configuration
1240          (current-window-configuration)))
1241     (switch-to-buffer (get-buffer-create lsdb-edit-form-buffer))
1242     (lsdb-edit-form-mode)
1243     (setq lsdb-previous-window-configuration window-configuration
1244           lsdb-edit-form-done-function exit-func)
1245     (erase-buffer)
1246     (insert documentation)
1247     (unless (bolp)
1248       (insert "\n"))
1249     (goto-char (point-min))
1250     (while (not (eobp))
1251       (insert ";;; ")
1252       (forward-line 1))
1253     (insert ";; Type `C-c C-c' after you've finished editing.\n")
1254     (insert "\n")
1255     (let ((p (point)))
1256       (pp form (current-buffer))
1257       (insert "\n")
1258       (goto-char p))))
1259
1260 (defun lsdb-edit-form-done ()
1261   "Update changes and kill the current buffer."
1262   (interactive)
1263   (goto-char (point-min))
1264   (let ((form (condition-case nil
1265                   (read (current-buffer))
1266                 (end-of-file nil)))
1267         (func lsdb-edit-form-done-function))
1268     (lsdb-edit-form-exit)
1269     (funcall func form)))
1270
1271 (defun lsdb-edit-form-exit ()
1272   "Kill the current buffer."
1273   (interactive)
1274   (let ((window-configuration lsdb-previous-window-configuration))
1275     (kill-buffer (current-buffer))
1276     (set-window-configuration window-configuration)))
1277
1278 ;;;_. Interface to Semi-gnus
1279 ;;;###autoload
1280 (defun lsdb-gnus-insinuate ()
1281   "Call this function to hook LSDB into Semi-gnus."
1282   (add-hook 'gnus-article-prepare-hook 'lsdb-gnus-update-record)
1283   (add-hook 'gnus-save-newsrc-hook 'lsdb-mode-save))
1284
1285 (defvar gnus-current-headers)
1286 (defun lsdb-gnus-update-record ()
1287   (let ((entity gnus-current-headers)
1288         records)
1289     (with-temp-buffer
1290       (set-buffer-multibyte nil)
1291       (buffer-disable-undo)
1292       (mime-insert-entity entity)
1293       (setq records (lsdb-update-records))
1294       (when records
1295         (lsdb-display-record (car records))))))
1296
1297 ;;;_. Interface to Wanderlust
1298 ;;;###autoload
1299 (defun lsdb-wl-insinuate ()
1300   "Call this function to hook LSDB into Wanderlust."
1301   (add-hook 'wl-message-redisplay-hook 'lsdb-wl-update-record)
1302   (add-hook 'wl-summary-exit-hook 'lsdb-hide-buffer)
1303   (add-hook 'wl-summary-toggle-disp-off-hook 'lsdb-hide-buffer)
1304   (add-hook 'wl-summary-toggle-disp-folder-on-hook 'lsdb-hide-buffer)
1305   (add-hook 'wl-summary-toggle-disp-folder-off-hook 'lsdb-hide-buffer)
1306   (add-hook 'wl-summary-toggle-disp-folder-message-resumed-hook
1307             'lsdb-wl-show-buffer)
1308   (add-hook 'wl-exit-hook 'lsdb-mode-save)
1309   (add-hook 'wl-save-hook 'lsdb-mode-save))
1310
1311 (eval-when-compile
1312   (autoload 'wl-message-get-original-buffer "wl-message"))
1313 (defun lsdb-wl-update-record ()
1314   (save-excursion
1315     (set-buffer (wl-message-get-original-buffer))
1316     (let ((records (lsdb-update-records)))
1317       (when records
1318         (let ((lsdb-temp-buffer-show-function
1319                #'lsdb-wl-temp-buffer-show-function))
1320           (lsdb-display-record (car records)))))))
1321
1322 (defun lsdb-wl-toggle-buffer (&optional arg)
1323   "Toggle hiding of the LSDB window for Wanderlust.
1324 If given a negative prefix, always show; if given a positive prefix,
1325 always hide."
1326   (interactive
1327    (list (if current-prefix-arg
1328              (prefix-numeric-value current-prefix-arg)
1329            0)))
1330   (let ((lsdb-temp-buffer-show-function
1331          #'lsdb-wl-temp-buffer-show-function))
1332     (lsdb-toggle-buffer arg)))
1333
1334 (defun lsdb-wl-show-buffer ()
1335   (when lsdb-pop-up-windows
1336     (let ((lsdb-temp-buffer-show-function
1337            #'lsdb-wl-temp-buffer-show-function))
1338       (lsdb-show-buffer))))
1339
1340 (defvar wl-current-summary-buffer)
1341 (defvar wl-message-buffer)
1342 (defun lsdb-wl-temp-buffer-show-function (buffer)
1343   (when lsdb-pop-up-windows
1344     (save-selected-window
1345       (let ((window (or (get-buffer-window lsdb-buffer-name)
1346                         (progn
1347                           (select-window 
1348                            (or (save-excursion
1349                                  (if (buffer-live-p wl-current-summary-buffer)
1350                                      (set-buffer wl-current-summary-buffer))
1351                                  (get-buffer-window wl-message-buffer))
1352                                (get-largest-window)))
1353                           (split-window-vertically)))))
1354         (set-window-buffer window buffer)
1355         (lsdb-fit-window-to-buffer window)))))
1356
1357 ;;;_. Interface to Mew written by Hideyuki SHIRAI <shirai@rdmg.mgcs.mei.co.jp>
1358 (eval-when-compile
1359   (autoload 'mew-sinfo-get-disp-msg "mew")
1360   (autoload 'mew-current-get-fld "mew")
1361   (autoload 'mew-current-get-msg "mew")
1362   (autoload 'mew-frame-id "mew")
1363   (autoload 'mew-cache-hit "mew"))
1364
1365 ;;;###autoload
1366 (defun lsdb-mew-insinuate ()
1367   "Call this function to hook LSDB into Mew."
1368   (add-hook 'mew-message-hook 'lsdb-mew-update-record)
1369   (add-hook 'mew-summary-toggle-disp-msg-hook
1370             (lambda ()
1371               (unless (mew-sinfo-get-disp-msg)
1372                 (lsdb-hide-buffer))))
1373   (add-hook 'mew-suspend-hook 'lsdb-hide-buffer)
1374   (add-hook 'mew-quit-hook 'lsdb-mode-save)
1375   (add-hook 'kill-emacs-hook 'lsdb-mode-save))
1376
1377 (defun lsdb-mew-update-record ()
1378   (let* ((fld (mew-current-get-fld (mew-frame-id)))
1379          (msg (mew-current-get-msg (mew-frame-id)))
1380          (cache (mew-cache-hit fld msg 'must-hit))
1381          records)
1382     (save-excursion
1383       (set-buffer cache)
1384       (make-local-variable 'lsdb-decode-field-body-function)
1385       (setq lsdb-decode-field-body-function
1386             (lambda (body name)
1387               (set-text-properties 0 (length body) nil body)
1388               body))
1389       (when (setq records (lsdb-update-records))
1390         (lsdb-display-record (car records))))))
1391
1392 ;;;_. Interface to MU-CITE
1393 (eval-when-compile
1394   (autoload 'mu-cite-get-value "mu-cite"))
1395
1396 (defun lsdb-mu-attribution (address)
1397   "Extract attribute information from LSDB."
1398   (let ((records
1399          (lsdb-lookup-records (concat "\\<" address "\\>") 'net)))
1400     (if records
1401         (cdr (assq 'attribution (cdr (car records)))))))
1402
1403 (defun lsdb-mu-set-attribution (attribution address)
1404   "Add attribute information to LSDB."
1405   (let ((records
1406          (lsdb-lookup-records (concat "\\<" address "\\>") 'net))
1407         entry)
1408     (when records
1409       (setq entry (assq 'attribution (cdr (car records))))
1410       (if entry
1411           (setcdr entry attribution)
1412         (setcdr (car records) (cons (cons 'attribution attribution)
1413                                     (cdr (car records))))
1414         (lsdb-puthash (car (car records)) (cdr (car records))
1415                       lsdb-hash-table)
1416         (run-hook-with-args 'lsdb-update-record-functions (car records))
1417         (setq lsdb-hash-tables-are-dirty t)))))
1418
1419 (defun lsdb-mu-get-prefix-method ()
1420   "A mu-cite method to return a prefix from LSDB or \">\".
1421 If an `attribution' value is found in LSDB, the value is returned.
1422 Otherwise \">\" is returned."
1423   (or (lsdb-mu-attribution (mu-cite-get-value 'address))
1424       ">"))
1425
1426 (defvar minibuffer-allow-text-properties)
1427
1428 (defvar lsdb-mu-history nil)
1429
1430 (defun lsdb-mu-get-prefix-register-method ()
1431   "A mu-cite method to return a prefix from LSDB or register it.
1432 If an `attribution' value is found in LSDB, the value is returned.
1433 Otherwise the function requests a prefix from a user.  The prefix will
1434 be registered to LSDB if the user wants it."
1435   (let ((address (mu-cite-get-value 'address)))
1436     (or (lsdb-mu-attribution address)
1437         (let* (minibuffer-allow-text-properties
1438                (result (read-string "Citation name? "
1439                                     (or (mu-cite-get-value 'x-attribution)
1440                                         (mu-cite-get-value 'full-name))
1441                                     'lsdb-mu-history)))
1442           (if (and (not (string-equal result ""))
1443                    (y-or-n-p (format "Register \"%s\"? " result)))
1444               (lsdb-mu-set-attribution result address))
1445           result))))
1446
1447 (defun lsdb-mu-get-prefix-register-verbose-method ()
1448   "A mu-cite method to return a prefix using LSDB.
1449
1450 In this method, a user must specify a prefix unconditionally.  If an
1451 `attribution' value is found in LSDB, the value is used as a initial
1452 value to input the prefix.  The prefix will be registered to LSDB if
1453 the user wants it."
1454   (let* ((address (mu-cite-get-value 'address))
1455          (attribution (lsdb-mu-attribution address))
1456          minibuffer-allow-text-properties
1457          (result (read-string "Citation name? "
1458                               (or attribution
1459                                   (mu-cite-get-value 'x-attribution)
1460                                   (mu-cite-get-value 'full-name))
1461                               'lsdb-mu-history)))
1462     (if (and (not (string-equal result ""))
1463              (not (string-equal result attribution))
1464              (y-or-n-p (format "Register \"%s\"? " result)))
1465         (lsdb-mu-set-attribution result address))
1466     result))
1467
1468 (defvar mu-cite-methods-alist)
1469 ;;;###autoload
1470 (defun lsdb-mu-insinuate ()
1471   (add-hook 'mu-cite-instantiation-hook
1472             (lambda ()
1473               (setq mu-cite-methods-alist
1474                     (nconc
1475                      mu-cite-methods-alist
1476                      (list
1477                       (cons 'lsdb-prefix
1478                             #'lsdb-mu-get-prefix-method)
1479                       (cons 'lsdb-prefix-register
1480                             #'lsdb-mu-get-prefix-register-method)
1481                       (cons 'lsdb-prefix-register-verbose
1482                             #'lsdb-mu-get-prefix-register-verbose-method)))))))
1483
1484 ;;;_. X-Face Rendering
1485 (defvar lsdb-x-face-cache
1486   (lsdb-make-hash-table :test 'equal))
1487
1488 (defun lsdb-x-face-available-image-type ()
1489   (static-if (featurep 'xemacs)
1490       (if (featurep 'xpm)
1491           'xpm)
1492     (and (>= emacs-major-version 21)
1493          (fboundp 'image-type-available-p)
1494          (if (image-type-available-p 'pbm)
1495              'pbm
1496            (if (image-type-available-p 'xpm)
1497                'xpm)))))
1498
1499 (defun lsdb-expose-x-face ()
1500   (let* ((record (get-text-property (point-min) 'lsdb-record))
1501          (x-face (cdr (assq 'x-face (cdr record))))
1502          (delimiter "\r "))
1503     (when (and lsdb-insert-x-face-function
1504                x-face)
1505       (goto-char (point-min))
1506       (end-of-line)
1507       (put-text-property 0 1 'invisible t delimiter) ;hide "\r"
1508       (put-text-property
1509        (point)
1510        (progn
1511          (insert delimiter)
1512          (while x-face
1513            (funcall lsdb-insert-x-face-function (pop x-face)))
1514          (point))
1515        'lsdb-record record))))
1516
1517 (defun lsdb-insert-x-face-image (data type marker)
1518   (static-if (featurep 'xemacs)
1519       (save-excursion
1520         (set-buffer (marker-buffer marker))
1521         (goto-char marker)
1522         (let* ((inhibit-read-only t)
1523                buffer-read-only
1524                (glyph (make-glyph (vector type :data data))))
1525           (set-extent-begin-glyph
1526            (make-extent (point) (point))
1527            glyph)))
1528     (save-excursion
1529       (set-buffer (marker-buffer marker))
1530       (goto-char marker)
1531       (let* ((inhibit-read-only t)
1532              buffer-read-only
1533              (image (create-image data type t :ascent 'center))
1534              (record (get-text-property (point) 'lsdb-record)))
1535         (put-text-property (point) (progn
1536                                      (insert-image image)
1537                                      (point))
1538                            'lsdb-record record)))))
1539
1540 (defun lsdb-insert-x-face-asynchronously (x-face)
1541   (let* ((type (lsdb-x-face-available-image-type))
1542          (shell-file-name lsdb-shell-file-name)
1543          (shell-command-switch lsdb-shell-command-switch)
1544          (process-connection-type nil)
1545          (cached (cdr (assq type (lsdb-gethash x-face lsdb-x-face-cache))))
1546          (marker (point-marker))
1547          process)
1548     (if cached
1549         (lsdb-insert-x-face-image cached type marker)
1550       (setq process
1551             (start-process-shell-command
1552              "lsdb-x-face-command" (generate-new-buffer " *lsdb work*")
1553              (concat "{ "
1554                      (nth 1 (assq type lsdb-x-face-command-alist))
1555                      "; } 2> /dev/null")))
1556       (process-send-string process (concat x-face "\n"))
1557       (process-send-eof process)
1558       (set-process-sentinel
1559        process
1560        `(lambda (process string)
1561           (unwind-protect
1562               (when (and (buffer-live-p (marker-buffer ,marker))
1563                          (equal string "finished\n"))
1564                 (let ((data
1565                        (with-current-buffer (process-buffer process)
1566                          (set-buffer-multibyte nil)
1567                          (buffer-string))))
1568                   (lsdb-insert-x-face-image data ',type ,marker)
1569                   (lsdb-puthash ,x-face (list (cons ',type data))
1570                                 lsdb-x-face-cache)))
1571             (kill-buffer (process-buffer process))))))))
1572
1573 (require 'product)
1574 (provide 'lsdb)
1575
1576 (product-provide 'lsdb
1577   (product-define "LSDB" nil '(0 5)))
1578
1579 ;;;_* Local emacs vars.
1580 ;;; The following `outline-layout' local variable setting:
1581 ;;;  - closes all topics from the first topic to just before the third-to-last,
1582 ;;;  - shows the children of the third to last (config vars)
1583 ;;;  - and the second to last (code section),
1584 ;;;  - and closes the last topic (this local-variables section).
1585 ;;;Local variables:
1586 ;;;outline-layout: (0 : -1 -1 0)
1587 ;;;End:
1588
1589 ;;; lsdb.el ends here