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 'mime)
  46
  47 ;;;_* USER CUSTOMIZATION VARIABLES:
  48 (defgroup lsdb nil
  49   "The Lovely Sister Database."
  50   :group 'news
  51   :group 'mail)
  52
  53 (defcustom lsdb-file (expand-file-name "~/.lsdb")
  54   "The name of the Lovely Sister Database file."
  55   :group 'lsdb
  56   :type 'file)
  57
  58 (defcustom lsdb-file-coding-system 'iso-2022-jp
  59   "Coding system for `lsdb-file'."
  60   :group 'lsdb
  61   :type 'symbol)
  62
  63 (defcustom lsdb-sender-headers
  64   "From\\|Resent-From"
  65   "List of headers to search for senders."
  66   :group 'lsdb
  67   :type 'list)
  68
  69 (defcustom lsdb-recipients-headers
  70   "Resent-To\\|Resent-Cc\\|Reply-To\\|To\\|Cc\\|Bcc"
  71   "List of headers to search for recipients."
  72   :group 'lsdb
  73   :type 'list)
  74
  75 (defcustom lsdb-interesting-header-alist
  76   '(("Organization" nil organization)
  77     ("\\(X-\\)?User-Agent\\|X-Mailer" nil user-agent)
  78     ("\\(X-\\)?ML-Name" nil mailing-list)
  79     ("\\(X-URL\\|X-URI\\)" nil www)
  80     ("X-Attribution\\|X-cite-me" nil attribution)
  81     ("X-Face" nil x-face))
  82   "Alist of headers we are interested in.
  83 The format of elements of this list should be
  84      (FIELD-NAME REGEXP ENTRY STRING)
  85 where the last three elements are optional."
  86   :group 'lsdb
  87   :type 'list)
  88
  89 (defcustom lsdb-entry-type-alist
  90   '((net 5 ?,)
  91     (creation-date 2)
  92     (last-modified 3)
  93     (mailing-list 4 ?,)
  94     (attribution 4 ?.)
  95     (organization 4)
  96     (www 1)
  97     (score -1)
  98     (x-face -1))
  99   "Alist of entries to display.
 100 The format of elements of this list should be
 101      (ENTRY SCORE CLASS)
 102 where the last element is optional."
 103   :group 'lsdb
 104   :type 'list)
 105
 106 (defcustom lsdb-decode-field-body-function #'lsdb-decode-field-body
 107   "Field body decoder."
 108   :group 'lsdb
 109   :type 'function)
 110
 111 (defcustom lsdb-canonicalize-full-name-function
 112   #'lsdb-canonicalize-spaces-and-dots
 113   "Way to canonicalize full name."
 114   :group 'lsdb
 115   :type 'function)
 116
 117 (defcustom lsdb-print-record-function
 118   #'lsdb-print-record
 119   "Function to print LSDB record."
 120   :group 'lsdb
 121   :type 'function)
 122
 123 (defcustom lsdb-window-max-height 7
 124   "Maximum number of lines used to display LSDB record."
 125   :group 'lsdb
 126   :type 'integer)
 127
 128 (defcustom lsdb-insert-x-face-function
 129   (if (and (>= emacs-major-version 21)
 130            (locate-library "x-face-e21"))
 131       #'lsdb-insert-x-face-with-x-face-e21)
 132   "Function to display X-Face."
 133   :group 'lsdb
 134   :type 'function)
 135
 136 (defcustom lsdb-display-record-hook
 137   (if lsdb-insert-x-face-function
 138       #'lsdb-expose-x-face)
 139   "A hook called after a record is displayed."
 140   :group 'lsdb
 141   :type 'hook)
 142
 143 (defgroup lsdb-edit-form nil
 144   "A mode for editing forms."
 145   :group 'lsdb)
 146
 147 (defcustom lsdb-edit-form-mode-hook nil
 148   "Hook run in `lsdb-edit-form-mode' buffers."
 149   :group 'lsdb-edit-form
 150   :type 'hook)
 151
 152 ;;;_. Faces
 153 (defface lsdb-header-face
 154   '((t (:underline t)))
 155   "Face for the file header line in `lsdb-mode'."
 156   :group 'lsdb)
 157 (defvar lsdb-header-face 'lsdb-header-face)
 158
 159 (defface lsdb-field-name-face
 160   '((((class color) (background dark))
 161      (:foreground "PaleTurquoise" :bold t))
 162     (t (:bold t)))
 163   "Face for the message header line in `lsdb-mode'."
 164   :group 'lsdb)
 165 (defvar lsdb-field-name-face 'lsdb-field-name-face)
 166
 167 (defface lsdb-field-body-face
 168   '((((class color) (background dark))
 169      (:foreground "turquoise" :italic t))
 170     (t (:italic t)))
 171   "Face for the message header line in `lsdb-mode'."
 172   :group 'lsdb)
 173 (defvar lsdb-field-body-face 'lsdb-field-body-face)
 174
 175 (defconst lsdb-font-lock-keywords
 176   '(("^\\sw[^\r\n]*"
 177      (0 lsdb-header-face))
 178     ("^\t\t.*$"
 179      (0 lsdb-field-body-face))
 180     ("^\t\\([^\t:]+:\\)[ \t]*\\(.*\\)$"
 181      (1 lsdb-field-name-face)
 182      (2 lsdb-field-body-face))))
 183
 184 (put 'lsdb-mode 'font-lock-defaults '(lsdb-font-lock-keywords t))
 185
 186 ;;;_* CODE - no user customizations below
 187 (defvar lsdb-hash-table nil
 188   "Internal hash table to hold LSDB records.")
 189
 190 (defvar lsdb-buffer-name "*LSDB*"
 191   "Buffer name to display LSDB record.")
 192
 193 (defvar lsdb-hash-table-is-dirty nil
 194   "Flag to indicate whether the hash table needs to be saved.")
 195
 196 ;;;_. Hash Table Emulation
 197 (if (fboundp 'make-hash-table)
 198     (progn
 199       (defalias 'lsdb-puthash 'puthash)
 200       (defalias 'lsdb-gethash 'gethash)
 201       (defalias 'lsdb-remhash 'remhash)
 202       (defalias 'lsdb-maphash 'maphash)
 203       (defalias 'lsdb-hash-table-size 'hash-table-size)
 204       (defalias 'lsdb-hash-table-count 'hash-table-count)
 205       (defalias 'lsdb-make-hash-table 'make-hash-table))
 206   (defun lsdb-puthash (key value hash-table)
 207     "Hash KEY to VALUE in HASH-TABLE."
 208     ;; Obarray is regarded as an open hash table, as a matter of
 209     ;; fact, rehashing doesn't make sense.
 210     (let (new-obarray)
 211       (when (> (car hash-table)
 212                (* (length (nth 1 hash-table)) 0.7))
 213         (setq new-obarray (make-vector (* (length (nth 1 hash-table)) 2) 0))
 214         (mapatoms
 215          (lambda (symbol)
 216            (set (intern (symbol-name symbol) new-obarray)
 217                 (symbol-value symbol)))
 218          (nth 1 hash-table))
 219         (setcdr hash-table (list new-obarray)))
 220       (set (intern key (nth 1 hash-table)) value)
 221       (setcar hash-table (1+ (car hash-table)))))
 222   (defun lsdb-gethash (key hash-table &optional default)
 223     "Find hash value for KEY in HASH-TABLE.
 224 If there is no corresponding value, return DEFAULT (which defaults to nil)."
 225     (let ((symbol (intern-soft key (nth 1 hash-table))))
 226       (if symbol
 227           (symbol-value symbol)
 228         default)))
 229   (defun lsdb-remhash (key hash-table)
 230     "Remove the entry for KEY from HASH-TABLE.
 231 Do nothing if there is no entry for KEY in HASH-TABLE."
 232     (unintern key (nth 1 hash-table))
 233     (setcar hash-table (1- (car hash-table))))
 234   (defun lsdb-maphash (function hash-table)
 235     "Map FUNCTION over entries in HASH-TABLE, calling it with two args,
 236 each key and value in HASH-TABLE.
 237
 238 FUNCTION may not modify HASH-TABLE, with the one exception that FUNCTION
 239 may remhash or puthash the entry currently being processed by FUNCTION."
 240     (mapatoms
 241      (lambda (symbol)
 242        (funcall function (symbol-name symbol) (symbol-value symbol)))
 243      hash-table))
 244   (defun lsdb-hash-table-size (hash-table)
 245     "Return the size of HASH-TABLE.
 246 This is the current number of slots in HASH-TABLE, whether occupied or not."
 247     (length (nth 1 hash-table)))
 248   (defalias 'lsdb-hash-table-count 'car)
 249   (defun lsdb-make-hash-table (&rest args)
 250     "Return a new empty hash table object."
 251     (list 0 (make-vector (or (plist-get args :size) 29) 0))))
 252
 253 ;;;_. Hash Table Reader/Writer
 254 (eval-and-compile
 255   (condition-case nil
 256       (progn
 257         ;; In XEmacs, hash tables can also be created by the lisp reader
 258         ;; using structure syntax.
 259         (read-from-string "#s(hash-table)")
 260         (defun lsdb-load-file (file)
 261           "Read the contents of FILE into a hash table."
 262           (save-excursion
 263             (set-buffer (find-file-noselect file))
 264             (re-search-forward "^#s")
 265             (beginning-of-line)
 266             (read (point-min-marker)))))
 267     (invalid-read-syntax
 268     (defun lsdb-load-file (file)
 269       "Read the contents of FILE into a hash table."
 270       (let* ((plist
 271               (with-temp-buffer
 272                 (insert-file-contents file)
 273                 (save-excursion
 274                   (re-search-forward "^#s")
 275                   (replace-match "")
 276                   (beginning-of-line)
 277                   (cdr (read (point-marker))))))
 278              (size (plist-get plist 'size))
 279              (data (plist-get plist 'data))
 280              (hash-table (lsdb-make-hash-table :size size :test 'equal)))
 281         (while data
 282           (lsdb-puthash (pop data) (pop data) hash-table))
 283         hash-table)))))
 284
 285 (defun lsdb-save-file (file hash-table)
 286   "Write the entries within HASH-TABLE into FILE."
 287   (let ((coding-system-for-write lsdb-file-coding-system))
 288     (with-temp-file file
 289       (if (and (or (featurep 'mule)
 290                    (featurep 'file-coding))
 291                lsdb-file-coding-system)
 292           (insert ";;; -*- coding: "
 293                   (if (symbolp lsdb-file-coding-system)
 294                       (symbol-name lsdb-file-coding-system)
 295                     ;; XEmacs
 296                     (coding-system-name lsdb-file-coding-system))
 297                   " -*-\n"))
 298       (insert "#s(hash-table size "
 299               (number-to-string (lsdb-hash-table-size hash-table))
 300               " test equal data (")
 301       (lsdb-maphash
 302        (lambda (key value)
 303          (insert (prin1-to-string key) " " (prin1-to-string value) " "))
 304        hash-table)
 305       (insert "))"))))
 306
 307 ;;;_. Mail Header Extraction
 308 (defun lsdb-fetch-field-bodies (regexp)
 309   (save-excursion
 310     (goto-char (point-min))
 311     (let ((case-fold-search t)
 312           field-bodies)
 313       (while (re-search-forward (concat "^\\(" regexp "\\):[ \t]*")
 314                                 nil t)
 315         (push (funcall lsdb-decode-field-body-function
 316                              (buffer-substring (point) (std11-field-end))
 317                              (match-string 1))
 318                     field-bodies))
 319       (nreverse field-bodies))))
 320
 321 (defun lsdb-canonicalize-spaces-and-dots (string)
 322   (while (string-match "  +\\|[\f\t\n\r\v]+\\|\\." string)
 323     (setq string (replace-match " " nil t string)))
 324   string)
 325
 326 (defun lsdb-extract-address-components (string)
 327   (let ((components (std11-extract-address-components string)))
 328     (if (nth 1 components)
 329         (if (car components)
 330             (list (nth 1 components)
 331                   (funcall lsdb-canonicalize-full-name-function
 332                            (car components)))
 333           (list (nth 1 components) (nth 1 components))))))
 334
 335 ;; stolen (and renamed) from nnheader.el
 336 (defun lsdb-decode-field-body (field-body field-name
 337                                           &optional mode max-column)
 338   (let ((multibyte enable-multibyte-characters))
 339     (unwind-protect
 340         (progn
 341           (set-buffer-multibyte t)
 342           (mime-decode-field-body field-body
 343                                   (if (stringp field-name)
 344                                       (intern (capitalize field-name))
 345                                     field-name)
 346                                   mode max-column))
 347       (set-buffer-multibyte multibyte))))
 348
 349 ;;;_. Record Management
 350 (defun lsdb-maybe-load-file ()
 351   (unless lsdb-hash-table
 352     (if (file-exists-p lsdb-file)
 353         (setq lsdb-hash-table (lsdb-load-file lsdb-file))
 354       (setq lsdb-hash-table (lsdb-make-hash-table :test 'equal)))))
 355
 356 (defun lsdb-update-record (sender &optional interesting)
 357   (let ((old (lsdb-gethash (nth 1 sender) lsdb-hash-table))
 358         (new (cons (cons 'net (list (car sender)))
 359                    interesting))
 360         merged
 361         record)
 362     (unless old
 363       (setq new (cons (cons 'creation-date (format-time-string "%Y-%m-%d"))
 364                       new)))
 365     (setq merged (lsdb-merge-record-entries old new)
 366           record (cons (nth 1 sender) merged))
 367     (unless (equal merged old)
 368       (let ((entry (assq 'last-modified (cdr record)))
 369             (last-modified (format-time-string "%Y-%m-%d")))
 370         (if entry
 371             (setcdr entry last-modified)
 372           (setcdr record (cons (cons 'last-modified last-modified)
 373                                (cdr record)))))
 374       (lsdb-puthash (car record) (cdr record)
 375                     lsdb-hash-table)
 376       (setq lsdb-hash-table-is-dirty t))
 377     record))
 378
 379 (defun lsdb-update-records ()
 380   (lsdb-maybe-load-file)
 381   (let (senders recipients interesting alist records bodies entry)
 382     (save-restriction
 383       (std11-narrow-to-header)
 384       (setq senders
 385             (delq nil (mapcar #'lsdb-extract-address-components
 386                               (lsdb-fetch-field-bodies
 387                                lsdb-sender-headers)))
 388             recipients
 389             (delq nil (mapcar #'lsdb-extract-address-components
 390                               (lsdb-fetch-field-bodies
 391                                lsdb-recipients-headers))))
 392       (setq alist lsdb-interesting-header-alist)
 393       (while alist
 394         (setq bodies
 395               (mapcar
 396                (lambda (field-body)
 397                  (if (and (nth 1 (car alist))
 398                           (string-match (nth 1 (car alist)) field-body))
 399                      (replace-match (nth 3 (car alist)) nil nil field-body)
 400                    field-body))
 401                (lsdb-fetch-field-bodies (car (car alist)))))
 402         (when bodies
 403           (setq entry (or (nth 2 (car alist))
 404                           'notes))
 405           (push (cons entry
 406                       (if (eq ?. (nth 2 (assq entry lsdb-entry-type-alist)))
 407                           (car bodies)
 408                         bodies))
 409                 interesting))
 410         (setq alist (cdr alist))))
 411     (if senders
 412         (setq records (list (lsdb-update-record (pop senders) interesting))))
 413     (setq alist (nconc senders recipients))
 414     (while alist
 415       (setq records (cons (lsdb-update-record (pop alist)) records)))
 416     (nreverse records)))
 417
 418 (defun lsdb-merge-record-entries (old new)
 419   (setq old (copy-sequence old))
 420   (while new
 421     (let ((entry (assq (car (car new)) old))
 422           list pointer)
 423       (if (null entry)
 424           (setq old (nconc old (list (car new))))
 425         (if (listp (cdr entry))
 426             (progn
 427               (setq list (cdr (car new)) pointer list)
 428               (while pointer
 429                 (if (member (car pointer) (cdr entry))
 430                     (setq list (delq (car pointer) list)))
 431                 (setq pointer (cdr pointer)))
 432               (setcdr entry (nconc (cdr entry) list)))
 433           (setcdr entry (cdr (car new))))))
 434     (setq new (cdr new)))
 435   old)
 436
 437 ;;;_. Display Management
 438 (defun lsdb-temp-buffer-show-function (buffer)
 439   (save-selected-window
 440     (let ((window (or (get-buffer-window lsdb-buffer-name)
 441                       (progn
 442                         (select-window (get-largest-window))
 443                         (split-window-vertically))))
 444           height)
 445       (set-window-buffer window buffer)
 446       (select-window window)
 447       (unless (pos-visible-in-window-p (point-max))
 448         (enlarge-window (- lsdb-window-max-height (window-height))))
 449       (shrink-window-if-larger-than-buffer)
 450       (if (> (setq height (window-height))
 451              lsdb-window-max-height)
 452           (shrink-window (- height lsdb-window-max-height))
 453           (shrink-window-if-larger-than-buffer)))))
 454
 455 (defun lsdb-display-record (record)
 456   "Display only one RECORD, then shrink the window as possible."
 457   (let ((temp-buffer-show-function
 458          (function lsdb-temp-buffer-show-function)))
 459     (lsdb-display-records (list record))))
 460
 461 (defun lsdb-display-records (records)
 462   (with-output-to-temp-buffer lsdb-buffer-name
 463     (set-buffer standard-output)
 464     (while records
 465       (save-restriction
 466         (narrow-to-region (point) (point))
 467         (funcall lsdb-print-record-function (car records))
 468         (add-text-properties (point-min) (point-max)
 469                              (list 'lsdb-record (car records)))
 470         (run-hooks 'lsdb-display-record-hook))
 471       (setq records (cdr records)))
 472     (lsdb-mode)))
 473
 474 (defsubst lsdb-entry-score (entry)
 475   (or (nth 1 (assq (car entry) lsdb-entry-type-alist)) 0))
 476
 477 (defun lsdb-insert-entry (entry)
 478   (insert "\t" (capitalize (symbol-name (car entry))) ": "
 479           (if (listp (cdr entry))
 480               (mapconcat
 481                #'identity (cdr entry)
 482                (if (eq ?, (nth 2 (assq (car entry) lsdb-entry-type-alist)))
 483                    ", "
 484                  "\n\t\t"))
 485             (cdr entry))
 486           "\n"))
 487
 488 (defun lsdb-print-record (record)
 489   (insert (car record) "\n")
 490   (let ((entries
 491          (sort (copy-sequence (cdr record))
 492                (lambda (entry1 entry2)
 493                  (> (lsdb-entry-score entry1) (lsdb-entry-score entry2))))))
 494     (while entries
 495       (if (>= (lsdb-entry-score (car entries)) 0)
 496           (lsdb-insert-entry (car entries)))
 497       (setq entries (cdr entries)))))
 498
 499 ;;;_. Completion
 500 (defvar lsdb-last-completion nil)
 501 (defvar lsdb-last-candidates nil)
 502 (defvar lsdb-last-candidates-pointer nil)
 503
 504 (defun lsdb-complete-name ()
 505   "Complete the user full-name or net-address before point"
 506   (interactive)
 507   (lsdb-maybe-load-file)
 508   (let* ((start
 509           (save-excursion
 510             (re-search-backward "\\(\\`\\|[\n:,]\\)[ \t]*")
 511             (goto-char (match-end 0))
 512             (point)))
 513          pattern
 514          (case-fold-search t)
 515          (completion-ignore-case t))
 516     (unless (eq last-command this-command)
 517       (setq lsdb-last-candidates nil
 518             lsdb-last-candidates-pointer nil
 519             lsdb-last-completion (buffer-substring start (point))
 520             pattern (concat "\\<" lsdb-last-completion))
 521       (lsdb-maphash
 522        (lambda (key value)
 523          (let ((net (cdr (assq 'net value))))
 524            (if (string-match pattern key)
 525                (setq lsdb-last-candidates
 526                      (nconc lsdb-last-candidates
 527                             (mapcar (lambda (address)
 528                                       (if (equal key address)
 529                                           key
 530                                         (concat key " <" address ">")))
 531                                     net)))
 532              (while net
 533                (if (string-match pattern (car net))
 534                    (push (car net) lsdb-last-candidates))
 535                (setq net (cdr net))))))
 536        lsdb-hash-table))
 537     (unless lsdb-last-candidates-pointer
 538       (setq lsdb-last-candidates-pointer lsdb-last-candidates))
 539     (when lsdb-last-candidates-pointer
 540       (delete-region start (point))
 541       (insert (pop lsdb-last-candidates-pointer)))))
 542
 543 ;;;_. Major Mode (`lsdb-mode') Implementation
 544 (defvar lsdb-mode-map
 545   (let ((keymap (make-sparse-keymap)))
 546     (define-key keymap "a" 'lsdb-mode-add-entry)
 547     (define-key keymap "d" 'lsdb-mode-delete-entry)
 548     (define-key keymap "e" 'lsdb-mode-edit-entry)
 549     (define-key keymap "s" 'lsdb-mode-save)
 550     (define-key keymap "q" 'lsdb-mode-quit-window)
 551     keymap)
 552   "LSDB's keymap.")
 553
 554 (if (commandp 'quit-window)
 555     (defalias 'lsdb-mode-quit-window 'quit-window)
 556   (defun lsdb-mode-quit-window ()
 557     (interactive)
 558     (if (one-window-p)
 559         (bury-buffer)
 560       (delete-window))))
 561
 562 (define-derived-mode lsdb-mode fundamental-mode "LSDB"
 563   "Major mode for browsing LSDB records."
 564   (setq buffer-read-only t)
 565   (if (featurep 'xemacs)
 566       ;; In XEmacs, setting `font-lock-defaults' only affects on
 567       ;; `find-file-hooks'.
 568       (font-lock-set-defaults)
 569     (set (make-local-variable 'font-lock-defaults)
 570          '(lsdb-font-lock-keywords t))))
 571
 572 (defun lsdb-narrow-to-record ()
 573   (narrow-to-region
 574    (or (previous-single-property-change (point) 'lsdb-record)
 575        (point-min))
 576    (or (next-single-property-change (point) 'lsdb-record)
 577        (point-max))))
 578
 579 (defun lsdb-current-entry ()
 580   (save-excursion
 581     (beginning-of-line)
 582     (if (looking-at "^[^\t]")
 583         (let ((record (get-text-property (point) 'lsdb-record))
 584               (completion-ignore-case t))
 585           (completing-read
 586            "Which entry to edit: "
 587            (mapcar (lambda (entry)
 588                      (list (capitalize (symbol-name (car entry)))))
 589                    (cdr record))))
 590       (end-of-line)
 591       (re-search-backward "^\t\\([^\t][^:]+\\):")
 592       (match-string 1))))
 593
 594 (defun lsdb-mode-add-entry (entry-name)
 595   "Add an entry on the current line."
 596   (interactive "sEntry name: ")
 597   (beginning-of-line)
 598   (unless (symbolp entry-name)
 599     (setq entry-name (intern (downcase entry-name))))
 600   (when (assq entry-name (cdr (get-text-property (point) 'lsdb-record)))
 601     (error "The entry already exists"))
 602   (let ((marker (point-marker)))
 603     (lsdb-edit-form
 604      nil "Editing the entry."
 605      `(lambda (form)
 606         (when form
 607           (save-excursion
 608             (set-buffer lsdb-buffer-name)
 609             (goto-char ,marker)
 610             (beginning-of-line)
 611             (let* ((record (get-text-property (point) 'lsdb-record))
 612                    (inhibit-read-only t)
 613                    buffer-read-only)
 614               (setcdr record (cons (cons ',entry-name form) (cdr record)))
 615               (lsdb-puthash (car record) (cdr record)
 616                             lsdb-hash-table)
 617               (setq lsdb-hash-table-is-dirty t)
 618               (beginning-of-line)
 619               (add-text-properties
 620                (point)
 621                (progn
 622                  (lsdb-insert-entry (cons ',entry-name form))
 623                  (point))
 624                (list 'lsdb-record record)))))))))
 625
 626 (defun lsdb-mode-delete-entry (&optional entry-name dont-update)
 627   "Delete the entry on the current line."
 628   (interactive)
 629   (let ((record (get-text-property (point) 'lsdb-record))
 630         entry)
 631     (or entry-name
 632         (setq entry-name (lsdb-current-entry)))
 633     (setq entry (assq (intern (downcase entry-name)) (cdr record)))
 634     (when (and entry
 635                (not dont-update))
 636       (setcdr record (delq entry (cdr record)))
 637       (lsdb-puthash (car record) (cdr record)
 638                     lsdb-hash-table)
 639       (setq lsdb-hash-table-is-dirty t))
 640     (save-restriction
 641       (lsdb-narrow-to-record)
 642       (let ((case-fold-search t)
 643             (inhibit-read-only t)
 644             buffer-read-only)
 645         (goto-char (point-min))
 646         (if (re-search-forward
 647              (concat "^\t" (or entry-name
 648                                (lsdb-current-entry))
 649                      ":")
 650              nil t)
 651             (delete-region (match-beginning 0)
 652                            (if (re-search-forward
 653                                 "^\t[^\t][^:]+:" nil t)
 654                                (match-beginning 0)
 655                              (point-max))))))))
 656
 657 (defun lsdb-mode-edit-entry ()
 658   "Edit the entry on the current line."
 659   (interactive)
 660   (let* ((record (get-text-property (point) 'lsdb-record))
 661          (entry-name (intern (downcase (lsdb-current-entry))))
 662          (entry (assq entry-name (cdr record)))
 663          (marker (point-marker)))
 664     (lsdb-edit-form
 665      (cdr entry) "Editing the entry."
 666      `(lambda (form)
 667         (unless (equal form ',entry-name)
 668           (save-excursion
 669             (set-buffer lsdb-buffer-name)
 670             (goto-char ,marker)
 671             (let* ((record (get-text-property (point) 'lsdb-record))
 672                    (entry (assq ',entry-name (cdr record)))
 673                    (inhibit-read-only t)
 674                    buffer-read-only)
 675               (setcdr entry form)
 676               (setq lsdb-hash-table-is-dirty t)
 677               (lsdb-mode-delete-entry (symbol-name ',entry-name) t)
 678               (beginning-of-line)
 679               (add-text-properties
 680                (point)
 681                (progn
 682                  (lsdb-insert-entry (cons ',entry-name form))
 683                  (point))
 684                (list 'lsdb-record record)))))))))
 685
 686 (defun lsdb-mode-save ()
 687   (interactive)
 688   (if (and lsdb-hash-table-is-dirty
 689            (or (interactive-p)
 690                (y-or-n-p "Save the LSDB now?")))
 691       (lsdb-save-file lsdb-file lsdb-hash-table)))
 692
 693 ;;;_ : Edit Forms -- stolen (and renamed) from gnus-eform.el
 694 (defvar lsdb-edit-form-buffer "*LSDB edit form*")
 695 (defvar lsdb-edit-form-done-function nil)
 696 (defvar lsdb-previous-window-configuration nil)
 697
 698 (defvar lsdb-edit-form-mode-map
 699   (let ((keymap (make-sparse-keymap)))
 700     (set-keymap-parent keymap emacs-lisp-mode-map)
 701     (define-key keymap "\C-c\C-c" 'lsdb-edit-form-done)
 702     (define-key keymap "\C-c\C-k" 'lsdb-edit-form-exit)
 703     keymap)
 704   "Edit form's keymap.")
 705
 706 (defun lsdb-edit-form-mode ()
 707   "Major mode for editing forms.
 708 It is a slightly enhanced emacs-lisp-mode.
 709
 710 \\{lsdb-edit-form-mode-map}"
 711   (interactive)
 712   (kill-all-local-variables)
 713   (setq major-mode 'lsdb-edit-form-mode
 714         mode-name "LSDB Edit Form")
 715   (use-local-map lsdb-edit-form-mode-map)
 716   (make-local-variable 'lsdb-edit-form-done-function)
 717   (make-local-variable 'lsdb-previous-window-configuration)
 718   (run-hooks 'lsdb-edit-form-mode-hook))
 719
 720 (defun lsdb-edit-form (form documentation exit-func)
 721   "Edit FORM in a new buffer.
 722 Call EXIT-FUNC on exit.  Display DOCUMENTATION in the beginning
 723 of the buffer."
 724   (let ((window-configuration
 725          (current-window-configuration)))
 726     (switch-to-buffer (get-buffer-create lsdb-edit-form-buffer))
 727     (lsdb-edit-form-mode)
 728     (setq lsdb-previous-window-configuration window-configuration
 729           lsdb-edit-form-done-function exit-func)
 730     (erase-buffer)
 731     (insert documentation)
 732     (unless (bolp)
 733       (insert "\n"))
 734     (goto-char (point-min))
 735     (while (not (eobp))
 736       (insert ";;; ")
 737       (forward-line 1))
 738     (insert ";; Type `C-c C-c' after you've finished editing.\n")
 739     (insert "\n")
 740     (let ((p (point)))
 741       (pp form (current-buffer))
 742       (insert "\n")
 743       (goto-char p))))
 744
 745 (defun lsdb-edit-form-done ()
 746   "Update changes and kill the current buffer."
 747   (interactive)
 748   (goto-char (point-min))
 749   (let ((form (condition-case nil
 750                   (read (current-buffer))
 751                 (end-of-file nil)))
 752         (func lsdb-edit-form-done-function))
 753     (lsdb-edit-form-exit)
 754     (funcall func form)))
 755
 756 (defun lsdb-edit-form-exit ()
 757   "Kill the current buffer."
 758   (interactive)
 759   (let ((window-configuration lsdb-previous-window-configuration))
 760     (kill-buffer (current-buffer))
 761     (set-window-configuration window-configuration)))
 762
 763 ;;;_. Interface to Semi-gnus
 764 ;;;###autoload
 765 (defun lsdb-gnus-insinuate ()
 766   "Call this function to hook LSDB into Semi-gnus."
 767   (add-hook 'gnus-article-prepare-hook 'lsdb-gnus-update-record)
 768   (add-hook 'gnus-save-newsrc-hook 'lsdb-mode-save))
 769
 770 (defvar gnus-current-headers)
 771 (defun lsdb-gnus-update-record ()
 772   (let ((entity gnus-current-headers)
 773         records)
 774     (with-temp-buffer
 775       (set-buffer-multibyte nil)
 776       (buffer-disable-undo)
 777       (mime-insert-entity entity)
 778       (setq records (lsdb-update-records))
 779       (when records
 780         (lsdb-display-record (car records))))))
 781
 782 ;;;_. Interface to Wanderlust
 783 (defun lsdb-wl-insinuate ()
 784   "Call this function to hook LSDB into Wanderlust."
 785   (add-hook 'wl-message-redisplay-hook 'lsdb-wl-update-record)
 786   (add-hook 'wl-summary-exit-hook 'lsdb-wl-hide-buffer)
 787   (add-hook 'wl-exit-hook 'lsdb-mode-save))
 788
 789 (defun lsdb-wl-update-record ()
 790   (save-excursion
 791     (set-buffer (wl-message-get-original-buffer))
 792     (let ((records (lsdb-update-records)))
 793       (when records
 794         (lsdb-display-record (car records))))))
 795
 796 (defun lsdb-wl-hide-buffer ()
 797   (let ((window (get-buffer-window lsdb-buffer-name)))
 798     (if window
 799         (delete-window window))))
 800
 801 ;;;_. X-Face Rendering
 802 (defun lsdb-expose-x-face ()
 803   (let* ((record (get-text-property (point-min) 'lsdb-record))
 804          (x-face (cdr (assq 'x-face (cdr record)))))
 805     (when (and lsdb-insert-x-face-function
 806                x-face)
 807       (goto-char (point-min))
 808       (end-of-line)
 809       (insert (propertize "\r" 'invisible t) " ")
 810       (while x-face
 811         (funcall lsdb-insert-x-face-function (pop x-face))))))
 812
 813 ;; stolen (and renamed) from gnus-summary-x-face.el written by Akihiro Arisawa.
 814 (defvar lsdb-x-face-scale-factor 0.5
 815   "A number of scale factor used to scale down X-face image.
 816 See also `x-face-scale-factor'.")
 817
 818 (defun lsdb-insert-x-face-with-x-face-e21 (x-face)
 819   (require 'x-face-e21)
 820   (insert-image (x-face-create-image
 821                  x-face :scale-factor lsdb-x-face-scale-factor)))
 822
 823 (provide 'lsdb)
 824
 825 ;;;_* Local emacs vars.
 826 ;;; The following `outline-layout' local variable setting:
 827 ;;;  - closes all topics from the first topic to just before the third-to-last,
 828 ;;;  - shows the children of the third to last (config vars)
 829 ;;;  - and the second to last (code section),
 830 ;;;  - and closes the last topic (this local-variables section).
 831 ;;;Local variables:
 832 ;;;outline-layout: (0 : -1 -1 0)
 833 ;;;End:
 834
 835 ;;; lsdb.el ends here