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