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