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