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