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