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: address 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 ;;; (autoload 'lsdb-wl-insinuate "lsdb")
  40 ;;; (add-hook 'wl-init-hook '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     ("Face" nil face)
 104     (,lsdb-sender-headers nil sender))
 105   "Alist of headers we are interested in.
 106 The format of elements of this list should be
 107      (FIELD-NAME REGEXP ENTRY STRING)
 108 where the last three elements are optional."
 109   :group 'lsdb
 110   :type 'list)
 111
 112 (defcustom lsdb-entry-type-alist
 113   '((net 5 ?,)
 114     (creation-date 2 ?. t)
 115     (last-modified 3 ?. t)
 116     (mailing-list 4 ?,)
 117     (attribution 4 ?.)
 118     (organization 4)
 119     (www 4)
 120     (aka 4 ?,)
 121     (score -1)
 122     (x-face -1)
 123     (face -1)
 124     (sender -1))
 125   "Alist of entry types for presentation.
 126 The format of elements of this list should be
 127      (ENTRY SCORE [CLASS READ-ONLY])
 128 where the last two elements are optional.
 129 Possible values for CLASS are `?.' and '?,'.  If CLASS is `?.', the
 130 entry takes a unique value which is overridden by newly assigned one
 131 by `lsdb-mode-edit-entry' or such a command.  If CLASS is `?,', the
 132 entry can have multiple values separated by commas.
 133 If the fourth element READ-ONLY is non-nil, it is assumed that the
 134 entry cannot be modified."
 135   :group 'lsdb
 136   :type 'list)
 137
 138 (defcustom lsdb-decode-field-body-function #'lsdb-decode-field-body
 139   "Field body decoder."
 140   :group 'lsdb
 141   :type 'function)
 142
 143 (defcustom lsdb-canonicalize-full-name-function
 144   #'lsdb-canonicalize-spaces-and-dots
 145   "Way to canonicalize full name."
 146   :group 'lsdb
 147   :type 'function)
 148
 149 (defcustom lsdb-lookup-full-name-functions
 150   '(lsdb-lookup-full-name-from-address-cache)
 151   "List of functions to pick up the existing full-name of the sender.
 152 The sender is passed to each function as the argument."
 153   :group 'lsdb
 154   :type 'hook)
 155
 156 (defcustom lsdb-after-update-record-functions
 157   '(lsdb-update-address-cache)
 158   "List of functions called after a record is updated.
 159 The updated record is passed to each function as the argument."
 160   :group 'lsdb
 161   :type 'hook)
 162
 163 (defcustom lsdb-after-delete-record-functions
 164   '(lsdb-delete-address-cache)
 165   "List of functions called after a record is removed.
 166 The removed record is passed to each function as the argument."
 167   :group 'lsdb
 168   :type 'hook)
 169
 170 (defcustom lsdb-secondary-hash-tables
 171   '(lsdb-address-cache)
 172   "List of the hash tables for reverse lookup"
 173   :group 'lsdb
 174   :type 'list)
 175
 176 (defcustom lsdb-window-max-height 7
 177   "Maximum number of lines used to display LSDB record."
 178   :group 'lsdb
 179   :type 'integer)
 180
 181 (defcustom lsdb-x-face-image-type nil
 182   "A image type of displayed x-face.
 183 If non-nil, supersedes the return value of `lsdb-x-face-available-image-type'."
 184   :group 'lsdb
 185   :type 'symbol)
 186
 187 (defcustom lsdb-x-face-scale-factor 0.5
 188   "A number used to scale down or scale up X-Face images."
 189   :group 'lsdb
 190   :type 'number)
 191
 192 (defcustom lsdb-x-face-command-alist
 193   '((pbm "{ echo '/* Width=48, Height=48 */'; uncompface; } | icontopbm | pnmscale " scale-factor)
 194     (xpm "{ echo '/* Width=48, Height=48 */'; uncompface; } | icontopbm | pnmscale " scale-factor " | ppmtoxpm"))
 195   "An alist from an image type to a command to be executed to display an X-Face header.
 196 The command will be executed in a sub-shell asynchronously.
 197 The compressed face will be piped to this command."
 198   :group 'lsdb
 199   :type 'list)
 200
 201 (defcustom lsdb-insert-x-face-function
 202   (if (static-if (featurep 'xemacs)
 203           (featurep 'xpm)
 204         (and (>= emacs-major-version 21)
 205              (fboundp 'image-type-available-p)
 206              (or (image-type-available-p 'pbm)
 207                  (image-type-available-p 'xpm))))
 208       #'lsdb-insert-x-face-asynchronously)
 209   "Function to display X-Face."
 210   :group 'lsdb
 211   :type 'function)
 212
 213 (defcustom lsdb-face-image-type nil
 214   "A image type of displayed face.
 215 If non-nil, supersedes the return value of `lsdb-x-face-available-image-type'."
 216   :group 'lsdb
 217   :type 'symbol)
 218
 219 (defcustom lsdb-face-scale-factor 0.5
 220   "A number used to scale down or scale up Face images."
 221   :group 'lsdb
 222   :type 'number)
 223
 224 (defcustom lsdb-face-command-alist
 225   '((png "pngtopnm | pnmscale " scale-factor " | pnmtopng")
 226     (xpm "pngtopnm | pnmscale " scale-factor " | ppmtoxpm"))
 227   "An alist from an image type to a command to be executed to display a Face header.
 228 The command will be executed in a sub-shell asynchronously.
 229 The decoded field-body (actually a PNG data) will be piped to this command."
 230   :group 'lsdb
 231   :type 'list)
 232
 233 (defcustom lsdb-insert-face-function
 234   (if (static-if (featurep 'xemacs)
 235           (or (featurep 'png)
 236               (featurep 'xpm))
 237         (and (>= emacs-major-version 21)
 238              (fboundp 'image-type-available-p)
 239              (or (image-type-available-p 'png)
 240                  (image-type-available-p 'xpm))))
 241       #'lsdb-insert-face-asynchronously)
 242   "Function to display Face."
 243   :group 'lsdb
 244   :type 'function)
 245
 246 (defcustom lsdb-print-record-hook '(lsdb-expose-x-face lsdb-expose-face)
 247   "A hook called after a record is displayed."
 248   :group 'lsdb
 249   :type 'hook)
 250
 251 (defcustom lsdb-display-records-sort-predicate nil
 252   "A predicate to sort records."
 253   :group 'lsdb
 254   :type 'function)
 255
 256 (defcustom lsdb-display-records-belong-to-user t
 257   "Non-nil means LSDB displays records belong to yourself.
 258 When this option is equal to nil and a message is sent by the user
 259 whose address is `user-mail-address', the LSDB record for the To: line
 260 will be shown instead of the one for the From: line."
 261   :group 'lsdb
 262   :type 'boolean)
 263
 264 (defcustom lsdb-pop-up-windows t
 265   "Non-nil means LSDB should make new windows to display records."
 266   :group 'lsdb
 267   :type 'boolean)
 268
 269 (defgroup lsdb-edit-form nil
 270   "A mode for editing forms."
 271   :group 'lsdb)
 272
 273 (defcustom lsdb-edit-form-mode-hook nil
 274   "Hook run in `lsdb-edit-form-mode' buffers."
 275   :group 'lsdb-edit-form
 276   :type 'hook)
 277
 278 (defcustom lsdb-shell-file-name "/bin/sh"
 279   "File name to load inferior shells from.
 280 Bourne shell or its equivalent \(not tcsh) is needed for \"2>\"."
 281   :group 'lsdb
 282   :type 'string)
 283
 284 (defcustom lsdb-shell-command-switch "-c"
 285   "Switch used to have the shell execute its command line argument."
 286   :group 'lsdb
 287   :type 'string)
 288
 289 (defcustom lsdb-verbose t
 290   "If non-nil, confirm user to submit changes to lsdb-hash-table."
 291   :type 'boolean
 292   :group 'lsdb)
 293
 294 (defcustom lsdb-strip-address nil
 295   "If non-nil, strip display-name from sender address before completion."
 296   :group 'lsdb
 297   :type 'boolean)
 298
 299 (defcustom lsdb-use-migemo nil
 300   "If non-nil, use `migemo' when complete address."
 301   :type 'boolean
 302   :group 'lsdb)
 303
 304 ;;;_. Faces
 305 (defface lsdb-header-face
 306   '((t (:underline t)))
 307   "Face for the file header line in `lsdb-mode'."
 308   :group 'lsdb)
 309 (defvar lsdb-header-face 'lsdb-header-face)
 310
 311 (defface lsdb-field-name-face
 312   '((((class color) (background dark))
 313      (:foreground "PaleTurquoise" :bold t))
 314     (t (:bold t)))
 315   "Face for the message header line in `lsdb-mode'."
 316   :group 'lsdb)
 317 (defvar lsdb-field-name-face 'lsdb-field-name-face)
 318
 319 (defface lsdb-field-body-face
 320   '((((class color) (background dark))
 321      (:foreground "turquoise" :italic t))
 322     (t (:italic t)))
 323   "Face for the message header line in `lsdb-mode'."
 324   :group 'lsdb)
 325 (defvar lsdb-field-body-face 'lsdb-field-body-face)
 326
 327 (defconst lsdb-font-lock-keywords
 328   '(("^\\sw[^\r\n]*"
 329      (0 lsdb-header-face))
 330     ("^\t\t.*$"
 331      (0 lsdb-field-body-face))
 332     ("^\t\\([^\t:]+:\\)[ \t]*\\(.*\\)$"
 333      (1 lsdb-field-name-face)
 334      (2 lsdb-field-body-face))))
 335
 336 (put 'lsdb-mode 'font-lock-defaults '(lsdb-font-lock-keywords t))
 337
 338 ;;;_* CODE - no user customizations below
 339 ;;;_. Internal Variables
 340 (defvar lsdb-hash-table nil
 341   "Internal hash table to hold LSDB records.")
 342
 343 (defvar lsdb-address-cache nil
 344   "The reverse lookup table for `lsdb-hash-table'.
 345 It represents address to full-name mapping.")
 346
 347 (defvar lsdb-buffer-name "*LSDB*"
 348   "Buffer name to display LSDB record.")
 349
 350 (defvar lsdb-hash-tables-are-dirty nil
 351   "Flag to indicate whether the internal hash tables need to be saved.")
 352
 353 (defvar lsdb-known-entry-names
 354   (make-vector 29 0)
 355   "An obarray used to complete an entry name.")
 356
 357 (defvar lsdb-temp-buffer-show-function
 358   #'lsdb-temp-buffer-show-function
 359   "Non-nil means call as function to display a help buffer.
 360 The function is called with one argument, the buffer to be displayed.
 361 Overrides `temp-buffer-show-function'.")
 362
 363 ;;;_. Utility functions
 364 (defun lsdb-substitute-variables (program variable value)
 365   (setq program (copy-sequence program))
 366   (let ((pointer program))
 367     (while pointer
 368       (setq pointer (memq variable program))
 369       (if pointer
 370           (setcar pointer value)))
 371     program))
 372
 373 ;;;_. Hash Table Emulation
 374 (if (and (fboundp 'make-hash-table)
 375          (subrp (symbol-function 'make-hash-table)))
 376     (progn
 377       (defalias 'lsdb-puthash 'puthash)
 378       (defalias 'lsdb-gethash 'gethash)
 379       (defalias 'lsdb-remhash 'remhash)
 380       (defalias 'lsdb-maphash 'maphash)
 381       (defalias 'lsdb-hash-table-size 'hash-table-size)
 382       (defalias 'lsdb-hash-table-count 'hash-table-count)
 383       (defalias 'lsdb-make-hash-table 'make-hash-table))
 384   (defun lsdb-puthash (key value hash-table)
 385     "Hash KEY to VALUE in HASH-TABLE."
 386     ;; Obarray is regarded as an open hash table, as a matter of
 387     ;; fact, rehashing doesn't make sense.
 388     (let (new-obarray)
 389       (when (> (car hash-table)
 390                (* (length (nth 1 hash-table)) 0.7))
 391         (setq new-obarray (make-vector (* (length (nth 1 hash-table)) 2) 0))
 392         (mapatoms
 393          (lambda (symbol)
 394            (set (intern (symbol-name symbol) new-obarray)
 395                 (symbol-value symbol)))
 396          (nth 1 hash-table))
 397         (setcdr hash-table (list new-obarray)))
 398       (set (intern key (nth 1 hash-table)) value)
 399       (setcar hash-table (1+ (car hash-table)))))
 400   (defun lsdb-gethash (key hash-table &optional default)
 401     "Find hash value for KEY in HASH-TABLE.
 402 If there is no corresponding value, return DEFAULT (which defaults to nil)."
 403     (let ((symbol (intern-soft key (nth 1 hash-table))))
 404       (if symbol
 405           (symbol-value symbol)
 406         default)))
 407   (defun lsdb-remhash (key hash-table)
 408     "Remove the entry for KEY from HASH-TABLE.
 409 Do nothing if there is no entry for KEY in HASH-TABLE."
 410     (unintern key (nth 1 hash-table))
 411     (setcar hash-table (1- (car hash-table))))
 412   (defun lsdb-maphash (function hash-table)
 413     "Map FUNCTION over entries in HASH-TABLE, calling it with two args,
 414 each key and value in HASH-TABLE.
 415
 416 FUNCTION may not modify HASH-TABLE, with the one exception that FUNCTION
 417 may remhash or puthash the entry currently being processed by FUNCTION."
 418     (mapatoms
 419      (lambda (symbol)
 420        (funcall function (symbol-name symbol) (symbol-value symbol)))
 421      (nth 1 hash-table)))
 422   (defun lsdb-hash-table-size (hash-table)
 423     "Return the size of HASH-TABLE.
 424 This is the current number of slots in HASH-TABLE, whether occupied or not."
 425     (length (nth 1 hash-table)))
 426   (defalias 'lsdb-hash-table-count 'car)
 427   (defun lsdb-make-hash-table (&rest args)
 428     "Return a new empty hash table object."
 429     (list 0 (make-vector (or (plist-get args :size) 29) 0))))
 430
 431 ;;;_. Hash Table Reader/Writer
 432 (defconst lsdb-secondary-hash-table-start-format
 433   ";;; %S\n")
 434
 435 (defsubst lsdb-secondary-hash-table-start (hash-table)
 436   (format lsdb-secondary-hash-table-start-format hash-table))
 437
 438 (eval-and-compile
 439   (condition-case nil
 440       (and
 441        ;; In XEmacs, hash tables can also be created by the lisp reader
 442        ;; using structure syntax.
 443        (read-from-string "#s(hash-table)")
 444        (defalias 'lsdb-read 'read))
 445     (invalid-read-syntax
 446      (defun lsdb-read (&optional marker)
 447        "Read one Lisp expression as text from MARKER, return as Lisp object."
 448        (save-excursion
 449          (goto-char marker)
 450          (if (looking-at "^#s(")
 451              (let ((end-marker
 452                     (progn
 453                       (forward-char 2)  ;skip "#s"
 454                       (forward-sexp)    ;move to the left paren
 455                       (point-marker))))
 456                (with-temp-buffer
 457                  (buffer-disable-undo)
 458                  (insert-buffer-substring (marker-buffer marker)
 459                                           marker end-marker)
 460                  (goto-char (point-min))
 461                  (delete-char 2)
 462                  (let ((object (read (current-buffer)))
 463                        hash-table data)
 464                    (if (eq 'hash-table (car object))
 465                        (progn
 466                          (setq hash-table
 467                                (lsdb-make-hash-table
 468                                 :size (plist-get (cdr object) 'size)
 469                                 :test 'equal)
 470                                data (plist-get (cdr object) 'data))
 471                          (while data
 472                            (lsdb-puthash (pop data) (pop data) hash-table))
 473                          hash-table)
 474                      object))))
 475            (read marker)))))))
 476
 477 (defun lsdb-load-hash-tables ()
 478   "Read the contents of `lsdb-file' into the internal hash tables."
 479   (let ((buffer (find-file-noselect lsdb-file))
 480         tables)
 481     (unwind-protect
 482         (save-excursion
 483           (set-buffer buffer)
 484           (goto-char (point-min))
 485           (re-search-forward "^#s(")
 486           (goto-char (match-beginning 0))
 487           (setq lsdb-hash-table (lsdb-read (point-marker)))
 488           ;; Load the secondary hash tables following.
 489           (setq tables lsdb-secondary-hash-tables)
 490           (while tables
 491             (if (re-search-forward
 492                  (concat "^" (lsdb-secondary-hash-table-start
 493                               (car tables)))
 494                  nil t)
 495                 (set (car tables) (lsdb-read (point-marker))))
 496             (setq tables (cdr tables))))
 497       (kill-buffer buffer))))
 498
 499 (defun lsdb-insert-hash-table (hash-table)
 500   (insert "#s(hash-table size "
 501           ;; Reduce the actual size of the close hash table, because
 502           ;; XEmacs doesn't have a distinction between index-size and
 503           ;; hash-table-size.
 504           (number-to-string (lsdb-hash-table-count hash-table))
 505           " test equal data (\n")
 506   (lsdb-maphash
 507    (lambda (key value)
 508      (let (print-level print-length)
 509        (insert (prin1-to-string key) " " (prin1-to-string value) "\n")))
 510    hash-table)
 511   (insert "))"))
 512
 513 (defun lsdb-save-hash-tables ()
 514   "Write the records within the internal hash tables into `lsdb-file'."
 515   (let ((coding-system-for-write lsdb-file-coding-system)
 516         tables)
 517     (with-temp-file lsdb-file
 518       (if (and (or (featurep 'mule)
 519                    (featurep 'file-coding))
 520                lsdb-file-coding-system)
 521           (let ((coding-system-name
 522                  (if (symbolp lsdb-file-coding-system)
 523                      (symbol-name lsdb-file-coding-system)
 524                    ;; XEmacs
 525                    (static-if (featurep 'xemacs)
 526                        (symbol-name (coding-system-name
 527                                      lsdb-file-coding-system))))))
 528             (if coding-system-name
 529                 (insert ";;; -*- mode: emacs-lisp; coding: "
 530                         coding-system-name " -*-\n"))))
 531       (lsdb-insert-hash-table lsdb-hash-table)
 532       ;; Save the secondary hash tables following.
 533       (setq tables lsdb-secondary-hash-tables)
 534       (while tables
 535         (insert "\n" (lsdb-secondary-hash-table-start
 536                       (car tables)))
 537         (lsdb-insert-hash-table (symbol-value (car tables)))
 538         (setq tables (cdr tables))))))
 539
 540 ;;;_. Mail Header Extraction
 541 (defun lsdb-fetch-fields (regexp)
 542   (save-excursion
 543     (goto-char (point-min))
 544     (let ((case-fold-search t)
 545           field-bodies)
 546       (while (re-search-forward (concat "^\\(" regexp "\\):[ \t]*")
 547                                 nil t)
 548         (push (cons (match-string 1)
 549                     (buffer-substring (point) (std11-field-end)))
 550               field-bodies))
 551       (nreverse field-bodies))))
 552
 553 (defun lsdb-canonicalize-spaces-and-dots (string)
 554   (while (string-match "  +\\|[\f\t\n\r\v]+\\|\\." string)
 555     (setq string (replace-match " " nil t string)))
 556   string)
 557
 558 (defun lsdb-extract-address-components (string)
 559   (let ((components (std11-extract-address-components string)))
 560     (if (and (nth 1 components)
 561              ;; When parsing a group address,
 562              ;; std11-extract-address-components is likely to return
 563              ;; the ("GROUP" "") form.
 564              (not (equal (nth 1 components) "")))
 565         (if (car components)
 566             (list (funcall lsdb-canonicalize-full-name-function
 567                            (car components))
 568                   (nth 1 components))
 569           (list (nth 1 components) (nth 1 components))))))
 570
 571 ;; stolen (and renamed) from nnheader.el
 572 (defun lsdb-decode-field-body (field-body field-name
 573                                           &optional mode max-column)
 574   (let ((multibyte enable-multibyte-characters))
 575     (unwind-protect
 576         (progn
 577           (set-buffer-multibyte t)
 578           (mime-decode-field-body field-body
 579                                   (if (stringp field-name)
 580                                       (intern (capitalize field-name))
 581                                     field-name)
 582                                   mode max-column))
 583       (set-buffer-multibyte multibyte))))
 584
 585 ;;;_. Record Management
 586 (defun lsdb-rebuild-secondary-hash-tables (&optional force)
 587   (let ((tables lsdb-secondary-hash-tables))
 588     (while tables
 589       (when (or force (not (symbol-value (car tables))))
 590         (set (car tables) (lsdb-make-hash-table :test 'equal))
 591         (setq lsdb-hash-tables-are-dirty t))
 592       (setq tables (cdr tables))))
 593   (if lsdb-hash-tables-are-dirty
 594       (lsdb-maphash
 595        (lambda (key value)
 596          (run-hook-with-args
 597           'lsdb-after-update-record-functions
 598           (cons key value)))
 599        lsdb-hash-table)))
 600
 601 (defun lsdb-maybe-load-hash-tables ()
 602   (unless lsdb-hash-table
 603     (if (file-exists-p lsdb-file)
 604         (lsdb-load-hash-tables)
 605       (setq lsdb-hash-table (lsdb-make-hash-table :test 'equal)))
 606     (lsdb-rebuild-secondary-hash-tables)))
 607
 608 ;;;_ : Fallback Lookup Functions
 609 ;;;_  , #1 Address Cache
 610 (defun lsdb-lookup-full-name-from-address-cache (sender)
 611   (lsdb-gethash (nth 1 sender) lsdb-address-cache))
 612
 613 (defun lsdb-update-address-cache (record)
 614   (let ((net (cdr (assq 'net record))))
 615     (while net
 616       (lsdb-puthash (pop net) (car record) lsdb-address-cache))))
 617
 618 (defun lsdb-delete-address-cache (record)
 619   (let ((net (cdr (assq 'net record))))
 620     (while net
 621       (lsdb-remhash (pop net) lsdb-address-cache))))
 622
 623 ;;;_  , #2 Iterate on the All Records (very slow)
 624 (defun lsdb-lookup-full-name-by-fuzzy-matching (sender)
 625   (let ((names
 626          (if (string-match
 627               "\\`\\(.+\\)[ \t]+\\(/[ \t]+\\|(\\([^)]+\\))\\)"
 628               (car sender))
 629              (if (match-beginning 3)
 630                  (list (match-string 1 (car sender))
 631                        (match-string 3 (car sender)))
 632                (list (match-string 1 (car sender))
 633                      (substring (car sender) (match-end 0))))
 634            (list (car sender))))
 635         (case-fold-search t))
 636     (catch 'found
 637       (lsdb-maphash
 638        (lambda (key value)
 639          (while names
 640            (if (or (string-match
 641                     (concat "\\<" (regexp-quote (car names)) "\\>")
 642                     key)
 643                    (string-match
 644                     (concat
 645                      "\\<"
 646                      (regexp-quote
 647                       (mapconcat #'identity
 648                                  (nreverse (split-string (car names)))
 649                                  " "))
 650                      "\\>")
 651                     key)
 652                    ;; Don't assume that we are using address cache.
 653                    (member (nth 1 sender) (cdr (assq 'net value))))
 654                (throw 'found key))
 655            (setq names (cdr names))))
 656        lsdb-hash-table))))
 657
 658 ;;;_ : Update Records
 659 (defun lsdb-update-record (sender &optional interesting)
 660   (let ((old (lsdb-gethash (car sender) lsdb-hash-table))
 661         (new (if (nth 1 sender)
 662                  (cons (cons 'net (list (nth 1 sender)))
 663                        interesting)
 664                interesting))
 665         merged
 666         record
 667         full-name)
 668     ;; Look for the existing record from the reverse hash table.
 669     ;; If it is found, regsiter the current full-name as AKA.
 670     (unless old
 671       (setq full-name
 672             (run-hook-with-args-until-success
 673              'lsdb-lookup-full-name-functions
 674              sender))
 675       (when full-name
 676         (setq old (lsdb-gethash full-name lsdb-hash-table)
 677               new (cons (list 'aka (car sender)) new))
 678         (setcar sender full-name)))
 679     (unless old
 680       (setq new (cons (cons 'creation-date (format-time-string "%Y-%m-%d"))
 681                       new)))
 682     (setq merged (lsdb-merge-record-entries old new)
 683           record (cons (car sender) merged))
 684     (unless (equal merged old)
 685       (let ((entry (assq 'last-modified (cdr record)))
 686             (last-modified (format-time-string "%Y-%m-%d")))
 687         (if entry
 688             (setcdr entry last-modified)
 689           (setcdr record (cons (cons 'last-modified last-modified)
 690                                (cdr record)))))
 691       (lsdb-puthash (car record) (cdr record)
 692                     lsdb-hash-table)
 693       (run-hook-with-args 'lsdb-after-update-record-functions record)
 694       (setq lsdb-hash-tables-are-dirty t))
 695     record))
 696
 697 (defun lsdb-update-records ()
 698   (lsdb-maybe-load-hash-tables)
 699   (let (senders recipients interesting alist records bodies entry)
 700     (save-restriction
 701       (std11-narrow-to-header)
 702       (setq senders
 703             (delq nil (mapcar (lambda (field)
 704                                 (let ((components
 705                                        (lsdb-extract-address-components
 706                                         (cdr field))))
 707                                   (if components
 708                                       (setcar
 709                                        components
 710                                        (funcall lsdb-decode-field-body-function
 711                                                 (car components) (car field))))
 712                                   components))
 713                               (lsdb-fetch-fields
 714                                lsdb-sender-headers)))
 715             recipients
 716             (delq nil (mapcar (lambda (field)
 717                                 (let ((components
 718                                        (lsdb-extract-address-components
 719                                         (cdr field))))
 720                                   (if components
 721                                       (setcar
 722                                        components
 723                                        (funcall lsdb-decode-field-body-function
 724                                                 (car components) (car field))))
 725                                   components))
 726                               (lsdb-fetch-fields
 727                                lsdb-recipients-headers))))
 728       (setq alist lsdb-interesting-header-alist)
 729       (while alist
 730         (setq bodies
 731               (delq nil (mapcar
 732                          (lambda (field)
 733                            (let ((field-body
 734                                   (funcall lsdb-decode-field-body-function
 735                                            (cdr field) (car field))))
 736                              (if (nth 1 (car alist))
 737                                  (and (string-match (nth 1 (car alist))
 738                                                     field-body)
 739                                       (replace-match (nth 3 (car alist))
 740                                                      nil nil field-body))
 741                                field-body)))
 742                          (lsdb-fetch-fields (car (car alist))))))
 743         (when bodies
 744           (setq entry (or (nth 2 (car alist))
 745                           'notes))
 746           (push (cons entry
 747                       (if (eq ?. (nth 2 (assq entry lsdb-entry-type-alist)))
 748                           (car bodies)
 749                         bodies))
 750                 interesting))
 751         (setq alist (cdr alist))))
 752     (if senders
 753         (setq records (list (lsdb-update-record (pop senders) interesting))))
 754     (setq alist (nconc senders recipients))
 755     (while alist
 756       (setq records (cons (lsdb-update-record (pop alist)) records)))
 757     (nreverse records)))
 758
 759 (defun lsdb-merge-record-entries (old new)
 760   (setq old (copy-sequence old))
 761   (while new
 762     (let ((entry (assq (car (car new)) old))
 763           list pointer)
 764       (if (null entry)
 765           (setq old (nconc old (list (car new))))
 766         (if (listp (cdr entry))
 767             (progn
 768               (setq list (cdr (car new)) pointer list)
 769               (while pointer
 770                 (if (member (car pointer) (cdr entry))
 771                     (setq list (delq (car pointer) list)))
 772                 (setq pointer (cdr pointer)))
 773               (setcdr entry (nconc (cdr entry) list)))
 774           (setcdr entry (cdr (car new))))))
 775     (setq new (cdr new)))
 776   old)
 777
 778 ;;;_. Display Management
 779 (defun lsdb-fit-window-to-buffer (&optional window)
 780   (save-selected-window
 781     (if window
 782         (select-window window))
 783     (unless (pos-visible-in-window-p (point-max))
 784       (enlarge-window (- lsdb-window-max-height (window-height))))
 785     (shrink-window-if-larger-than-buffer)
 786     (let ((height (window-height)))
 787       (if (> height lsdb-window-max-height)
 788           (shrink-window (- height lsdb-window-max-height)))
 789       (set-window-start window (point-min)))))
 790
 791 (defun lsdb-temp-buffer-show-function (buffer)
 792   (when lsdb-pop-up-windows
 793     (save-selected-window
 794       (let ((window (or (get-buffer-window lsdb-buffer-name)
 795                         (progn
 796                           (select-window (get-largest-window))
 797                           (split-window-vertically)))))
 798         (set-window-buffer window buffer)
 799         (lsdb-fit-window-to-buffer window)))))
 800
 801 (defun lsdb-update-records-and-display ()
 802   (let ((records (lsdb-update-records)))
 803     (if lsdb-display-records-belong-to-user
 804         (if records
 805             (lsdb-display-record (car records))
 806           (lsdb-hide-buffer))
 807       (catch 'lsdb-show-record
 808         (while records
 809           (if (member user-mail-address (cdr (assq 'net (car records))))
 810               (setq records (cdr records))
 811             (lsdb-display-record (car records))
 812             (throw 'lsdb-show-record t)))
 813         (lsdb-hide-buffer)))))
 814
 815 (defun lsdb-display-record (record)
 816   "Display only one RECORD, then shrink the window as possible."
 817   (let ((temp-buffer-show-function lsdb-temp-buffer-show-function))
 818     (lsdb-display-records (list record))))
 819
 820 (defun lsdb-display-records (records)
 821   (with-current-buffer (get-buffer-create lsdb-buffer-name)
 822     (let ((standard-output (current-buffer))
 823           (inhibit-read-only t)
 824           buffer-read-only)
 825       (buffer-disable-undo)
 826       (erase-buffer)
 827       (setq records
 828             (sort (copy-sequence records)
 829                   (or lsdb-display-records-sort-predicate
 830                       (lambda (record1 record2)
 831                         (string-lessp (car record1) (car record2))))))
 832       (while records
 833         (save-restriction
 834           (narrow-to-region (point) (point))
 835           (lsdb-print-record (car records)))
 836         (goto-char (point-max))
 837         (setq records (cdr records))))
 838     (lsdb-mode)
 839     (set-buffer-modified-p lsdb-hash-tables-are-dirty)
 840     (goto-char (point-min))
 841     (if temp-buffer-show-function
 842         (funcall temp-buffer-show-function (current-buffer))
 843       (pop-to-buffer (current-buffer)))))
 844
 845 (defsubst lsdb-entry-score (entry)
 846   (or (nth 1 (assq (car entry) lsdb-entry-type-alist)) 0))
 847
 848 (defun lsdb-insert-entry (entry)
 849   (let ((entry-name (capitalize (symbol-name (car entry)))))
 850     (intern entry-name lsdb-known-entry-names)
 851     (if (>= (lsdb-entry-score entry) 0)
 852         (insert "\t" entry-name ": "
 853                 (if (listp (cdr entry))
 854                     (mapconcat
 855                      #'identity (cdr entry)
 856                      (if (eq ?, (nth 2 (assq (car entry)
 857                                              lsdb-entry-type-alist)))
 858                          ", "
 859                        "\n\t\t"))
 860                   (cdr entry))
 861                 "\n"))))
 862
 863 (defun lsdb-print-record (record)
 864   (insert (car record) "\n")
 865   (let ((entries
 866          (sort (copy-sequence (cdr record))
 867                (lambda (entry1 entry2)
 868                  (> (lsdb-entry-score entry1) (lsdb-entry-score entry2))))))
 869     (while entries
 870       (lsdb-insert-entry (car entries))
 871       (setq entries (cdr entries))))
 872   (add-text-properties (point-min) (point-max)
 873                        (list 'lsdb-record record))
 874   (run-hooks 'lsdb-print-record-hook))
 875
 876 ;;;_. Completion
 877 (defvar lsdb-last-completion nil)
 878 (defvar lsdb-last-candidates nil)
 879 (defvar lsdb-last-candidates-pointer nil)
 880 (defvar lsdb-complete-marker nil)
 881
 882 ;;;_ : Matching Highlight
 883 (defvar lsdb-last-highlight-overlay nil)
 884
 885 ;;; avoid byte-compile warning for migemo
 886 (eval-when-compile
 887   (autoload 'migemo-get-pattern "migemo"))
 888
 889 (defun lsdb-complete-name-highlight (start end)
 890   (make-local-hook 'pre-command-hook)
 891   (add-hook 'pre-command-hook 'lsdb-complete-name-highlight-update nil t)
 892   (save-excursion
 893     (goto-char start)
 894     (if (and lsdb-use-migemo (fboundp 'migemo-get-pattern))
 895         (re-search-forward lsdb-last-completion end)
 896       (search-forward lsdb-last-completion end))
 897     (setq lsdb-last-highlight-overlay
 898           (make-overlay (match-beginning 0) (match-end 0)))
 899     (overlay-put lsdb-last-highlight-overlay 'face
 900                  (or (find-face 'isearch-secondary)
 901                      (find-face 'isearch-lazy-highlight-face)
 902                      'underline))))
 903
 904 (defun lsdb-complete-name-highlight-update ()
 905   (unless (eq this-command 'lsdb-complete-name)
 906     (if lsdb-last-highlight-overlay
 907         (delete-overlay lsdb-last-highlight-overlay))
 908     (set-marker lsdb-complete-marker nil)
 909     (remove-hook 'pre-command-hook
 910                  'lsdb-complete-name-highlight-update t)))
 911
 912 ;;;_ : Name Completion
 913 (defun lsdb-complete-name ()
 914   "Complete the user full-name or net-address before point"
 915   (interactive)
 916   (lsdb-maybe-load-hash-tables)
 917   (unless (markerp lsdb-complete-marker)
 918     (setq lsdb-complete-marker (make-marker)))
 919   (let* ((start
 920           (or (and (eq (marker-buffer lsdb-complete-marker) (current-buffer))
 921                    (marker-position lsdb-complete-marker))
 922               (save-excursion
 923                 (re-search-backward "\\(\\`\\|[\n:,]\\)[ \t]*")
 924                 (set-marker lsdb-complete-marker (match-end 0)))))
 925          pattern
 926          (case-fold-search t)
 927          (completion-ignore-case t))
 928     (unless (eq last-command this-command)
 929       (setq lsdb-last-candidates nil
 930             lsdb-last-candidates-pointer nil
 931             lsdb-last-completion (buffer-substring start (point)))
 932       (if (and lsdb-use-migemo (fboundp 'migemo-get-pattern))
 933           (setq lsdb-last-completion (migemo-get-pattern lsdb-last-completion)
 934                 pattern (concat "\\<\\(" lsdb-last-completion "\\)"))
 935         (setq pattern (concat "\\<" (regexp-quote lsdb-last-completion))))
 936       (lsdb-maphash
 937        (lambda (key value)
 938          (setq lsdb-last-candidates
 939                (nconc lsdb-last-candidates
 940                       (delq nil (mapcar
 941                                  (lambda (candidate)
 942                                    (if (string-match pattern candidate)
 943                                        candidate))
 944                                  (if lsdb-strip-address
 945                                      (cdr (assq 'net value))
 946                                    (append (cdr (assq 'net value))
 947                                            (cdr (assq 'sender value)))))))))
 948        lsdb-hash-table)
 949       ;; Sort candidates by the position where the pattern occurred.
 950       (setq lsdb-last-candidates
 951             (sort lsdb-last-candidates
 952                   (lambda (cand1 cand2)
 953                     (< (if (string-match pattern cand1)
 954                            (match-beginning 0))
 955                        (if (string-match pattern cand2)
 956                            (match-beginning 0)))))))
 957     (unless lsdb-last-candidates-pointer
 958       (setq lsdb-last-candidates-pointer lsdb-last-candidates))
 959     (when lsdb-last-candidates-pointer
 960       (delete-region start (point))
 961       (insert (pop lsdb-last-candidates-pointer))
 962       (lsdb-complete-name-highlight start (point)))))
 963
 964 ;;;_. Major Mode (`lsdb-mode') Implementation
 965 ;;;_ : Modeline Buffer Identification
 966 (defconst lsdb-pointer-xpm
 967   "/* XPM */
 968 static char * lsdb_pointer_xpm[] = {
 969 \"14 14 5 1\",
 970 \"      c None\",
 971 \"+     c #FF9696\",
 972 \"@     c #FF0000\",
 973 \"#     c #FF7575\",
 974 \"$     c #FF5959\",
 975 \"              \",
 976 \"  +++   @@@   \",
 977 \" +++## @@@@@  \",
 978 \" ++### @@@@@  \",
 979 \" +#####@@@@@  \",
 980 \" +###$$@@@@@  \",
 981 \" +###$$@@@@@  \",
 982 \"  ##$$$@@@@   \",
 983 \"   #$$$@@@    \",
 984 \"    $$@@@     \",
 985 \"     $@@      \",
 986 \"      @       \",
 987 \"              \",
 988 \"              \"};")
 989
 990 (static-if (featurep 'xemacs)
 991     (progn
 992       (defvar lsdb-xemacs-modeline-left-extent
 993         (copy-extent modeline-buffer-id-left-extent))
 994
 995       (defvar lsdb-xemacs-modeline-right-extent
 996         (copy-extent modeline-buffer-id-right-extent))
 997
 998       (defun lsdb-modeline-buffer-identification (line)
 999         "Decorate 1st element of `mode-line-buffer-identification' LINE.
1000 Modify whole identification by side effect."
1001         (let ((id (car line)) chopped)
1002           (if (and (stringp id) (string-match "^LSDB:" id))
1003               (progn
1004                 (setq chopped (substring id 0 (match-end 0))
1005                       id (substring id (match-end 0)))
1006                 (nconc
1007                  (list
1008                   (let ((glyph
1009                          (make-glyph
1010                           (nconc
1011                            (if (featurep 'xpm)
1012                                (list (vector 'xpm :data lsdb-pointer-xpm)))
1013                            (list (vector 'string :data chopped))))))
1014                     (set-glyph-face glyph 'modeline-buffer-id)
1015                     (cons lsdb-xemacs-modeline-left-extent glyph))
1016                   (cons lsdb-xemacs-modeline-right-extent id))
1017                  (cdr line)))
1018             line))))
1019   (condition-case nil
1020       (progn
1021         (require 'image)
1022         (defun lsdb-modeline-buffer-identification (line)
1023           "Decorate 1st element of `mode-line-buffer-identification' LINE.
1024 Modify whole identification by side effect."
1025           (let ((id (copy-sequence (car line)))
1026                 (image
1027                  (if (image-type-available-p 'xpm)
1028                      (create-image lsdb-pointer-xpm 'xpm t :ascent 'center))))
1029             (when (and image
1030                        (stringp id) (string-match "^LSDB:" id))
1031               (add-text-properties 0 (length id)
1032                                    (list 'display image
1033                                          'rear-nonsticky (list 'display))
1034                                    id)
1035               (setcar line id))
1036             line)))
1037     (error
1038      (defalias 'lsdb-modeline-buffer-identification 'identity))))
1039
1040 (defvar lsdb-mode-map
1041   (let ((keymap (make-sparse-keymap)))
1042     (define-key keymap "a" 'lsdb-mode-add-entry)
1043     (define-key keymap "d" 'lsdb-mode-delete-entry)
1044     (define-key keymap "D" 'lsdb-mode-delete-record)
1045     (define-key keymap "e" 'lsdb-mode-edit-entry)
1046     (define-key keymap "E" 'lsdb-mode-edit-record)
1047     (define-key keymap "l" 'lsdb-mode-load)
1048     (define-key keymap "s" 'lsdb-mode-save)
1049     (define-key keymap "q" 'lsdb-mode-quit-window)
1050     (define-key keymap "g" 'lsdb-mode-lookup)
1051     (define-key keymap "p" 'lsdb-mode-previous-record)
1052     (define-key keymap "n" 'lsdb-mode-next-record)
1053     (define-key keymap " " 'scroll-up)
1054     (define-key keymap [delete] 'scroll-down)
1055     (define-key keymap "\177" 'scroll-down)
1056     (define-key keymap [backspace] 'scroll-down)
1057     keymap)
1058   "LSDB's keymap.")
1059
1060 (defvar lsdb-modeline-string "")
1061
1062 (define-derived-mode lsdb-mode fundamental-mode "LSDB"
1063   "Major mode for browsing LSDB records."
1064   (setq buffer-read-only t)
1065   (static-if (featurep 'xemacs)
1066       ;; In XEmacs, setting `font-lock-defaults' only affects on
1067       ;; `find-file-hooks'.
1068       (font-lock-set-defaults)
1069     (set (make-local-variable 'font-lock-defaults)
1070          '(lsdb-font-lock-keywords t)))
1071   (make-local-hook 'post-command-hook)
1072   (add-hook 'post-command-hook 'lsdb-modeline-update nil t)
1073   (make-local-variable 'lsdb-modeline-string)
1074   (setq mode-line-buffer-identification
1075         (lsdb-modeline-buffer-identification
1076          '("LSDB: " lsdb-modeline-string)))
1077   (lsdb-modeline-update)
1078   (force-mode-line-update))
1079
1080 (defun lsdb-modeline-update ()
1081   (let ((record
1082          (get-text-property (if (eobp) (point-min) (point)) 'lsdb-record))
1083         net)
1084     (if record
1085         (progn
1086           (setq net (car (cdr (assq 'net (cdr record)))))
1087           (if (and net (equal net (car record)))
1088               (setq lsdb-modeline-string net)
1089             (setq lsdb-modeline-string (concat (car record) " <" net ">"))))
1090       (setq lsdb-modeline-string ""))))
1091
1092 (defun lsdb-narrow-to-record ()
1093   "Narrow to the current record."
1094   (let ((end (next-single-property-change (point) 'lsdb-record nil
1095                                           (point-max))))
1096     (narrow-to-region
1097      (previous-single-property-change end 'lsdb-record nil (point-min))
1098      end)
1099     (goto-char (point-min))))
1100
1101 (defun lsdb-current-record ()
1102   "Return the current record name."
1103   (get-text-property (point) 'lsdb-record))
1104
1105 (defun lsdb-delete-record (record)
1106   "Delete given RECORD."
1107   (lsdb-remhash (car record) lsdb-hash-table)
1108   (run-hook-with-args 'lsdb-after-delete-record-functions record)
1109   (setq lsdb-hash-tables-are-dirty t))
1110
1111 (defun lsdb-current-entry ()
1112   "Return the current entry name in canonical form."
1113   (save-excursion
1114     (beginning-of-line)
1115     (if (looking-at "^\t\\([^\t][^:]+\\):")
1116         (intern (downcase (match-string 1))))))
1117
1118 (defun lsdb-read-entry (record &optional prompt)
1119   "Prompt to select an entry in the given RECORD."
1120   (let* ((completion-ignore-case t)
1121          (entry-name
1122           (completing-read
1123            (or prompt
1124                "Which entry: ")
1125            (mapcar (lambda (entry)
1126                      (list (capitalize (symbol-name (car entry)))))
1127                    (cdr record))
1128            nil t)))
1129     (unless (equal entry-name "")
1130       (intern (downcase entry-name)))))
1131
1132 (defun lsdb-delete-entry (record entry)
1133   "Delete given ENTRY from RECORD."
1134   (setcdr record (delq entry (cdr record)))
1135   (lsdb-puthash (car record) (cdr record)
1136                 lsdb-hash-table)
1137   (run-hook-with-args 'lsdb-after-update-record-functions record)
1138   (setq lsdb-hash-tables-are-dirty t))
1139
1140 (defun lsdb-mode-add-entry (entry-name)
1141   "Add an entry on the current line."
1142   (interactive
1143    (let ((completion-ignore-case t))
1144      (list (completing-read "Entry name: " lsdb-known-entry-names))))
1145   (beginning-of-line)
1146   (unless (symbolp entry-name)
1147     (setq entry-name (intern (downcase entry-name))))
1148   (when (assq entry-name (cdr (lsdb-current-record)))
1149     (error "The entry already exists"))
1150   (let ((marker (point-marker)))
1151     (lsdb-edit-form
1152      nil "Editing the entry."
1153      `(lambda (form)
1154         (when form
1155           (save-excursion
1156             (set-buffer lsdb-buffer-name)
1157             (goto-char ,marker)
1158             (let ((record (lsdb-current-record))
1159                   (inhibit-read-only t)
1160                   buffer-read-only)
1161               (setcdr record (cons (cons ',entry-name form) (cdr record)))
1162               (lsdb-puthash (car record) (cdr record)
1163                             lsdb-hash-table)
1164               (run-hook-with-args 'lsdb-after-update-record-functions record)
1165               (setq lsdb-hash-tables-are-dirty t)
1166               (beginning-of-line 2)
1167               (add-text-properties
1168                (point)
1169                (progn
1170                  (lsdb-insert-entry (cons ',entry-name form))
1171                  (point))
1172                (list 'lsdb-record record)))))))))
1173
1174 (defun lsdb-mode-delete-entry-1 (entry)
1175   "Delete text contents of the ENTRY from the current buffer."
1176   (save-restriction
1177     (lsdb-narrow-to-record)
1178     (let ((case-fold-search t)
1179           (inhibit-read-only t)
1180           buffer-read-only)
1181       (goto-char (point-min))
1182       (if (re-search-forward
1183            (concat "^\t" (capitalize (symbol-name (car entry))) ":")
1184            nil t)
1185           (delete-region (match-beginning 0)
1186                          (if (re-search-forward
1187                               "^\t[^\t][^:]+:" nil t)
1188                              (match-beginning 0)
1189                            (point-max)))))))
1190
1191 (defun lsdb-mode-delete-entry ()
1192   "Delete the entry on the current line."
1193   (interactive)
1194   (let ((record (lsdb-current-record))
1195         entry-name entry)
1196     (unless record
1197       (error "There is nothing to follow here"))
1198     (setq entry-name (or (lsdb-current-entry)
1199                          (lsdb-read-entry record "Which entry to delete: "))
1200           entry (assq entry-name (cdr record)))
1201     (when (and entry
1202                (or (not lsdb-verbose)
1203                    (y-or-n-p
1204                     (format "Do you really want to delete entry `%s' of `%s'? "
1205                             entry-name (car record)))))
1206       (lsdb-delete-entry record entry)
1207       (lsdb-mode-delete-entry-1 entry))))
1208
1209 (defun lsdb-mode-delete-record ()
1210   "Delete the record on the current line."
1211   (interactive)
1212   (let ((record (lsdb-current-record)))
1213     (unless record
1214       (error "%s" "There is nothing to follow here"))
1215     (when (or (not lsdb-verbose)
1216               (yes-or-no-p
1217                (format "Do you really want to delete entire record of `%s'? "
1218                        (car record))))
1219       (lsdb-delete-record record)
1220       (save-restriction
1221         (lsdb-narrow-to-record)
1222         (let ((inhibit-read-only t)
1223               buffer-read-only)
1224           (delete-region (point-min) (point-max)))))))
1225
1226 (defun lsdb-mode-delete-entry-or-record ()
1227   "Delete the entry on the current line.
1228 If the cursor is on the first line of a database entry (the name line)
1229 then the entire entry will be deleted."
1230   (interactive)
1231   (if (lsdb-current-entry)
1232       (lsdb-mode-delete-entry)
1233     (lsdb-mode-delete-record)))
1234
1235 (defun lsdb-mode-edit-entry ()
1236   "Edit the entry on the current line."
1237   (interactive)
1238   (let ((record (lsdb-current-record)))
1239     (unless record
1240       (error "There is nothing to follow here"))
1241     (let ((entry-name (or (lsdb-current-entry)
1242                           (lsdb-read-entry record "Which entry to edit: "))))
1243       (lsdb-edit-form
1244        (cdr (assq entry-name (cdr record))) "Editing the entry."
1245        `(lambda (form)
1246           (let* ((record ',record)
1247                  (entry-name ',entry-name)
1248                  (entry (assq entry-name (cdr record))))
1249             (unless (equal form (cdr entry))
1250               (setcdr entry form)
1251               (run-hook-with-args 'lsdb-after-update-record-functions record)
1252               (setq lsdb-hash-tables-are-dirty t)
1253               (with-current-buffer lsdb-buffer-name
1254                 (let ((inhibit-read-only t)
1255                       buffer-read-only
1256                       (pos (text-property-any (point-min) (point-max)
1257                                               'lsdb-record record)))
1258                   (unless pos
1259                     (error "%s" "The entry currently in editing is discarded"))
1260                   (lsdb-mode-delete-entry-1 entry)
1261                   (forward-line 0)
1262                   (add-text-properties
1263                    (point)
1264                    (progn
1265                      (lsdb-insert-entry (cons entry-name form))
1266                      (point))
1267                    (list 'lsdb-record record)))))))))))
1268
1269 (defun lsdb-mode-edit-record ()
1270   "Edit the name of the record on the current line."
1271   (interactive)
1272   (let ((record (lsdb-current-record)))
1273     (unless record
1274       (error "There is nothing to follow here"))
1275     (lsdb-edit-form
1276      (car record) "Editing the name."
1277      `(lambda (new-name)
1278         (unless (stringp new-name)
1279           (error "String is required: `%s'" new-name))
1280         (let* ((record ',record)
1281                (old-name (car record)))
1282           (unless (equal new-name old-name)
1283             (lsdb-delete-record record)
1284             (setcar record new-name)
1285             (lsdb-puthash new-name (cdr record) lsdb-hash-table)
1286             (run-hook-with-args 'lsdb-after-update-record-functions record)
1287             (setq lsdb-hash-tables-are-dirty t)
1288             (with-current-buffer lsdb-buffer-name
1289               (let ((inhibit-read-only t)
1290                     buffer-read-only
1291                     (pos (text-property-any (point-min) (point-max)
1292                                             'lsdb-record record)))
1293                 (unless pos
1294                   (error "%s" "The entry currently in editing is discarded"))
1295                 (delete-region (point) (+ (point) (length old-name)))
1296                 (add-text-properties (point)
1297                                      (progn (insert form) (point))
1298                                      (list 'lsdb-record record))))))))))
1299
1300 (defun lsdb-mode-edit-entry-or-record ()
1301   "Edit the entry on the current line.
1302 If the cursor is on the first line of a database entry (the name line)
1303 then the name of this record will be edited."
1304   (interactive)
1305   (if (lsdb-current-entry)
1306       (lsdb-mode-edit-entry)
1307     (lsdb-mode-edit-record)))
1308
1309 (defun lsdb-mode-save (&optional force)
1310   "Save LSDB hash table into `lsdb-file'."
1311   (interactive "P")
1312   (if (not (or force
1313                lsdb-hash-tables-are-dirty))
1314       (message "(No changes need to be saved)")
1315     (when (or (interactive-p)           ;Don't ask user if this
1316                                         ;function is called as a
1317                                         ;command.
1318               (not lsdb-verbose)
1319               (y-or-n-p "Save the LSDB now? "))
1320       (lsdb-save-hash-tables)
1321       (set-buffer-modified-p (setq lsdb-hash-tables-are-dirty nil))
1322       (message "The LSDB was saved successfully."))))
1323
1324 (defun lsdb-mode-load ()
1325   "Load LSDB hash table from `lsdb-file'."
1326   (interactive)
1327   (let (lsdb-secondary-hash-tables)
1328     (lsdb-load-hash-tables))
1329   (message "Rebuilding secondary hash tables...")
1330   (lsdb-rebuild-secondary-hash-tables t)
1331   (message "Rebuilding secondary hash tables...done"))
1332
1333 (defun lsdb-mode-quit-window (&optional kill window)
1334   "Quit the current buffer.
1335 It partially emulates the GNU Emacs' of `quit-window'."
1336   (interactive "P")
1337   (unless window
1338     (setq window (selected-window)))
1339   (let ((buffer (window-buffer window)))
1340     (unless (save-selected-window
1341               (select-window window)
1342               (one-window-p))
1343       (delete-window window))
1344     (if kill
1345         (kill-buffer buffer)
1346       (bury-buffer (unless (eq buffer (current-buffer)) buffer)))))
1347
1348 (defun lsdb-hide-buffer ()
1349   "Hide the LSDB window."
1350   (let ((window (get-buffer-window lsdb-buffer-name)))
1351     (if window
1352         (lsdb-mode-quit-window nil window))))
1353
1354 (defun lsdb-show-buffer ()
1355   "Show the LSDB window."
1356   (if (get-buffer lsdb-buffer-name)
1357       (if lsdb-temp-buffer-show-function
1358           (let ((lsdb-pop-up-windows t))
1359             (funcall lsdb-temp-buffer-show-function lsdb-buffer-name))
1360         (pop-to-buffer lsdb-buffer-name))))
1361
1362 (defun lsdb-toggle-buffer (&optional arg)
1363   "Toggle hiding of the LSDB window.
1364 If given a negative prefix, always show; if given a positive prefix,
1365 always hide."
1366   (interactive
1367    (list (if current-prefix-arg
1368              (prefix-numeric-value current-prefix-arg)
1369            0)))
1370   (unless arg                           ;called noninteractively?
1371     (setq arg 0))
1372   (cond
1373    ((or (< arg 0)
1374         (and (zerop arg)
1375              (not (get-buffer-window lsdb-buffer-name))))
1376     (lsdb-show-buffer))
1377    ((or (> arg 0)
1378         (and (zerop arg)
1379              (get-buffer-window lsdb-buffer-name)))
1380     (lsdb-hide-buffer))))
1381
1382 (defun lsdb-lookup-records (regexp &optional entry-name)
1383   "Return the all records in the LSDB matching the REGEXP.
1384 If the optional 2nd argument ENTRY-NAME is given, matching only
1385 performed against the entry field."
1386   (let (records)
1387     (lsdb-maphash
1388      (if entry-name
1389          (progn
1390            (lambda (key value)
1391              (let ((entry (cdr (assq entry-name value)))
1392                    found)
1393                (unless (listp entry)
1394                  (setq entry (list entry)))
1395                (while (and (not found) entry)
1396                  (if (string-match regexp (pop entry))
1397                      (setq found t)))
1398                (if found
1399                    (push (cons key value) records)))))
1400        (lambda (key value)
1401          (if (string-match regexp key)
1402              (push (cons key value) records))))
1403      lsdb-hash-table)
1404     records))
1405
1406 (defvar lsdb-mode-lookup-history nil)
1407
1408 (defun lsdb-mode-lookup (regexp &optional entry-name)
1409   "Display the all records in the LSDB matching the REGEXP.
1410 If the optional 2nd argument ENTRY-NAME is given, matching only
1411 performed against the entry field."
1412   (interactive
1413    (let* ((completion-ignore-case t)
1414           (entry-name
1415            (if current-prefix-arg
1416                (completing-read "Entry name: "
1417                                 lsdb-known-entry-names))))
1418      (list
1419       (read-from-minibuffer
1420        (if entry-name
1421            (format "Search records `%s' regexp: " entry-name)
1422          "Search records regexp: ")
1423        nil nil nil 'lsdb-mode-lookup-history)
1424       (if (and entry-name (not (equal entry-name "")))
1425           (intern (downcase entry-name))))))
1426   (lsdb-maybe-load-hash-tables)
1427   (let ((records (lsdb-lookup-records regexp entry-name)))
1428     (if records
1429         (lsdb-display-records records))))
1430
1431 ;;;###autoload
1432 (defalias 'lsdb 'lsdb-mode-lookup)
1433
1434 (defun lsdb-mode-next-record (&optional arg)
1435   "Go to the next record."
1436   (interactive "p")
1437   (unless arg                           ;called noninteractively?
1438     (setq arg 1))
1439   (if (< arg 0)
1440       (lsdb-mode-previous-record (- arg))
1441     (while (> arg 0)
1442       (goto-char (next-single-property-change
1443                   (point) 'lsdb-record nil (point-max)))
1444       (setq arg (1- arg)))))
1445
1446 (defun lsdb-mode-previous-record (&optional arg)
1447   "Go to the previous record."
1448   (interactive "p")
1449   (unless arg                           ;called noninteractively?
1450     (setq arg 1))
1451   (if (< arg 0)
1452       (lsdb-mode-next-record (- arg))
1453     (while (> arg 0)
1454       (goto-char (previous-single-property-change
1455                   (point) 'lsdb-record nil (point-min)))
1456       (setq arg (1- arg)))))
1457
1458 ;;;_ : Edit Forms -- stolen (and renamed) from gnus-eform.el
1459 (defvar lsdb-edit-form-buffer "*LSDB edit form*")
1460 (defvar lsdb-edit-form-done-function nil)
1461 (defvar lsdb-previous-window-configuration nil)
1462
1463 (defvar lsdb-edit-form-mode-map
1464   (let ((keymap (make-sparse-keymap)))
1465     (set-keymap-parent keymap emacs-lisp-mode-map)
1466     (define-key keymap "\C-c\C-c" 'lsdb-edit-form-done)
1467     (define-key keymap "\C-c\C-k" 'lsdb-edit-form-exit)
1468     keymap)
1469   "Edit form's keymap.")
1470
1471 (defun lsdb-edit-form-mode ()
1472   "Major mode for editing forms.
1473 It is a slightly enhanced emacs-lisp-mode.
1474
1475 \\{lsdb-edit-form-mode-map}"
1476   (interactive)
1477   (kill-all-local-variables)
1478   (setq major-mode 'lsdb-edit-form-mode
1479         mode-name "LSDB Edit Form")
1480   (use-local-map lsdb-edit-form-mode-map)
1481   (make-local-variable 'lsdb-edit-form-done-function)
1482   (make-local-variable 'lsdb-previous-window-configuration)
1483   (run-hooks 'lsdb-edit-form-mode-hook))
1484
1485 (defun lsdb-edit-form (form documentation exit-func)
1486   "Edit FORM in a new buffer.
1487 Call EXIT-FUNC on exit.  Display DOCUMENTATION in the beginning
1488 of the buffer."
1489   (let ((window-configuration
1490          (current-window-configuration)))
1491     (switch-to-buffer (get-buffer-create lsdb-edit-form-buffer))
1492     (lsdb-edit-form-mode)
1493     (setq lsdb-previous-window-configuration window-configuration
1494           lsdb-edit-form-done-function exit-func)
1495     (erase-buffer)
1496     (insert documentation)
1497     (unless (bolp)
1498       (insert "\n"))
1499     (goto-char (point-min))
1500     (while (not (eobp))
1501       (insert ";;; ")
1502       (forward-line 1))
1503     (insert ";; Type `C-c C-c' after you've finished editing.\n")
1504     (insert "\n")
1505     (let ((p (point)))
1506       (pp form (current-buffer))
1507       (insert "\n")
1508       (goto-char p))))
1509
1510 (defun lsdb-edit-form-done ()
1511   "Update changes and kill the current buffer."
1512   (interactive)
1513   (goto-char (point-min))
1514   (let ((form (condition-case nil
1515                   (read (current-buffer))
1516                 (end-of-file nil)))
1517         (func lsdb-edit-form-done-function))
1518     (lsdb-edit-form-exit)
1519     (funcall func form)))
1520
1521 (defun lsdb-edit-form-exit ()
1522   "Kill the current buffer."
1523   (interactive)
1524   (let ((window-configuration lsdb-previous-window-configuration))
1525     (kill-buffer (current-buffer))
1526     (set-window-configuration window-configuration)))
1527
1528 ;;;_. Interface to Semi-gnus
1529 ;;;###autoload
1530 (defun lsdb-gnus-insinuate ()
1531   "Call this function to hook LSDB into Semi-gnus."
1532   (add-hook 'gnus-article-prepare-hook 'lsdb-gnus-update-record)
1533   (add-hook 'gnus-save-newsrc-hook 'lsdb-mode-save))
1534
1535 (eval-when-compile
1536   (defvar gnus-article-current-summary)
1537   (defvar gnus-original-article-buffer))
1538
1539 (defun lsdb-gnus-update-record ()
1540   (with-current-buffer (with-current-buffer gnus-article-current-summary
1541                          gnus-original-article-buffer)
1542     (lsdb-update-records-and-display)))
1543
1544 ;;;_. Interface to Wanderlust
1545 ;;;###autoload
1546 (defun lsdb-wl-insinuate ()
1547   "Call this function to hook LSDB into Wanderlust."
1548   (add-hook 'wl-message-redisplay-hook 'lsdb-wl-update-record)
1549   (add-hook 'wl-summary-exit-hook 'lsdb-hide-buffer)
1550   (add-hook 'wl-summary-toggle-disp-off-hook 'lsdb-hide-buffer)
1551   (add-hook 'wl-summary-toggle-disp-folder-on-hook 'lsdb-hide-buffer)
1552   (add-hook 'wl-summary-toggle-disp-folder-off-hook 'lsdb-hide-buffer)
1553   (add-hook 'wl-summary-toggle-disp-folder-message-resumed-hook
1554             'lsdb-wl-show-buffer)
1555   (add-hook 'wl-exit-hook 'lsdb-mode-save)
1556   (add-hook 'wl-save-hook 'lsdb-mode-save))
1557
1558 (eval-when-compile
1559   (autoload 'wl-message-get-original-buffer "wl-message"))
1560 (defun lsdb-wl-update-record ()
1561   (save-excursion
1562     (set-buffer (wl-message-get-original-buffer))
1563     (let ((lsdb-temp-buffer-show-function
1564            #'lsdb-wl-temp-buffer-show-function))
1565       (lsdb-update-records-and-display))))
1566
1567 (defun lsdb-wl-toggle-buffer (&optional arg)
1568   "Toggle hiding of the LSDB window for Wanderlust.
1569 If given a negative prefix, always show; if given a positive prefix,
1570 always hide."
1571   (interactive
1572    (list (if current-prefix-arg
1573              (prefix-numeric-value current-prefix-arg)
1574            0)))
1575   (let ((lsdb-temp-buffer-show-function
1576          #'lsdb-wl-temp-buffer-show-function))
1577     (lsdb-toggle-buffer arg)))
1578
1579 (defun lsdb-wl-show-buffer ()
1580   (when lsdb-pop-up-windows
1581     (let ((lsdb-temp-buffer-show-function
1582            #'lsdb-wl-temp-buffer-show-function))
1583       (lsdb-show-buffer))))
1584
1585 (defvar wl-current-summary-buffer)
1586 (defvar wl-message-buffer)
1587 (defun lsdb-wl-temp-buffer-show-function (buffer)
1588   (when lsdb-pop-up-windows
1589     (save-selected-window
1590       (let ((window (or (get-buffer-window lsdb-buffer-name)
1591                         (progn
1592                           (select-window
1593                            (or (save-excursion
1594                                  (if (buffer-live-p wl-current-summary-buffer)
1595                                      (set-buffer wl-current-summary-buffer))
1596                                  (and wl-message-buffer
1597                                       (get-buffer-window wl-message-buffer)))
1598                                (get-largest-window)))
1599                           (split-window-vertically)))))
1600         (set-window-buffer window buffer)
1601         (lsdb-fit-window-to-buffer window)))))
1602
1603 ;;;_. Interface to Mew written by Hideyuki SHIRAI <shirai@meadowy.org>
1604 (eval-when-compile
1605   (condition-case nil
1606       (progn
1607         (require 'mew)
1608         ;; Avoid macro `mew-cache-hit' expand (Mew 1.94.2 or earlier).
1609         ;; Changed `mew-cache-hit' from macro to function at Mew 2.0.
1610         (if (not (fboundp 'mew-current-get-fld))
1611             (setq byte-compile-macro-environment
1612                   (cons '(mew-cache-hit . nil)
1613                         byte-compile-macro-environment))))
1614     (error
1615      ;; Silence byte compiler for environments where Mew does not installed.
1616      (autoload 'mew-sinfo-get-disp-msg "mew")
1617      (autoload 'mew-current-get-fld "mew")
1618      (autoload 'mew-current-get-msg "mew")
1619      (autoload 'mew-frame-id "mew")
1620      (autoload 'mew-cache-hit "mew")
1621      (autoload 'mew-xinfo-get-decode-err "mew")
1622      (autoload 'mew-xinfo-get-action "mew"))))
1623
1624 ;;;###autoload
1625 (defun lsdb-mew-insinuate ()
1626   "Call this function to hook LSDB into Mew."
1627   (add-hook 'mew-message-hook 'lsdb-mew-update-record)
1628   (add-hook 'mew-summary-toggle-disp-msg-hook
1629             (lambda ()
1630               (unless (mew-sinfo-get-disp-msg)
1631                 (lsdb-hide-buffer))))
1632   (add-hook 'mew-suspend-hook 'lsdb-hide-buffer)
1633   (add-hook 'mew-quit-hook 'lsdb-mode-save)
1634   (add-hook 'kill-emacs-hook 'lsdb-mode-save)
1635   (cond
1636    ;; Mew 3
1637    ((fboundp 'mew-summary-visit-folder)
1638     (defadvice mew-summary-visit-folder (before lsdb-hide-buffer activate)
1639       (lsdb-hide-buffer)))
1640    ;; Mew 2
1641    ((fboundp 'mew-summary-switch-to-folder)
1642     (defadvice mew-summary-switch-to-folder (before lsdb-hide-buffer activate)
1643       (lsdb-hide-buffer)))))
1644
1645 (defun lsdb-mew-update-record ()
1646   (let* ((fld (mew-current-get-fld (mew-frame-id)))
1647          (msg (mew-current-get-msg (mew-frame-id)))
1648          (cache (mew-cache-hit fld msg)))
1649     (when cache
1650       (save-excursion
1651         (set-buffer cache)
1652         (unless (or (mew-xinfo-get-decode-err) (mew-xinfo-get-action))
1653           (make-local-variable 'lsdb-decode-field-body-function)
1654           (setq lsdb-decode-field-body-function
1655                 (lambda (body name)
1656                   (set-text-properties 0 (length body) nil body)
1657                   body))
1658           (lsdb-update-records-and-display))))))
1659
1660 ;;;_. Interface to MU-CITE
1661 (eval-when-compile
1662   (autoload 'mu-cite-get-value "mu-cite"))
1663
1664 (defun lsdb-mu-attribution (address)
1665   "Extract attribute information from LSDB."
1666   (let ((records
1667          (lsdb-lookup-records (concat "\\<" address "\\>") 'net)))
1668     (if records
1669         (cdr (assq 'attribution (cdr (car records)))))))
1670
1671 (defun lsdb-mu-set-attribution (attribution address)
1672   "Add attribute information to LSDB."
1673   (let ((records
1674          (lsdb-lookup-records (concat "\\<" address "\\>") 'net))
1675         entry)
1676     (when records
1677       (setq entry (assq 'attribution (cdr (car records))))
1678       (if entry
1679           (setcdr entry attribution)
1680         (setcdr (car records) (cons (cons 'attribution attribution)
1681                                     (cdr (car records))))
1682         (lsdb-puthash (car (car records)) (cdr (car records))
1683                       lsdb-hash-table)
1684         (run-hook-with-args 'lsdb-after-update-record-functions (car records))
1685         (setq lsdb-hash-tables-are-dirty t)))))
1686
1687 (defun lsdb-mu-get-prefix-method ()
1688   "A mu-cite method to return a prefix from LSDB or \">\".
1689 If an `attribution' value is found in LSDB, the value is returned.
1690 Otherwise \">\" is returned."
1691   (or (lsdb-mu-attribution (mu-cite-get-value 'address))
1692       ">"))
1693
1694 (defvar minibuffer-allow-text-properties)
1695
1696 (defvar lsdb-mu-history nil)
1697
1698 (defun lsdb-mu-get-prefix-register-method ()
1699   "A mu-cite method to return a prefix from LSDB or register it.
1700 If an `attribution' value is found in LSDB, the value is returned.
1701 Otherwise the function requests a prefix from a user.  The prefix will
1702 be registered to LSDB if the user wants it."
1703   (let ((address (mu-cite-get-value 'address)))
1704     (or (lsdb-mu-attribution address)
1705         (let* (minibuffer-allow-text-properties
1706                (result (read-string "Citation name? "
1707                                     (or (mu-cite-get-value 'x-attribution)
1708                                         (mu-cite-get-value 'full-name))
1709                                     'lsdb-mu-history)))
1710           (if (and (not (string-equal result ""))
1711                    (y-or-n-p (format "Register \"%s\"? " result)))
1712               (lsdb-mu-set-attribution result address))
1713           result))))
1714
1715 (defun lsdb-mu-get-prefix-register-verbose-method ()
1716   "A mu-cite method to return a prefix using LSDB.
1717
1718 In this method, a user must specify a prefix unconditionally.  If an
1719 `attribution' value is found in LSDB, the value is used as a initial
1720 value to input the prefix.  The prefix will be registered to LSDB if
1721 the user wants it."
1722   (let* ((address (mu-cite-get-value 'address))
1723          (attribution (lsdb-mu-attribution address))
1724          minibuffer-allow-text-properties
1725          (result (read-string "Citation name? "
1726                               (or attribution
1727                                   (mu-cite-get-value 'x-attribution)
1728                                   (mu-cite-get-value 'full-name))
1729                               'lsdb-mu-history)))
1730     (if (and (not (string-equal result ""))
1731              (not (string-equal result attribution))
1732              (y-or-n-p (format "Register \"%s\"? " result)))
1733         (lsdb-mu-set-attribution result address))
1734     result))
1735
1736 (defvar mu-cite-methods-alist)
1737 ;;;###autoload
1738 (defun lsdb-mu-insinuate ()
1739   (add-hook 'mu-cite-instantiation-hook
1740             (lambda ()
1741               (setq mu-cite-methods-alist
1742                     (nconc
1743                      mu-cite-methods-alist
1744                      (list
1745                       (cons 'lsdb-prefix
1746                             #'lsdb-mu-get-prefix-method)
1747                       (cons 'lsdb-prefix-register
1748                             #'lsdb-mu-get-prefix-register-method)
1749                       (cons 'lsdb-prefix-register-verbose
1750                             #'lsdb-mu-get-prefix-register-verbose-method)))))))
1751
1752 ;;;_. X-Face Rendering
1753 (defvar lsdb-x-face-cache
1754   (lsdb-make-hash-table :test 'equal))
1755
1756 (defun lsdb-x-face-available-image-type ()
1757   (static-if (featurep 'xemacs)
1758       (if (featurep 'xpm)
1759           'xpm)
1760     (and (>= emacs-major-version 21)
1761          (fboundp 'image-type-available-p)
1762          (if (image-type-available-p 'pbm)
1763              'pbm
1764            (if (image-type-available-p 'xpm)
1765                'xpm)))))
1766
1767 (defun lsdb-expose-x-face ()
1768   (let* ((record (get-text-property (point-min) 'lsdb-record))
1769          (x-face (cdr (assq 'x-face (cdr record))))
1770          (delimiter "\r "))
1771     (when (and lsdb-insert-x-face-function
1772                x-face)
1773       (goto-char (point-min))
1774       (end-of-line)
1775       (put-text-property 0 1 'invisible t delimiter) ;hide "\r"
1776       (put-text-property
1777        (point)
1778        (progn
1779          (insert delimiter)
1780          (while x-face
1781            (funcall lsdb-insert-x-face-function (pop x-face)))
1782          (point))
1783        'lsdb-record record))))
1784
1785 (defun lsdb-insert-x-face-image (data type marker)
1786   (static-if (featurep 'xemacs)
1787       (save-excursion
1788         (set-buffer (marker-buffer marker))
1789         (goto-char marker)
1790         (let* ((inhibit-read-only t)
1791                buffer-read-only
1792                (glyph (make-glyph (vector type :data data))))
1793           (set-extent-begin-glyph
1794            (make-extent (point) (point))
1795            glyph)))
1796     (save-excursion
1797       (set-buffer (marker-buffer marker))
1798       (goto-char marker)
1799       (let* ((inhibit-read-only t)
1800              buffer-read-only
1801              (image (create-image data type t :ascent 'center))
1802              (record (get-text-property (point) 'lsdb-record)))
1803         (put-text-property (point) (progn
1804                                      (insert-image image)
1805                                      (point))
1806                            'lsdb-record record)))))
1807
1808 (defun lsdb-insert-x-face-asynchronously (x-face)
1809   (let* ((type (or lsdb-x-face-image-type
1810                    (lsdb-x-face-available-image-type)))
1811          (shell-file-name lsdb-shell-file-name)
1812          (shell-command-switch lsdb-shell-command-switch)
1813          (coding-system-for-read 'binary)
1814          (process-connection-type nil)
1815          (cached (cdr (assq type (lsdb-gethash x-face lsdb-x-face-cache))))
1816          (marker (point-marker))
1817          buffer
1818          process)
1819     (if cached
1820         (lsdb-insert-x-face-image cached type marker)
1821       (with-current-buffer (setq buffer (generate-new-buffer " *lsdb work*"))
1822         (buffer-disable-undo)
1823         (set-buffer-multibyte nil))
1824       (setq process
1825             (start-process-shell-command
1826              "lsdb-x-face-command" buffer
1827              (concat "{ "
1828                      (apply #'concat
1829                             (lsdb-substitute-variables
1830                              (cdr (assq type lsdb-x-face-command-alist))
1831                              'scale-factor
1832                              (number-to-string lsdb-x-face-scale-factor)))
1833                      "; } 2> /dev/null")))
1834       (set-process-filter
1835        process
1836        `(lambda (process string)
1837           (save-excursion
1838             (set-buffer ,buffer)
1839             (goto-char (point-max))
1840             (insert string))))
1841       (set-process-sentinel
1842        process
1843        `(lambda (process string)
1844           (unwind-protect
1845               (if (equal string "finished\n")
1846                   (let ((data
1847                          (with-current-buffer ,buffer
1848                            (buffer-string))))
1849                     (lsdb-insert-x-face-image data ',type ,marker)
1850                     (lsdb-puthash ,x-face (list (cons ',type data))
1851                                   lsdb-x-face-cache)))
1852             (kill-buffer ,buffer))))
1853       (process-send-string process (concat x-face "\n"))
1854       (process-send-eof process))))
1855
1856 ;;;_. Face Rendering
1857 (defvar lsdb-face-cache
1858   (lsdb-make-hash-table :test 'equal))
1859
1860 (defun lsdb-face-available-image-type ()
1861   (static-if (featurep 'xemacs)
1862       (if (featurep 'png)
1863           'png
1864         (if (featurep 'xpm)
1865             'xpm))
1866     (and (>= emacs-major-version 21)
1867          (fboundp 'image-type-available-p)
1868          (if (image-type-available-p 'png)
1869              'png
1870            (if (image-type-available-p 'xpm)
1871                'xpm)))))
1872
1873 (defun lsdb-expose-face ()
1874   (let* ((record (get-text-property (point-min) 'lsdb-record))
1875          (face (cdr (assq 'face (cdr record))))
1876          (delimiter "\r "))
1877     (when (and lsdb-insert-face-function
1878                face)
1879       (goto-char (point-min))
1880       (end-of-line)
1881       (put-text-property 0 1 'invisible t delimiter) ;hide "\r"
1882       (put-text-property
1883        (point)
1884        (progn
1885          (insert delimiter)
1886          (while face
1887            (funcall lsdb-insert-face-function (pop face)))
1888          (point))
1889        'lsdb-record record))))
1890
1891 (defun lsdb-insert-face-image (data type marker)
1892   (static-if (featurep 'xemacs)
1893       (save-excursion
1894         (set-buffer (marker-buffer marker))
1895         (goto-char marker)
1896         (let* ((inhibit-read-only t)
1897                buffer-read-only
1898                (glyph (make-glyph (vector type :data data))))
1899           (set-extent-begin-glyph
1900            (make-extent (point) (point))
1901            glyph)))
1902     (save-excursion
1903       (set-buffer (marker-buffer marker))
1904       (goto-char marker)
1905       (let* ((inhibit-read-only t)
1906              buffer-read-only
1907              (image (create-image data type t :ascent 'center))
1908              (record (get-text-property (point) 'lsdb-record)))
1909         (put-text-property (point) (progn
1910                                      (insert-image image)
1911                                      (point))
1912                            'lsdb-record record)))))
1913
1914 (defun lsdb-insert-face-asynchronously (face)
1915   (let* ((type (or lsdb-face-image-type
1916                    (lsdb-face-available-image-type)))
1917          (shell-file-name lsdb-shell-file-name)
1918          (shell-command-switch lsdb-shell-command-switch)
1919          (coding-system-for-read 'binary)
1920          (coding-system-for-write 'binary)
1921          (process-connection-type nil)
1922          (cached (cdr (assq type (lsdb-gethash face lsdb-face-cache))))
1923          (marker (point-marker))
1924          buffer
1925          process)
1926     (if cached
1927         (lsdb-insert-face-image cached type marker)
1928       (with-current-buffer (setq buffer (generate-new-buffer " *lsdb work*"))
1929         (buffer-disable-undo)
1930         (set-buffer-multibyte nil))
1931       (setq process
1932             (start-process-shell-command
1933              "lsdb-face-command" buffer
1934              (concat "{ "
1935                      (apply #'concat
1936                             (lsdb-substitute-variables
1937                              (cdr (assq type lsdb-face-command-alist))
1938                              'scale-factor
1939                              (number-to-string lsdb-face-scale-factor)))
1940                      "; } 2> /dev/null")))
1941       (set-process-filter
1942        process
1943        `(lambda (process string)
1944           (save-excursion
1945             (set-buffer ,buffer)
1946             (goto-char (point-max))
1947             (insert string))))
1948       (set-process-sentinel
1949        process
1950        `(lambda (process string)
1951           (unwind-protect
1952               (if (equal string "finished\n")
1953                   (let ((data
1954                          (with-current-buffer ,buffer
1955                            (buffer-string))))
1956                     (lsdb-insert-face-image data ',type ,marker)
1957                     (lsdb-puthash ,face (list (cons ',type data))
1958                                   lsdb-face-cache)))
1959             (kill-buffer ,buffer))))
1960       (process-send-string process (base64-decode-string face))
1961       (process-send-eof process))))
1962
1963 (require 'product)
1964 (provide 'lsdb)
1965
1966 (product-provide 'lsdb
1967   (product-define "LSDB" nil '(0 11)))
1968
1969 ;;;_* Local emacs vars.
1970 ;;; The following `allout-layout' local variable setting:
1971 ;;;  - closes all topics from the first topic to just before the third-to-last,
1972 ;;;  - shows the children of the third to last (config vars)
1973 ;;;  - and the second to last (code section),
1974 ;;;  - and closes the last topic (this local-variables section).
1975 ;;;Local variables:
1976 ;;;allout-layout: (0 : -1 -1 0)
1977 ;;;End:
1978
1979 ;;; lsdb.el ends here