lsdb.el

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