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