lsdb.el

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