lsdb.el

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