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