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 (")
 506   (lsdb-maphash
 507    (lambda (key value)
 508      (let (print-level print-length)
 509        (insert (prin1-to-string key) " " (prin1-to-string value) " ")))
 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 dont-ask)
1310   "Save LSDB hash table into `lsdb-file'."
1311   (interactive (list t))
1312   (if (not lsdb-hash-tables-are-dirty)
1313       (message "(No changes need to be saved)")
1314     (when (or dont-ask
1315               (not lsdb-verbose)
1316               (y-or-n-p "Save the LSDB now? "))
1317       (lsdb-save-hash-tables)
1318       (set-buffer-modified-p (setq lsdb-hash-tables-are-dirty nil))
1319       (message "The LSDB was saved successfully."))))
1320
1321 (defun lsdb-mode-load ()
1322   "Load LSDB hash table from `lsdb-file'."
1323   (interactive)
1324   (let (lsdb-secondary-hash-tables)
1325     (lsdb-load-hash-tables))
1326   (message "Rebuilding secondary hash tables...")
1327   (lsdb-rebuild-secondary-hash-tables t)
1328   (message "Rebuilding secondary hash tables...done"))
1329
1330 (defun lsdb-mode-quit-window (&optional kill window)
1331   "Quit the current buffer.
1332 It partially emulates the GNU Emacs' of `quit-window'."
1333   (interactive "P")
1334   (unless window
1335     (setq window (selected-window)))
1336   (let ((buffer (window-buffer window)))
1337     (unless (save-selected-window
1338               (select-window window)
1339               (one-window-p))
1340       (delete-window window))
1341     (if kill
1342         (kill-buffer buffer)
1343       (bury-buffer (unless (eq buffer (current-buffer)) buffer)))))
1344
1345 (defun lsdb-hide-buffer ()
1346   "Hide the LSDB window."
1347   (let ((window (get-buffer-window lsdb-buffer-name)))
1348     (if window
1349         (lsdb-mode-quit-window nil window))))
1350
1351 (defun lsdb-show-buffer ()
1352   "Show the LSDB window."
1353   (if (get-buffer lsdb-buffer-name)
1354       (if lsdb-temp-buffer-show-function
1355           (let ((lsdb-pop-up-windows t))
1356             (funcall lsdb-temp-buffer-show-function lsdb-buffer-name))
1357         (pop-to-buffer lsdb-buffer-name))))
1358
1359 (defun lsdb-toggle-buffer (&optional arg)
1360   "Toggle hiding of the LSDB window.
1361 If given a negative prefix, always show; if given a positive prefix,
1362 always hide."
1363   (interactive
1364    (list (if current-prefix-arg
1365              (prefix-numeric-value current-prefix-arg)
1366            0)))
1367   (unless arg                           ;called noninteractively?
1368     (setq arg 0))
1369   (cond
1370    ((or (< arg 0)
1371         (and (zerop arg)
1372              (not (get-buffer-window lsdb-buffer-name))))
1373     (lsdb-show-buffer))
1374    ((or (> arg 0)
1375         (and (zerop arg)
1376              (get-buffer-window lsdb-buffer-name)))
1377     (lsdb-hide-buffer))))
1378
1379 (defun lsdb-lookup-records (regexp &optional entry-name)
1380   "Return the all records in the LSDB matching the REGEXP.
1381 If the optional 2nd argument ENTRY-NAME is given, matching only
1382 performed against the entry field."
1383   (let (records)
1384     (lsdb-maphash
1385      (if entry-name
1386          (progn
1387            (lambda (key value)
1388              (let ((entry (cdr (assq entry-name value)))
1389                    found)
1390                (unless (listp entry)
1391                  (setq entry (list entry)))
1392                (while (and (not found) entry)
1393                  (if (string-match regexp (pop entry))
1394                      (setq found t)))
1395                (if found
1396                    (push (cons key value) records)))))
1397        (lambda (key value)
1398          (if (string-match regexp key)
1399              (push (cons key value) records))))
1400      lsdb-hash-table)
1401     records))
1402
1403 (defvar lsdb-mode-lookup-history nil)
1404
1405 (defun lsdb-mode-lookup (regexp &optional entry-name)
1406   "Display the all records in the LSDB matching the REGEXP.
1407 If the optional 2nd argument ENTRY-NAME is given, matching only
1408 performed against the entry field."
1409   (interactive
1410    (let* ((completion-ignore-case t)
1411           (entry-name
1412            (if current-prefix-arg
1413                (completing-read "Entry name: "
1414                                 lsdb-known-entry-names))))
1415      (list
1416       (read-from-minibuffer
1417        (if entry-name
1418            (format "Search records `%s' regexp: " entry-name)
1419          "Search records regexp: ")
1420        nil nil nil 'lsdb-mode-lookup-history)
1421       (if (and entry-name (not (equal entry-name "")))
1422           (intern (downcase entry-name))))))
1423   (lsdb-maybe-load-hash-tables)
1424   (let ((records (lsdb-lookup-records regexp entry-name)))
1425     (if records
1426         (lsdb-display-records records))))
1427
1428 ;;;###autoload
1429 (defalias 'lsdb 'lsdb-mode-lookup)
1430
1431 (defun lsdb-mode-next-record (&optional arg)
1432   "Go to the next record."
1433   (interactive "p")
1434   (unless arg                           ;called noninteractively?
1435     (setq arg 1))
1436   (if (< arg 0)
1437       (lsdb-mode-previous-record (- arg))
1438     (while (> arg 0)
1439       (goto-char (next-single-property-change
1440                   (point) 'lsdb-record nil (point-max)))
1441       (setq arg (1- arg)))))
1442
1443 (defun lsdb-mode-previous-record (&optional arg)
1444   "Go to the previous record."
1445   (interactive "p")
1446   (unless arg                           ;called noninteractively?
1447     (setq arg 1))
1448   (if (< arg 0)
1449       (lsdb-mode-next-record (- arg))
1450     (while (> arg 0)
1451       (goto-char (previous-single-property-change
1452                   (point) 'lsdb-record nil (point-min)))
1453       (setq arg (1- arg)))))
1454
1455 ;;;_ : Edit Forms -- stolen (and renamed) from gnus-eform.el
1456 (defvar lsdb-edit-form-buffer "*LSDB edit form*")
1457 (defvar lsdb-edit-form-done-function nil)
1458 (defvar lsdb-previous-window-configuration nil)
1459
1460 (defvar lsdb-edit-form-mode-map
1461   (let ((keymap (make-sparse-keymap)))
1462     (set-keymap-parent keymap emacs-lisp-mode-map)
1463     (define-key keymap "\C-c\C-c" 'lsdb-edit-form-done)
1464     (define-key keymap "\C-c\C-k" 'lsdb-edit-form-exit)
1465     keymap)
1466   "Edit form's keymap.")
1467
1468 (defun lsdb-edit-form-mode ()
1469   "Major mode for editing forms.
1470 It is a slightly enhanced emacs-lisp-mode.
1471
1472 \\{lsdb-edit-form-mode-map}"
1473   (interactive)
1474   (kill-all-local-variables)
1475   (setq major-mode 'lsdb-edit-form-mode
1476         mode-name "LSDB Edit Form")
1477   (use-local-map lsdb-edit-form-mode-map)
1478   (make-local-variable 'lsdb-edit-form-done-function)
1479   (make-local-variable 'lsdb-previous-window-configuration)
1480   (run-hooks 'lsdb-edit-form-mode-hook))
1481
1482 (defun lsdb-edit-form (form documentation exit-func)
1483   "Edit FORM in a new buffer.
1484 Call EXIT-FUNC on exit.  Display DOCUMENTATION in the beginning
1485 of the buffer."
1486   (let ((window-configuration
1487          (current-window-configuration)))
1488     (switch-to-buffer (get-buffer-create lsdb-edit-form-buffer))
1489     (lsdb-edit-form-mode)
1490     (setq lsdb-previous-window-configuration window-configuration
1491           lsdb-edit-form-done-function exit-func)
1492     (erase-buffer)
1493     (insert documentation)
1494     (unless (bolp)
1495       (insert "\n"))
1496     (goto-char (point-min))
1497     (while (not (eobp))
1498       (insert ";;; ")
1499       (forward-line 1))
1500     (insert ";; Type `C-c C-c' after you've finished editing.\n")
1501     (insert "\n")
1502     (let ((p (point)))
1503       (pp form (current-buffer))
1504       (insert "\n")
1505       (goto-char p))))
1506
1507 (defun lsdb-edit-form-done ()
1508   "Update changes and kill the current buffer."
1509   (interactive)
1510   (goto-char (point-min))
1511   (let ((form (condition-case nil
1512                   (read (current-buffer))
1513                 (end-of-file nil)))
1514         (func lsdb-edit-form-done-function))
1515     (lsdb-edit-form-exit)
1516     (funcall func form)))
1517
1518 (defun lsdb-edit-form-exit ()
1519   "Kill the current buffer."
1520   (interactive)
1521   (let ((window-configuration lsdb-previous-window-configuration))
1522     (kill-buffer (current-buffer))
1523     (set-window-configuration window-configuration)))
1524
1525 ;;;_. Interface to Semi-gnus
1526 ;;;###autoload
1527 (defun lsdb-gnus-insinuate ()
1528   "Call this function to hook LSDB into Semi-gnus."
1529   (add-hook 'gnus-article-prepare-hook 'lsdb-gnus-update-record)
1530   (add-hook 'gnus-save-newsrc-hook 'lsdb-mode-save))
1531
1532 (defvar gnus-article-current-summary)
1533 (defvar gnus-original-article-buffer)
1534 (defun lsdb-gnus-update-record ()
1535   (with-current-buffer (with-current-buffer gnus-article-current-summary
1536                          gnus-original-article-buffer)
1537     (lsdb-update-records-and-display)))
1538
1539 ;;;_. Interface to Wanderlust
1540 ;;;###autoload
1541 (defun lsdb-wl-insinuate ()
1542   "Call this function to hook LSDB into Wanderlust."
1543   (add-hook 'wl-message-redisplay-hook 'lsdb-wl-update-record)
1544   (add-hook 'wl-summary-exit-hook 'lsdb-hide-buffer)
1545   (add-hook 'wl-summary-toggle-disp-off-hook 'lsdb-hide-buffer)
1546   (add-hook 'wl-summary-toggle-disp-folder-on-hook 'lsdb-hide-buffer)
1547   (add-hook 'wl-summary-toggle-disp-folder-off-hook 'lsdb-hide-buffer)
1548   (add-hook 'wl-summary-toggle-disp-folder-message-resumed-hook
1549             'lsdb-wl-show-buffer)
1550   (add-hook 'wl-exit-hook 'lsdb-mode-save)
1551   (add-hook 'wl-save-hook 'lsdb-mode-save))
1552
1553 (eval-when-compile
1554   (autoload 'wl-message-get-original-buffer "wl-message"))
1555 (defun lsdb-wl-update-record ()
1556   (save-excursion
1557     (set-buffer (wl-message-get-original-buffer))
1558     (let ((lsdb-temp-buffer-show-function
1559            #'lsdb-wl-temp-buffer-show-function))
1560       (lsdb-update-records-and-display))))
1561
1562 (defun lsdb-wl-toggle-buffer (&optional arg)
1563   "Toggle hiding of the LSDB window for Wanderlust.
1564 If given a negative prefix, always show; if given a positive prefix,
1565 always hide."
1566   (interactive
1567    (list (if current-prefix-arg
1568              (prefix-numeric-value current-prefix-arg)
1569            0)))
1570   (let ((lsdb-temp-buffer-show-function
1571          #'lsdb-wl-temp-buffer-show-function))
1572     (lsdb-toggle-buffer arg)))
1573
1574 (defun lsdb-wl-show-buffer ()
1575   (when lsdb-pop-up-windows
1576     (let ((lsdb-temp-buffer-show-function
1577            #'lsdb-wl-temp-buffer-show-function))
1578       (lsdb-show-buffer))))
1579
1580 (defvar wl-current-summary-buffer)
1581 (defvar wl-message-buffer)
1582 (defun lsdb-wl-temp-buffer-show-function (buffer)
1583   (when lsdb-pop-up-windows
1584     (save-selected-window
1585       (let ((window (or (get-buffer-window lsdb-buffer-name)
1586                         (progn
1587                           (select-window
1588                            (or (save-excursion
1589                                  (if (buffer-live-p wl-current-summary-buffer)
1590                                      (set-buffer wl-current-summary-buffer))
1591                                  (get-buffer-window wl-message-buffer))
1592                                (get-largest-window)))
1593                           (split-window-vertically)))))
1594         (set-window-buffer window buffer)
1595         (lsdb-fit-window-to-buffer window)))))
1596
1597 ;;;_. Interface to Mew written by Hideyuki SHIRAI <shirai@meadowy.org>
1598 (eval-when-compile
1599   (condition-case nil
1600       (progn
1601         (require 'mew)
1602         ;; Avoid macro `mew-cache-hit' expand (Mew 1.94.2 or earlier).
1603         ;; Changed `mew-cache-hit' from macro to function at Mew 2.0.
1604         (if (not (fboundp 'mew-current-get-fld))
1605             (setq byte-compile-macro-environment
1606                   (cons '(mew-cache-hit . nil)
1607                         byte-compile-macro-environment))))
1608     (error
1609      ;; Silence byte compiler for environments where Mew does not installed.
1610      (autoload 'mew-sinfo-get-disp-msg "mew")
1611      (autoload 'mew-current-get-fld "mew")
1612      (autoload 'mew-current-get-msg "mew")
1613      (autoload 'mew-frame-id "mew")
1614      (autoload 'mew-cache-hit "mew")
1615      (autoload 'mew-xinfo-get-decode-err "mew")
1616      (autoload 'mew-xinfo-get-action "mew"))))
1617
1618 ;;;###autoload
1619 (defun lsdb-mew-insinuate ()
1620   "Call this function to hook LSDB into Mew."
1621   (add-hook 'mew-message-hook 'lsdb-mew-update-record)
1622   (add-hook 'mew-summary-toggle-disp-msg-hook
1623             (lambda ()
1624               (unless (mew-sinfo-get-disp-msg)
1625                 (lsdb-hide-buffer))))
1626   (add-hook 'mew-suspend-hook 'lsdb-hide-buffer)
1627   (add-hook 'mew-quit-hook 'lsdb-mode-save)
1628   (add-hook 'kill-emacs-hook 'lsdb-mode-save)
1629   (cond
1630    ;; Mew 3
1631    ((fboundp 'mew-summary-visit-folder)
1632     (defadvice mew-summary-visit-folder (before lsdb-hide-buffer activate)
1633       (lsdb-hide-buffer)))
1634    ;; Mew 2
1635    ((fboundp 'mew-summary-switch-to-folder)
1636     (defadvice mew-summary-switch-to-folder (before lsdb-hide-buffer activate)
1637       (lsdb-hide-buffer)))))
1638
1639 (defun lsdb-mew-update-record ()
1640   (let* ((fld (mew-current-get-fld (mew-frame-id)))
1641          (msg (mew-current-get-msg (mew-frame-id)))
1642          (cache (mew-cache-hit fld msg)))
1643     (when cache
1644       (save-excursion
1645         (set-buffer cache)
1646         (unless (or (mew-xinfo-get-decode-err) (mew-xinfo-get-action))
1647           (make-local-variable 'lsdb-decode-field-body-function)
1648           (setq lsdb-decode-field-body-function
1649                 (lambda (body name)
1650                   (set-text-properties 0 (length body) nil body)
1651                   body))
1652           (lsdb-update-records-and-display))))))
1653
1654 ;;;_. Interface to MU-CITE
1655 (eval-when-compile
1656   (autoload 'mu-cite-get-value "mu-cite"))
1657
1658 (defun lsdb-mu-attribution (address)
1659   "Extract attribute information from LSDB."
1660   (let ((records
1661          (lsdb-lookup-records (concat "\\<" address "\\>") 'net)))
1662     (if records
1663         (cdr (assq 'attribution (cdr (car records)))))))
1664
1665 (defun lsdb-mu-set-attribution (attribution address)
1666   "Add attribute information to LSDB."
1667   (let ((records
1668          (lsdb-lookup-records (concat "\\<" address "\\>") 'net))
1669         entry)
1670     (when records
1671       (setq entry (assq 'attribution (cdr (car records))))
1672       (if entry
1673           (setcdr entry attribution)
1674         (setcdr (car records) (cons (cons 'attribution attribution)
1675                                     (cdr (car records))))
1676         (lsdb-puthash (car (car records)) (cdr (car records))
1677                       lsdb-hash-table)
1678         (run-hook-with-args 'lsdb-after-update-record-functions (car records))
1679         (setq lsdb-hash-tables-are-dirty t)))))
1680
1681 (defun lsdb-mu-get-prefix-method ()
1682   "A mu-cite method to return a prefix from LSDB or \">\".
1683 If an `attribution' value is found in LSDB, the value is returned.
1684 Otherwise \">\" is returned."
1685   (or (lsdb-mu-attribution (mu-cite-get-value 'address))
1686       ">"))
1687
1688 (defvar minibuffer-allow-text-properties)
1689
1690 (defvar lsdb-mu-history nil)
1691
1692 (defun lsdb-mu-get-prefix-register-method ()
1693   "A mu-cite method to return a prefix from LSDB or register it.
1694 If an `attribution' value is found in LSDB, the value is returned.
1695 Otherwise the function requests a prefix from a user.  The prefix will
1696 be registered to LSDB if the user wants it."
1697   (let ((address (mu-cite-get-value 'address)))
1698     (or (lsdb-mu-attribution address)
1699         (let* (minibuffer-allow-text-properties
1700                (result (read-string "Citation name? "
1701                                     (or (mu-cite-get-value 'x-attribution)
1702                                         (mu-cite-get-value 'full-name))
1703                                     'lsdb-mu-history)))
1704           (if (and (not (string-equal result ""))
1705                    (y-or-n-p (format "Register \"%s\"? " result)))
1706               (lsdb-mu-set-attribution result address))
1707           result))))
1708
1709 (defun lsdb-mu-get-prefix-register-verbose-method ()
1710   "A mu-cite method to return a prefix using LSDB.
1711
1712 In this method, a user must specify a prefix unconditionally.  If an
1713 `attribution' value is found in LSDB, the value is used as a initial
1714 value to input the prefix.  The prefix will be registered to LSDB if
1715 the user wants it."
1716   (let* ((address (mu-cite-get-value 'address))
1717          (attribution (lsdb-mu-attribution address))
1718          minibuffer-allow-text-properties
1719          (result (read-string "Citation name? "
1720                               (or attribution
1721                                   (mu-cite-get-value 'x-attribution)
1722                                   (mu-cite-get-value 'full-name))
1723                               'lsdb-mu-history)))
1724     (if (and (not (string-equal result ""))
1725              (not (string-equal result attribution))
1726              (y-or-n-p (format "Register \"%s\"? " result)))
1727         (lsdb-mu-set-attribution result address))
1728     result))
1729
1730 (defvar mu-cite-methods-alist)
1731 ;;;###autoload
1732 (defun lsdb-mu-insinuate ()
1733   (add-hook 'mu-cite-instantiation-hook
1734             (lambda ()
1735               (setq mu-cite-methods-alist
1736                     (nconc
1737                      mu-cite-methods-alist
1738                      (list
1739                       (cons 'lsdb-prefix
1740                             #'lsdb-mu-get-prefix-method)
1741                       (cons 'lsdb-prefix-register
1742                             #'lsdb-mu-get-prefix-register-method)
1743                       (cons 'lsdb-prefix-register-verbose
1744                             #'lsdb-mu-get-prefix-register-verbose-method)))))))
1745
1746 ;;;_. X-Face Rendering
1747 (defvar lsdb-x-face-cache
1748   (lsdb-make-hash-table :test 'equal))
1749
1750 (defun lsdb-x-face-available-image-type ()
1751   (static-if (featurep 'xemacs)
1752       (if (featurep 'xpm)
1753           'xpm)
1754     (and (>= emacs-major-version 21)
1755          (fboundp 'image-type-available-p)
1756          (if (image-type-available-p 'pbm)
1757              'pbm
1758            (if (image-type-available-p 'xpm)
1759                'xpm)))))
1760
1761 (defun lsdb-expose-x-face ()
1762   (let* ((record (get-text-property (point-min) 'lsdb-record))
1763          (x-face (cdr (assq 'x-face (cdr record))))
1764          (delimiter "\r "))
1765     (when (and lsdb-insert-x-face-function
1766                x-face)
1767       (goto-char (point-min))
1768       (end-of-line)
1769       (put-text-property 0 1 'invisible t delimiter) ;hide "\r"
1770       (put-text-property
1771        (point)
1772        (progn
1773          (insert delimiter)
1774          (while x-face
1775            (funcall lsdb-insert-x-face-function (pop x-face)))
1776          (point))
1777        'lsdb-record record))))
1778
1779 (defun lsdb-insert-x-face-image (data type marker)
1780   (static-if (featurep 'xemacs)
1781       (save-excursion
1782         (set-buffer (marker-buffer marker))
1783         (goto-char marker)
1784         (let* ((inhibit-read-only t)
1785                buffer-read-only
1786                (glyph (make-glyph (vector type :data data))))
1787           (set-extent-begin-glyph
1788            (make-extent (point) (point))
1789            glyph)))
1790     (save-excursion
1791       (set-buffer (marker-buffer marker))
1792       (goto-char marker)
1793       (let* ((inhibit-read-only t)
1794              buffer-read-only
1795              (image (create-image data type t :ascent 'center))
1796              (record (get-text-property (point) 'lsdb-record)))
1797         (put-text-property (point) (progn
1798                                      (insert-image image)
1799                                      (point))
1800                            'lsdb-record record)))))
1801
1802 (defun lsdb-insert-x-face-asynchronously (x-face)
1803   (let* ((type (or lsdb-x-face-image-type
1804                    (lsdb-x-face-available-image-type)))
1805          (shell-file-name lsdb-shell-file-name)
1806          (shell-command-switch lsdb-shell-command-switch)
1807          (coding-system-for-read 'binary)
1808          (process-connection-type nil)
1809          (cached (cdr (assq type (lsdb-gethash x-face lsdb-x-face-cache))))
1810          (marker (point-marker))
1811          process)
1812     (if cached
1813         (lsdb-insert-x-face-image cached type marker)
1814       (setq process
1815             (start-process-shell-command
1816              "lsdb-x-face-command" (generate-new-buffer " *lsdb work*")
1817              (concat "{ "
1818                      (apply #'concat
1819                             (lsdb-substitute-variables
1820                              (cdr (assq type lsdb-x-face-command-alist))
1821                              'scale-factor
1822                              (number-to-string lsdb-x-face-scale-factor)))
1823                      "; } 2> /dev/null")))
1824       (process-send-string process (concat x-face "\n"))
1825       (process-send-eof process)
1826       (set-process-sentinel
1827        process
1828        `(lambda (process string)
1829           (unwind-protect
1830               (when (and (buffer-live-p (marker-buffer ,marker))
1831                          (equal string "finished\n"))
1832                 (let ((data
1833                        (with-current-buffer (process-buffer process)
1834                          (set-buffer-multibyte nil)
1835                          (buffer-string))))
1836                   (lsdb-insert-x-face-image data ',type ,marker)
1837                   (lsdb-puthash ,x-face (list (cons ',type data))
1838                                 lsdb-x-face-cache)))
1839             (kill-buffer (process-buffer process))))))))
1840
1841 ;;;_. Face Rendering
1842 (defvar lsdb-face-cache
1843   (lsdb-make-hash-table :test 'equal))
1844
1845 (defun lsdb-face-available-image-type ()
1846   (static-if (featurep 'xemacs)
1847       (if (featurep 'png)
1848           'png
1849         (if (featurep 'xpm)
1850             'xpm))
1851     (and (>= emacs-major-version 21)
1852          (fboundp 'image-type-available-p)
1853          (if (image-type-available-p 'png)
1854              'png
1855            (if (image-type-available-p 'xpm)
1856                'xpm)))))
1857
1858 (defun lsdb-expose-face ()
1859   (let* ((record (get-text-property (point-min) 'lsdb-record))
1860          (face (cdr (assq 'face (cdr record))))
1861          (delimiter "\r "))
1862     (when (and lsdb-insert-face-function
1863                face)
1864       (goto-char (point-min))
1865       (end-of-line)
1866       (put-text-property 0 1 'invisible t delimiter) ;hide "\r"
1867       (put-text-property
1868        (point)
1869        (progn
1870          (insert delimiter)
1871          (while face
1872            (funcall lsdb-insert-face-function (pop face)))
1873          (point))
1874        'lsdb-record record))))
1875
1876 (defun lsdb-insert-face-image (data type marker)
1877   (static-if (featurep 'xemacs)
1878       (save-excursion
1879         (set-buffer (marker-buffer marker))
1880         (goto-char marker)
1881         (let* ((inhibit-read-only t)
1882                buffer-read-only
1883                (glyph (make-glyph (vector type :data data))))
1884           (set-extent-begin-glyph
1885            (make-extent (point) (point))
1886            glyph)))
1887     (save-excursion
1888       (set-buffer (marker-buffer marker))
1889       (goto-char marker)
1890       (let* ((inhibit-read-only t)
1891              buffer-read-only
1892              (image (create-image data type t :ascent 'center))
1893              (record (get-text-property (point) 'lsdb-record)))
1894         (put-text-property (point) (progn
1895                                      (insert-image image)
1896                                      (point))
1897                            'lsdb-record record)))))
1898
1899 (defun lsdb-insert-face-asynchronously (face)
1900   (let* ((type (or lsdb-face-image-type
1901                    (lsdb-face-available-image-type)))
1902          (shell-file-name lsdb-shell-file-name)
1903          (shell-command-switch lsdb-shell-command-switch)
1904          (coding-system-for-read 'binary)
1905          (coding-system-for-write 'binary)
1906          (process-connection-type nil)
1907          (cached (cdr (assq type (lsdb-gethash face lsdb-face-cache))))
1908          (marker (point-marker))
1909          process)
1910     (if cached
1911         (lsdb-insert-face-image cached type marker)
1912       (setq process
1913             (start-process-shell-command
1914              "lsdb-face-command" (generate-new-buffer " *lsdb work*")
1915              (concat "{ "
1916                      (apply #'concat
1917                             (lsdb-substitute-variables
1918                              (cdr (assq type lsdb-face-command-alist))
1919                              'scale-factor
1920                              (number-to-string lsdb-face-scale-factor)))
1921                      "; } 2> /dev/null")))
1922       (process-send-string process (base64-decode-string face))
1923       (process-send-eof process)
1924       (set-process-sentinel
1925        process
1926        `(lambda (process string)
1927           (unwind-protect
1928               (when (and (buffer-live-p (marker-buffer ,marker))
1929                          (equal string "finished\n"))
1930                 (let ((data
1931                        (with-current-buffer (process-buffer process)
1932                          (set-buffer-multibyte nil)
1933                          (buffer-string))))
1934                   (lsdb-insert-face-image data ',type ,marker)
1935                   (lsdb-puthash ,face (list (cons ',type data))
1936                                 lsdb-face-cache)))
1937             (kill-buffer (process-buffer process))))))))
1938
1939 (require 'product)
1940 (provide 'lsdb)
1941
1942 (product-provide 'lsdb
1943   (product-define "LSDB" nil '(0 11)))
1944
1945 ;;;_* Local emacs vars.
1946 ;;; The following `allout-layout' local variable setting:
1947 ;;;  - closes all topics from the first topic to just before the third-to-last,
1948 ;;;  - shows the children of the third to last (config vars)
1949 ;;;  - and the second to last (code section),
1950 ;;;  - and closes the last topic (this local-variables section).
1951 ;;;Local variables:
1952 ;;;allout-layout: (0 : -1 -1 0)
1953 ;;;End:
1954
1955 ;;; lsdb.el ends here