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