lsdb.el

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