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