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