lsdb.el

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