lsdb.el

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