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