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