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