lsdb.el

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