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