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