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