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