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               ;; reduce the actual size of the close hash table
 342               (number-to-string (lsdb-hash-table-count hash-table))
 343               " test equal data (")
 344       (lsdb-maphash
 345        (lambda (key value)
 346          (insert (prin1-to-string key) " " (prin1-to-string value) " "))
 347        hash-table)
 348       (insert "))"))))
 349
 350 ;;;_. Mail Header Extraction
 351 (defun lsdb-fetch-field-bodies (regexp)
 352   (save-excursion
 353     (goto-char (point-min))
 354     (let ((case-fold-search t)
 355           field-bodies)
 356       (while (re-search-forward (concat "^\\(" regexp "\\):[ \t]*")
 357                                 nil t)
 358         (push (funcall lsdb-decode-field-body-function
 359                              (buffer-substring (point) (std11-field-end))
 360                              (match-string 1))
 361                     field-bodies))
 362       (nreverse field-bodies))))
 363
 364 (defun lsdb-canonicalize-spaces-and-dots (string)
 365   (while (string-match "  +\\|[\f\t\n\r\v]+\\|\\." string)
 366     (setq string (replace-match " " nil t string)))
 367   string)
 368
 369 (defun lsdb-extract-address-components (string)
 370   (let ((components (std11-extract-address-components string)))
 371     (if (nth 1 components)
 372         (if (car components)
 373             (list (nth 1 components)
 374                   (funcall lsdb-canonicalize-full-name-function
 375                            (car components)))
 376           (list (nth 1 components) (nth 1 components))))))
 377
 378 ;; stolen (and renamed) from nnheader.el
 379 (defun lsdb-decode-field-body (field-body field-name
 380                                           &optional mode max-column)
 381   (let ((multibyte enable-multibyte-characters))
 382     (unwind-protect
 383         (progn
 384           (set-buffer-multibyte t)
 385           (mime-decode-field-body field-body
 386                                   (if (stringp field-name)
 387                                       (intern (capitalize field-name))
 388                                     field-name)
 389                                   mode max-column))
 390       (set-buffer-multibyte multibyte))))
 391
 392 ;;;_. Record Management
 393 (defun lsdb-maybe-load-file ()
 394   (unless lsdb-hash-table
 395     (if (file-exists-p lsdb-file)
 396         (setq lsdb-hash-table (lsdb-load-file lsdb-file))
 397       (setq lsdb-hash-table (lsdb-make-hash-table :test 'equal)))))
 398
 399 (defun lsdb-update-record (sender &optional interesting)
 400   (let ((old (lsdb-gethash (nth 1 sender) lsdb-hash-table))
 401         (new (cons (cons 'net (list (car sender)))
 402                    interesting))
 403         merged
 404         record)
 405     (unless old
 406       (setq new (cons (cons 'creation-date (format-time-string "%Y-%m-%d"))
 407                       new)))
 408     (setq merged (lsdb-merge-record-entries old new)
 409           record (cons (nth 1 sender) merged))
 410     (unless (equal merged old)
 411       (let ((entry (assq 'last-modified (cdr record)))
 412             (last-modified (format-time-string "%Y-%m-%d")))
 413         (if entry
 414             (setcdr entry last-modified)
 415           (setcdr record (cons (cons 'last-modified last-modified)
 416                                (cdr record)))))
 417       (lsdb-puthash (car record) (cdr record)
 418                     lsdb-hash-table)
 419       (setq lsdb-hash-table-is-dirty t))
 420     record))
 421
 422 (defun lsdb-update-records ()
 423   (lsdb-maybe-load-file)
 424   (let (senders recipients interesting alist records bodies entry)
 425     (save-restriction
 426       (std11-narrow-to-header)
 427       (setq senders
 428             (delq nil (mapcar #'lsdb-extract-address-components
 429                               (lsdb-fetch-field-bodies
 430                                lsdb-sender-headers)))
 431             recipients
 432             (delq nil (mapcar #'lsdb-extract-address-components
 433                               (lsdb-fetch-field-bodies
 434                                lsdb-recipients-headers))))
 435       (setq alist lsdb-interesting-header-alist)
 436       (while alist
 437         (setq bodies
 438               (mapcar
 439                (lambda (field-body)
 440                  (if (and (nth 1 (car alist))
 441                           (string-match (nth 1 (car alist)) field-body))
 442                      (replace-match (nth 3 (car alist)) nil nil field-body)
 443                    field-body))
 444                (lsdb-fetch-field-bodies (car (car alist)))))
 445         (when bodies
 446           (setq entry (or (nth 2 (car alist))
 447                           'notes))
 448           (push (cons entry
 449                       (if (eq ?. (nth 2 (assq entry lsdb-entry-type-alist)))
 450                           (car bodies)
 451                         bodies))
 452                 interesting))
 453         (setq alist (cdr alist))))
 454     (if senders
 455         (setq records (list (lsdb-update-record (pop senders) interesting))))
 456     (setq alist (nconc senders recipients))
 457     (while alist
 458       (setq records (cons (lsdb-update-record (pop alist)) records)))
 459     (nreverse records)))
 460
 461 (defun lsdb-merge-record-entries (old new)
 462   (setq old (copy-sequence old))
 463   (while new
 464     (let ((entry (assq (car (car new)) old))
 465           list pointer)
 466       (if (null entry)
 467           (setq old (nconc old (list (car new))))
 468         (if (listp (cdr entry))
 469             (progn
 470               (setq list (cdr (car new)) pointer list)
 471               (while pointer
 472                 (if (member (car pointer) (cdr entry))
 473                     (setq list (delq (car pointer) list)))
 474                 (setq pointer (cdr pointer)))
 475               (setcdr entry (nconc (cdr entry) list)))
 476           (setcdr entry (cdr (car new))))))
 477     (setq new (cdr new)))
 478   old)
 479
 480 ;;;_. Display Management
 481 (defun lsdb-temp-buffer-show-function (buffer)
 482   (save-selected-window
 483     (let ((window (or (get-buffer-window lsdb-buffer-name)
 484                       (progn
 485                         (select-window (get-largest-window))
 486                         (split-window-vertically))))
 487           height)
 488       (set-window-buffer window buffer)
 489       (select-window window)
 490       (unless (pos-visible-in-window-p (point-max))
 491         (enlarge-window (- lsdb-window-max-height (window-height))))
 492       (shrink-window-if-larger-than-buffer)
 493       (if (> (setq height (window-height))
 494              lsdb-window-max-height)
 495           (shrink-window (- height lsdb-window-max-height)))
 496       (set-window-start window (point-min)))))
 497
 498 (defun lsdb-display-record (record)
 499   "Display only one RECORD, then shrink the window as possible."
 500   (let ((temp-buffer-show-function
 501          (function lsdb-temp-buffer-show-function)))
 502     (lsdb-display-records (list record))))
 503
 504 (defun lsdb-display-records (records)
 505   (with-output-to-temp-buffer lsdb-buffer-name
 506     (set-buffer standard-output)
 507     (setq records
 508           (sort (copy-sequence records)
 509                 (or lsdb-display-records-sort-predicate
 510                     (lambda (record1 record2)
 511                       (string-lessp (car record1) (car record2))))))
 512     (while records
 513       (save-restriction
 514         (narrow-to-region (point) (point))
 515         (lsdb-print-record (car records)))
 516       (goto-char (point-max))
 517       (setq records (cdr records)))
 518     (lsdb-mode)))
 519
 520 (defsubst lsdb-entry-score (entry)
 521   (or (nth 1 (assq (car entry) lsdb-entry-type-alist)) 0))
 522
 523 (defun lsdb-insert-entry (entry)
 524   (let ((entry-name (capitalize (symbol-name (car entry)))))
 525     (intern entry-name lsdb-known-entry-names)
 526     (if (>= (lsdb-entry-score entry) 0)
 527         (insert "\t" entry-name ": "
 528                 (if (listp (cdr entry))
 529                     (mapconcat
 530                      #'identity (cdr entry)
 531                      (if (eq ?, (nth 2 (assq (car entry)
 532                                              lsdb-entry-type-alist)))
 533                          ", "
 534                        "\n\t\t"))
 535                   (cdr entry))
 536                 "\n"))))
 537
 538 (defun lsdb-print-record (record)
 539   (insert (car record) "\n")
 540   (let ((entries
 541          (sort (copy-sequence (cdr record))
 542                (lambda (entry1 entry2)
 543                  (> (lsdb-entry-score entry1) (lsdb-entry-score entry2))))))
 544     (while entries
 545       (lsdb-insert-entry (car entries))
 546       (setq entries (cdr entries))))
 547   (add-text-properties (point-min) (point-max)
 548                        (list 'lsdb-record record))
 549   (run-hooks 'lsdb-print-record-hook))
 550
 551 ;;;_. Completion
 552 (defvar lsdb-last-completion nil)
 553 (defvar lsdb-last-candidates nil)
 554 (defvar lsdb-last-candidates-pointer nil)
 555
 556 (defun lsdb-complete-name ()
 557   "Complete the user full-name or net-address before point"
 558   (interactive)
 559   (lsdb-maybe-load-file)
 560   (let* ((start
 561           (save-excursion
 562             (re-search-backward "\\(\\`\\|[\n:,]\\)[ \t]*")
 563             (goto-char (match-end 0))
 564             (point)))
 565          pattern
 566          (case-fold-search t)
 567          (completion-ignore-case t))
 568     (unless (eq last-command this-command)
 569       (setq lsdb-last-candidates nil
 570             lsdb-last-candidates-pointer nil
 571             lsdb-last-completion (buffer-substring start (point))
 572             pattern (concat "\\<" lsdb-last-completion))
 573       (lsdb-maphash
 574        (lambda (key value)
 575          (let ((net (cdr (assq 'net value))))
 576            (if (string-match pattern key)
 577                (setq lsdb-last-candidates
 578                      (nconc lsdb-last-candidates
 579                             (mapcar (lambda (address)
 580                                       (if (equal key address)
 581                                           key
 582                                         (concat key " <" address ">")))
 583                                     net)))
 584              (while net
 585                (if (string-match pattern (car net))
 586                    (push (car net) lsdb-last-candidates))
 587                (setq net (cdr net))))))
 588        lsdb-hash-table))
 589     (unless lsdb-last-candidates-pointer
 590       (setq lsdb-last-candidates-pointer lsdb-last-candidates))
 591     (when lsdb-last-candidates-pointer
 592       (delete-region start (point))
 593       (insert (pop lsdb-last-candidates-pointer)))))
 594
 595 ;;;_. Major Mode (`lsdb-mode') Implementation
 596 ;;;_ : Modeline Buffer Identification
 597 (defconst lsdb-pointer-xpm
 598   "/* XPM */
 599 static char * lsdb_pointer_xpm[] = {
 600 \"14 14 5 1\",
 601 \"      c None\",
 602 \"+     c #FF9696\",
 603 \"@     c #FF0000\",
 604 \"#     c #FF7575\",
 605 \"$     c #FF5959\",
 606 \"              \",
 607 \"  +++   @@@   \",
 608 \" +++## @@@@@  \",
 609 \" ++### @@@@@  \",
 610 \" +#####@@@@@  \",
 611 \" +###$$@@@@@  \",
 612 \" +###$$@@@@@  \",
 613 \"  ##$$$@@@@   \",
 614 \"   #$$$@@@    \",
 615 \"    $$@@@     \",
 616 \"     $@@      \",
 617 \"      @       \",
 618 \"              \",
 619 \"              \"};")
 620
 621 (static-if (featurep 'xemacs)
 622     (progn
 623       (defvar lsdb-xemacs-modeline-left-extent
 624         (copy-extent modeline-buffer-id-left-extent))
 625
 626       (defvar lsdb-xemacs-modeline-right-extent
 627         (copy-extent modeline-buffer-id-right-extent))
 628
 629       (defun lsdb-modeline-buffer-identification (line)
 630         "Decorate 1st element of `mode-line-buffer-identification' LINE.
 631 Modify whole identification by side effect."
 632         (let ((id (car line)) chopped)
 633           (if (and (stringp id) (string-match "^LSDB:" id))
 634               (progn
 635                 (setq chopped (substring id 0 (match-end 0))
 636                       id (substring id (match-end 0)))
 637                 (nconc
 638                  (list
 639                   (let ((glyph
 640                          (make-glyph
 641                           (nconc
 642                            (if (featurep 'xpm)
 643                                (list (vector 'xpm :data lsdb-pointer-xpm)))
 644                            (list (vector 'string :data chopped))))))
 645                     (set-glyph-face glyph 'modeline-buffer-id)
 646                     (cons lsdb-xemacs-modeline-left-extent glyph))
 647                   (cons lsdb-xemacs-modeline-right-extent id))
 648                  (cdr line)))
 649             line))))
 650   (condition-case nil
 651       (progn
 652         (require 'image)
 653         (defun lsdb-modeline-buffer-identification (line)
 654           "Decorate 1st element of `mode-line-buffer-identification' LINE.
 655 Modify whole identification by side effect."
 656           (let ((id (copy-sequence (car line)))
 657                 (image
 658                  (if (image-type-available-p 'xpm)
 659                      (create-image lsdb-pointer-xpm 'xpm t :ascent 'center))))
 660             (when (and image
 661                        (stringp id) (string-match "^LSDB:" id))
 662               (add-text-properties 0 (length id)
 663                                    (list 'display image
 664                                          'rear-nonsticky (list 'display))
 665                                    id)
 666               (setcar line id))
 667             line)))
 668     (error
 669      (defalias 'lsdb-modeline-buffer-identification 'identity))))
 670
 671 (defvar lsdb-mode-map
 672   (let ((keymap (make-sparse-keymap)))
 673     (define-key keymap "a" 'lsdb-mode-add-entry)
 674     (define-key keymap "d" 'lsdb-mode-delete-entry)
 675     (define-key keymap "e" 'lsdb-mode-edit-entry)
 676     (define-key keymap "s" 'lsdb-mode-save)
 677     (define-key keymap "q" 'lsdb-mode-quit-window)
 678     (define-key keymap "g" 'lsdb-mode-lookup)
 679     (define-key keymap "p" 'lsdb-mode-previous-record)
 680     (define-key keymap "n" 'lsdb-mode-next-record)
 681     (define-key keymap " " 'scroll-up)
 682     (define-key keymap [delete] 'scroll-down)
 683     (define-key keymap "\177" 'scroll-down)
 684     (define-key keymap [backspace] 'scroll-down)
 685     keymap)
 686   "LSDB's keymap.")
 687
 688 (defvar lsdb-modeline-string "")
 689
 690 (define-derived-mode lsdb-mode fundamental-mode "LSDB"
 691   "Major mode for browsing LSDB records."
 692   (setq buffer-read-only t)
 693   (static-if (featurep 'xemacs)
 694       ;; In XEmacs, setting `font-lock-defaults' only affects on
 695       ;; `find-file-hooks'.
 696       (font-lock-set-defaults)
 697     (set (make-local-variable 'font-lock-defaults)
 698          '(lsdb-font-lock-keywords t)))
 699   (make-local-variable 'post-command-hook)
 700   (setq post-command-hook 'lsdb-modeline-update)
 701   (make-local-variable 'lsdb-modeline-string)
 702   (setq mode-line-buffer-identification
 703         (lsdb-modeline-buffer-identification
 704          '("LSDB: " lsdb-modeline-string)))
 705   (lsdb-modeline-update)
 706   (force-mode-line-update))
 707
 708 (defun lsdb-modeline-update ()
 709   (let ((record
 710          (get-text-property (if (eobp) (point-min) (point)) 'lsdb-record))
 711         net)
 712     (if record
 713         (progn
 714           (setq net (car (cdr (assq 'net (cdr record)))))
 715           (if (equal net (car record))
 716               (setq lsdb-modeline-string net)
 717             (setq lsdb-modeline-string (concat (car record) " <" net ">"))))
 718       (setq lsdb-modeline-string ""))))
 719
 720 (defun lsdb-narrow-to-record ()
 721   "Narrow to the current record."
 722   (let ((end (next-single-property-change (point) 'lsdb-record nil
 723                                           (point-max))))
 724     (narrow-to-region
 725      (previous-single-property-change (point) 'lsdb-record nil (point-min))
 726      end)
 727     (goto-char (point-min))))
 728
 729 (defun lsdb-current-record ()
 730   "Return the current record name."
 731   (let ((record (get-text-property (point) 'lsdb-record)))
 732     (unless record
 733       (error "There is nothing to follow here"))
 734     record))
 735
 736 (defun lsdb-current-entry ()
 737   "Return the current entry name.
 738 If the point is not on a entry line, it prompts to select a entry in
 739 the current record."
 740   (save-excursion
 741     (beginning-of-line)
 742     (if (looking-at "^[^\t]")
 743         (let ((record (lsdb-current-record))
 744               (completion-ignore-case t))
 745           (completing-read
 746            "Which entry to modify: "
 747            (mapcar (lambda (entry)
 748                      (list (capitalize (symbol-name (car entry)))))
 749                    (cdr record))))
 750       (end-of-line)
 751       (re-search-backward "^\t\\([^\t][^:]+\\):")
 752       (match-string 1))))
 753
 754 (defun lsdb-mode-add-entry (entry-name)
 755   "Add an entry on the current line."
 756   (interactive
 757    (let ((completion-ignore-case t))
 758      (list (completing-read "Entry name: " lsdb-known-entry-names))))
 759   (beginning-of-line)
 760   (unless (symbolp entry-name)
 761     (setq entry-name (intern (downcase entry-name))))
 762   (when (assq entry-name (cdr (lsdb-current-record)))
 763     (error "The entry already exists"))
 764   (let ((marker (point-marker)))
 765     (lsdb-edit-form
 766      nil "Editing the entry."
 767      `(lambda (form)
 768         (when form
 769           (save-excursion
 770             (set-buffer lsdb-buffer-name)
 771             (goto-char ,marker)
 772             (let ((record (lsdb-current-record))
 773                   (inhibit-read-only t)
 774                   buffer-read-only)
 775               (setcdr record (cons (cons ',entry-name form) (cdr record)))
 776               (lsdb-puthash (car record) (cdr record)
 777                             lsdb-hash-table)
 778               (setq lsdb-hash-table-is-dirty t)
 779               (beginning-of-line 2)
 780               (add-text-properties
 781                (point)
 782                (progn
 783                  (lsdb-insert-entry (cons ',entry-name form))
 784                  (point))
 785                (list 'lsdb-record record)))))))))
 786
 787 (defun lsdb-mode-delete-entry (&optional entry-name dont-update)
 788   "Delete the entry on the current line."
 789   (interactive)
 790   (let ((record (lsdb-current-record))
 791         entry)
 792     (or entry-name
 793         (setq entry-name (lsdb-current-entry)))
 794     (setq entry (assq (intern (downcase entry-name)) (cdr record)))
 795     (when (and entry
 796                (not dont-update))
 797       (setcdr record (delq entry (cdr record)))
 798       (lsdb-puthash (car record) (cdr record)
 799                     lsdb-hash-table)
 800       (setq lsdb-hash-table-is-dirty t))
 801     (save-restriction
 802       (lsdb-narrow-to-record)
 803       (let ((case-fold-search t)
 804             (inhibit-read-only t)
 805             buffer-read-only)
 806         (goto-char (point-min))
 807         (if (re-search-forward
 808              (concat "^\t" (or entry-name
 809                                (lsdb-current-entry))
 810                      ":")
 811              nil t)
 812             (delete-region (match-beginning 0)
 813                            (if (re-search-forward
 814                                 "^\t[^\t][^:]+:" nil t)
 815                                (match-beginning 0)
 816                              (point-max))))))))
 817
 818 (defun lsdb-mode-edit-entry ()
 819   "Edit the entry on the current line."
 820   (interactive)
 821   (let* ((record (lsdb-current-record))
 822          (entry-name (intern (downcase (lsdb-current-entry))))
 823          (entry (assq entry-name (cdr record)))
 824          (marker (point-marker)))
 825     (lsdb-edit-form
 826      (cdr entry) "Editing the entry."
 827      `(lambda (form)
 828         (unless (equal form ',(cdr entry))
 829           (save-excursion
 830             (set-buffer lsdb-buffer-name)
 831             (goto-char ,marker)
 832             (let* ((record (lsdb-current-record))
 833                    (entry (assq ',entry-name (cdr record)))
 834                    (inhibit-read-only t)
 835                    buffer-read-only)
 836               (setcdr entry form)
 837               (setq lsdb-hash-table-is-dirty t)
 838               (lsdb-mode-delete-entry (symbol-name ',entry-name) t)
 839               (beginning-of-line)
 840               (add-text-properties
 841                (point)
 842                (progn
 843                  (lsdb-insert-entry (cons ',entry-name form))
 844                  (point))
 845                (list 'lsdb-record record)))))))))
 846
 847 (defun lsdb-mode-save (&optional dont-ask)
 848   "Save LSDB hash table into `lsdb-file'."
 849   (interactive)
 850   (if (not lsdb-hash-table-is-dirty)
 851       (message "(No changes need to be saved)")
 852     (when (or (interactive-p)
 853               dont-ask
 854               (y-or-n-p "Save the LSDB now?"))
 855       (lsdb-save-file lsdb-file lsdb-hash-table)
 856       (setq lsdb-hash-table-is-dirty nil)
 857       (message "The LSDB was saved successfully."))))
 858
 859 (defun lsdb-mode-quit-window (&optional kill window)
 860   "Quit the current buffer.
 861 It partially emulates the GNU Emacs' of `quit-window'."
 862   (interactive "P")
 863   (unless window
 864     (setq window (selected-window)))
 865   (let ((buffer (window-buffer window)))
 866     (unless (save-selected-window
 867               (select-window window)
 868               (one-window-p))
 869       (delete-window window))
 870     (if kill
 871         (kill-buffer buffer)
 872       (bury-buffer buffer))))
 873
 874 (defun lsdb-mode-hide-buffer ()
 875   "Hide the LSDB window."
 876   (let ((window (get-buffer-window lsdb-buffer-name)))
 877     (if window
 878         (lsdb-mode-quit-window nil window))))
 879
 880 (defun lsdb-lookup-records (regexp &optional entry-name)
 881   "Return the all records in the LSDB matching the REGEXP.
 882 If the optional 2nd argument ENTRY-NAME is given, matching only
 883 performed against the entry field."
 884   (let (records)
 885     (lsdb-maphash
 886      (if entry-name
 887          (progn
 888            (unless (symbolp entry-name)
 889              (setq entry-name (intern (downcase entry-name))))
 890            (lambda (key value)
 891              (let ((entry (cdr (assq entry-name value)))
 892                    found)
 893                (unless (listp entry)
 894                  (setq entry (list entry)))
 895                (while (and (not found) entry)
 896                  (if (string-match regexp (pop entry))
 897                      (setq found t)))
 898                (if found
 899                    (push (cons key value) records)))))
 900        (lambda (key value)
 901          (if (string-match regexp key)
 902              (push (cons key value) records))))
 903      lsdb-hash-table)
 904     records))
 905
 906 (defvar lsdb-mode-lookup-history nil)
 907
 908 (defun lsdb-mode-lookup (regexp &optional entry-name)
 909   "Display the all records in the LSDB matching the REGEXP.
 910 If the optional 2nd argument ENTRY-NAME is given, matching only
 911 performed against the entry field."
 912   (interactive
 913    (let* ((completion-ignore-case t)
 914           (entry-name
 915            (if current-prefix-arg
 916                (completing-read "Entry name: "
 917                                 lsdb-known-entry-names))))
 918      (list
 919       (read-from-minibuffer
 920        (if entry-name
 921            (format "Search records `%s' regexp: " entry-name)
 922          "Search records regexp: ")
 923        nil nil nil 'lsdb-mode-lookup-history)
 924       entry-name)))
 925   (lsdb-maybe-load-file)
 926   (let ((records (lsdb-lookup-records regexp entry-name)))
 927     (if records
 928         (lsdb-display-records records))))
 929
 930 ;;;###autoload
 931 (defalias 'lsdb 'lsdb-mode-lookup)
 932
 933 (defun lsdb-mode-next-record (&optional arg)
 934   "Go to the next record."
 935   (interactive "p")
 936   (unless arg                           ;called noninteractively?
 937     (setq arg 1))
 938   (if (< arg 0)
 939       (lsdb-mode-previous-record (- arg))
 940     (while (> arg 0)
 941       (goto-char (next-single-property-change
 942                   (point) 'lsdb-record nil (point-max)))
 943       (setq arg (1- arg)))))
 944
 945 (defun lsdb-mode-previous-record (&optional arg)
 946   "Go to the previous record."
 947   (interactive "p")
 948   (unless arg                           ;called noninteractively?
 949     (setq arg 1))
 950   (if (< arg 0)
 951       (lsdb-mode-next-record (- arg))
 952     (while (> arg 0)
 953       (goto-char (previous-single-property-change
 954                   (point) 'lsdb-record nil (point-min)))
 955       (setq arg (1- arg)))))
 956
 957 ;;;_ : Edit Forms -- stolen (and renamed) from gnus-eform.el
 958 (defvar lsdb-edit-form-buffer "*LSDB edit form*")
 959 (defvar lsdb-edit-form-done-function nil)
 960 (defvar lsdb-previous-window-configuration nil)
 961
 962 (defvar lsdb-edit-form-mode-map
 963   (let ((keymap (make-sparse-keymap)))
 964     (set-keymap-parent keymap emacs-lisp-mode-map)
 965     (define-key keymap "\C-c\C-c" 'lsdb-edit-form-done)
 966     (define-key keymap "\C-c\C-k" 'lsdb-edit-form-exit)
 967     keymap)
 968   "Edit form's keymap.")
 969
 970 (defun lsdb-edit-form-mode ()
 971   "Major mode for editing forms.
 972 It is a slightly enhanced emacs-lisp-mode.
 973
 974 \\{lsdb-edit-form-mode-map}"
 975   (interactive)
 976   (kill-all-local-variables)
 977   (setq major-mode 'lsdb-edit-form-mode
 978         mode-name "LSDB Edit Form")
 979   (use-local-map lsdb-edit-form-mode-map)
 980   (make-local-variable 'lsdb-edit-form-done-function)
 981   (make-local-variable 'lsdb-previous-window-configuration)
 982   (run-hooks 'lsdb-edit-form-mode-hook))
 983
 984 (defun lsdb-edit-form (form documentation exit-func)
 985   "Edit FORM in a new buffer.
 986 Call EXIT-FUNC on exit.  Display DOCUMENTATION in the beginning
 987 of the buffer."
 988   (let ((window-configuration
 989          (current-window-configuration)))
 990     (switch-to-buffer (get-buffer-create lsdb-edit-form-buffer))
 991     (lsdb-edit-form-mode)
 992     (setq lsdb-previous-window-configuration window-configuration
 993           lsdb-edit-form-done-function exit-func)
 994     (erase-buffer)
 995     (insert documentation)
 996     (unless (bolp)
 997       (insert "\n"))
 998     (goto-char (point-min))
 999     (while (not (eobp))
1000       (insert ";;; ")
1001       (forward-line 1))
1002     (insert ";; Type `C-c C-c' after you've finished editing.\n")
1003     (insert "\n")
1004     (let ((p (point)))
1005       (pp form (current-buffer))
1006       (insert "\n")
1007       (goto-char p))))
1008
1009 (defun lsdb-edit-form-done ()
1010   "Update changes and kill the current buffer."
1011   (interactive)
1012   (goto-char (point-min))
1013   (let ((form (condition-case nil
1014                   (read (current-buffer))
1015                 (end-of-file nil)))
1016         (func lsdb-edit-form-done-function))
1017     (lsdb-edit-form-exit)
1018     (funcall func form)))
1019
1020 (defun lsdb-edit-form-exit ()
1021   "Kill the current buffer."
1022   (interactive)
1023   (let ((window-configuration lsdb-previous-window-configuration))
1024     (kill-buffer (current-buffer))
1025     (set-window-configuration window-configuration)))
1026
1027 ;;;_. Interface to Semi-gnus
1028 ;;;###autoload
1029 (defun lsdb-gnus-insinuate ()
1030   "Call this function to hook LSDB into Semi-gnus."
1031   (add-hook 'gnus-article-prepare-hook 'lsdb-gnus-update-record)
1032   (add-hook 'gnus-save-newsrc-hook 'lsdb-mode-save))
1033
1034 (defvar gnus-current-headers)
1035 (defun lsdb-gnus-update-record ()
1036   (let ((entity gnus-current-headers)
1037         records)
1038     (with-temp-buffer
1039       (set-buffer-multibyte nil)
1040       (buffer-disable-undo)
1041       (mime-insert-entity entity)
1042       (setq records (lsdb-update-records))
1043       (when records
1044         (lsdb-display-record (car records))))))
1045
1046 ;;;_. Interface to Wanderlust
1047 ;;;###autoload
1048 (defun lsdb-wl-insinuate ()
1049   "Call this function to hook LSDB into Wanderlust."
1050   (add-hook 'wl-message-redisplay-hook 'lsdb-wl-update-record)
1051   (add-hook 'wl-summary-exit-hook 'lsdb-mode-hide-buffer)
1052   (add-hook 'wl-exit-hook 'lsdb-mode-save)
1053   (add-hook 'wl-save-hook 'lsdb-mode-save))
1054
1055 (eval-when-compile
1056   (autoload 'wl-message-get-original-buffer "wl-message"))
1057 (defun lsdb-wl-update-record ()
1058   (save-excursion
1059     (set-buffer (wl-message-get-original-buffer))
1060     (let ((records (lsdb-update-records)))
1061       (when records
1062         (lsdb-display-record (car records))))))
1063
1064 ;;;_. Interface to Mew written by Hideyuki SHIRAI <shirai@rdmg.mgcs.mei.co.jp>
1065 (eval-when-compile
1066   (autoload 'mew-sinfo-get-disp-msg "mew")
1067   (autoload 'mew-current-get-fld "mew")
1068   (autoload 'mew-current-get-msg "mew")
1069   (autoload 'mew-frame-id "mew")
1070   (autoload 'mew-cache-hit "mew"))
1071
1072 ;;;###autoload
1073 (defun lsdb-mew-insinuate ()
1074   "Call this function to hook LSDB into Mew."
1075   (add-hook 'mew-message-hook 'lsdb-mew-update-record)
1076   (add-hook 'mew-summary-toggle-disp-msg-hook
1077             (lambda ()
1078               (unless (mew-sinfo-get-disp-msg)
1079                 (lsdb-mode-hide-buffer))))
1080   (add-hook 'mew-suspend-hook 'lsdb-mode-hide-buffer)
1081   (add-hook 'mew-quit-hook 'lsdb-mode-save)
1082   (add-hook 'kill-emacs-hook 'lsdb-mode-save))
1083
1084 (defun lsdb-mew-update-record ()
1085   (let* ((fld (mew-current-get-fld (mew-frame-id)))
1086          (msg (mew-current-get-msg (mew-frame-id)))
1087          (cache (mew-cache-hit fld msg 'must-hit))
1088          records)
1089     (save-excursion
1090       (set-buffer cache)
1091       (make-local-variable 'lsdb-decode-field-body-function)
1092       (setq lsdb-decode-field-body-function
1093             (lambda (body name)
1094               (set-text-properties 0 (length body) nil body)
1095               body))
1096       (when (setq records (lsdb-update-records))
1097         (lsdb-display-record (car records))))))
1098
1099 ;;;_. Interface to MU-CITE
1100 (eval-when-compile
1101   (autoload 'mu-cite-get-value "mu-cite"))
1102
1103 (defun lsdb-mu-attribution (address)
1104   "Extract attribute information from LSDB."
1105   (let ((records
1106          (lsdb-lookup-records (concat "\\<" address "\\>") 'net)))
1107     (if records
1108         (cdr (assq 'attribution (cdr (car records)))))))
1109
1110 (defun lsdb-mu-set-attribution (attribution address)
1111   "Add attribute information to LSDB."
1112   (let ((records
1113          (lsdb-lookup-records (concat "\\<" address "\\>") 'net))
1114         entry)
1115     (when records
1116       (setq entry (assq 'attribution (cdr (car records))))
1117       (if entry
1118           (setcdr entry attribution)
1119         (setcdr (car records) (cons (cons 'attribution attribution)
1120                                     (cdr (car records))))
1121         (lsdb-puthash (car (car records)) (cdr (car records))
1122                       lsdb-hash-table)
1123         (setq lsdb-hash-table-is-dirty t)))))
1124
1125 (defun lsdb-mu-get-prefix-method ()
1126   "A mu-cite method to return a prefix from LSDB or \">\".
1127 If an `attribution' value is found in LSDB, the value is returned.
1128 Otherwise \">\" is returned."
1129   (or (lsdb-mu-attribution (mu-cite-get-value 'address))
1130       ">"))
1131
1132 (defvar minibuffer-allow-text-properties)
1133
1134 (defvar lsdb-mu-history nil)
1135
1136 (defun lsdb-mu-get-prefix-register-method ()
1137   "A mu-cite method to return a prefix from LSDB or register it.
1138 If an `attribution' value is found in LSDB, the value is returned.
1139 Otherwise the function requests a prefix from a user.  The prefix will
1140 be registered to LSDB if the user wants it."
1141   (let ((address (mu-cite-get-value 'address)))
1142     (or (lsdb-mu-attribution address)
1143         (let* (minibuffer-allow-text-properties
1144                (result (read-string "Citation name? "
1145                                     (or (mu-cite-get-value 'x-attribution)
1146                                         (mu-cite-get-value 'full-name))
1147                                     'lsdb-mu-history)))
1148           (if (and (not (string-equal result ""))
1149                    (y-or-n-p (format "Register \"%s\"? " result)))
1150               (lsdb-mu-set-attribution result address))
1151           result))))
1152
1153 (defun lsdb-mu-get-prefix-register-verbose-method ()
1154   "A mu-cite method to return a prefix using LSDB.
1155
1156 In this method, a user must specify a prefix unconditionally.  If an
1157 `attribution' value is found in LSDB, the value is used as a initial
1158 value to input the prefix.  The prefix will be registered to LSDB if
1159 the user wants it."
1160   (let* ((address (mu-cite-get-value 'address))
1161          (attribution (lsdb-mu-attribution address))
1162          minibuffer-allow-text-properties
1163          (result (read-string "Citation name? "
1164                               (or attribution
1165                                   (mu-cite-get-value 'x-attribution)
1166                                   (mu-cite-get-value 'full-name))
1167                               'lsdb-mu-history)))
1168     (if (and (not (string-equal result ""))
1169              (not (string-equal result attribution))
1170              (y-or-n-p (format "Register \"%s\"? " result)))
1171         (lsdb-mu-set-attribution result address))
1172     result))
1173
1174 (defvar mu-cite-methods-alist)
1175 ;;;###autoload
1176 (defun lsdb-mu-insinuate ()
1177   (add-hook 'mu-cite-instantiation-hook
1178             (lambda ()
1179               (setq mu-cite-methods-alist
1180                     (nconc
1181                      mu-cite-methods-alist
1182                      (list
1183                       (cons 'lsdb-prefix
1184                             #'lsdb-mu-get-prefix-method)
1185                       (cons 'lsdb-prefix-register
1186                             #'lsdb-mu-get-prefix-register-method)
1187                       (cons 'lsdb-prefix-register-verbose
1188                             #'lsdb-mu-get-prefix-register-verbose-method)))))))
1189
1190 ;;;_. X-Face Rendering
1191 (defvar lsdb-x-face-cache
1192   (lsdb-make-hash-table :test 'equal))
1193
1194 (defun lsdb-x-face-available-image-type ()
1195   (static-if (featurep 'xemacs)
1196       (if (featurep 'xpm)
1197           'xpm)
1198     (and (>= emacs-major-version 21)
1199          (fboundp 'image-type-available-p)
1200          (if (image-type-available-p 'pbm)
1201              'pbm
1202            (if (image-type-available-p 'xpm)
1203                'xpm)))))
1204
1205 (defun lsdb-expose-x-face ()
1206   (let* ((record (get-text-property (point-min) 'lsdb-record))
1207          (x-face (cdr (assq 'x-face (cdr record))))
1208          (delimiter "\r "))
1209     (when (and lsdb-insert-x-face-function
1210                x-face)
1211       (goto-char (point-min))
1212       (end-of-line)
1213       (put-text-property 0 1 'invisible t delimiter)
1214       (put-text-property 0 (length delimiter) 'lsdb-record record delimiter)
1215       (insert delimiter)
1216       (while x-face
1217         (funcall lsdb-insert-x-face-function (pop x-face))))))
1218
1219 (defun lsdb-insert-x-face-image (data type marker)
1220   (static-if (featurep 'xemacs)
1221       (save-excursion
1222         (set-buffer (marker-buffer marker))
1223         (goto-char marker)
1224         (let* ((inhibit-read-only t)
1225                buffer-read-only
1226                (glyph (make-glyph (vector type :data data))))
1227           (set-extent-begin-glyph
1228            (make-extent (point) (point))
1229            glyph)))
1230     (save-excursion
1231       (set-buffer (marker-buffer marker))
1232       (goto-char marker)
1233       (let* ((inhibit-read-only t)
1234              buffer-read-only
1235              (image (create-image data type t :ascent 'center))
1236              (record (get-text-property (point) 'lsdb-record)))
1237         (put-text-property (point) (progn
1238                                      (insert-image image)
1239                                      (point))
1240                            'lsdb-record record)))))
1241
1242 (defun lsdb-insert-x-face-asynchronously (x-face)
1243   (let* ((type (lsdb-x-face-available-image-type))
1244          (shell-file-name lsdb-shell-file-name)
1245          (shell-command-switch lsdb-shell-command-switch)
1246          (process-connection-type nil)
1247          (cached (cdr (assq type (lsdb-gethash x-face lsdb-x-face-cache))))
1248          (marker (point-marker))
1249          process)
1250     (if cached
1251         (lsdb-insert-x-face-image cached type marker)
1252       (setq process
1253             (start-process-shell-command
1254              "lsdb-x-face-command" (generate-new-buffer " *lsdb work*")
1255              (concat "{ "
1256                      (nth 1 (assq type lsdb-x-face-command-alist))
1257                      "; } 2> /dev/null")))
1258       (process-send-string process (concat x-face "\n"))
1259       (process-send-eof process)
1260       (set-process-sentinel
1261        process
1262        `(lambda (process string)
1263           (unwind-protect
1264               (when (and (buffer-live-p (marker-buffer ,marker))
1265                          (equal string "finished\n"))
1266                 (let ((data
1267                        (with-current-buffer (process-buffer process)
1268                          (set-buffer-multibyte nil)
1269                          (buffer-string))))
1270                   (lsdb-insert-x-face-image data ',type ,marker)
1271                   (lsdb-puthash ,x-face (list (cons ',type data))
1272                                 lsdb-x-face-cache)))
1273             (kill-buffer (process-buffer process))))))))
1274
1275 (require 'product)
1276 (provide 'lsdb)
1277
1278 (product-provide 'lsdb
1279   (product-define "LSDB" nil '(0 2)))
1280
1281 ;;;_* Local emacs vars.
1282 ;;; The following `outline-layout' local variable setting:
1283 ;;;  - closes all topics from the first topic to just before the third-to-last,
1284 ;;;  - shows the children of the third to last (config vars)
1285 ;;;  - and the second to last (code section),
1286 ;;;  - and closes the last topic (this local-variables section).
1287 ;;;Local variables:
1288 ;;;outline-layout: (0 : -1 -1 0)
1289 ;;;End:
1290
1291 ;;; lsdb.el ends here