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