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     (if (>= (lsdb-entry-score entry) 0)
 489         (insert "\t" entry-name ": "
 490                 (if (listp (cdr entry))
 491                     (mapconcat
 492                      #'identity (cdr entry)
 493                      (if (eq ?, (nth 2 (assq (car entry)
 494                                              lsdb-entry-type-alist)))
 495                          ", "
 496                        "\n\t\t"))
 497                   (cdr entry))
 498                 "\n"))))
 499
 500 (defun lsdb-print-record (record)
 501   (insert (car record) "\n")
 502   (let ((entries
 503          (sort (copy-sequence (cdr record))
 504                (lambda (entry1 entry2)
 505                  (> (lsdb-entry-score entry1) (lsdb-entry-score entry2))))))
 506     (while entries
 507       (lsdb-insert-entry (car entries))
 508       (setq entries (cdr entries)))))
 509
 510 ;;;_. Completion
 511 (defvar lsdb-last-completion nil)
 512 (defvar lsdb-last-candidates nil)
 513 (defvar lsdb-last-candidates-pointer nil)
 514
 515 (defun lsdb-complete-name ()
 516   "Complete the user full-name or net-address before point"
 517   (interactive)
 518   (lsdb-maybe-load-file)
 519   (let* ((start
 520           (save-excursion
 521             (re-search-backward "\\(\\`\\|[\n:,]\\)[ \t]*")
 522             (goto-char (match-end 0))
 523             (point)))
 524          pattern
 525          (case-fold-search t)
 526          (completion-ignore-case t))
 527     (unless (eq last-command this-command)
 528       (setq lsdb-last-candidates nil
 529             lsdb-last-candidates-pointer nil
 530             lsdb-last-completion (buffer-substring start (point))
 531             pattern (concat "\\<" lsdb-last-completion))
 532       (lsdb-maphash
 533        (lambda (key value)
 534          (let ((net (cdr (assq 'net value))))
 535            (if (string-match pattern key)
 536                (setq lsdb-last-candidates
 537                      (nconc lsdb-last-candidates
 538                             (mapcar (lambda (address)
 539                                       (if (equal key address)
 540                                           key
 541                                         (concat key " <" address ">")))
 542                                     net)))
 543              (while net
 544                (if (string-match pattern (car net))
 545                    (push (car net) lsdb-last-candidates))
 546                (setq net (cdr net))))))
 547        lsdb-hash-table))
 548     (unless lsdb-last-candidates-pointer
 549       (setq lsdb-last-candidates-pointer lsdb-last-candidates))
 550     (when lsdb-last-candidates-pointer
 551       (delete-region start (point))
 552       (insert (pop lsdb-last-candidates-pointer)))))
 553
 554 ;;;_. Major Mode (`lsdb-mode') Implementation
 555 (defvar lsdb-mode-map
 556   (let ((keymap (make-sparse-keymap)))
 557     (define-key keymap "a" 'lsdb-mode-add-entry)
 558     (define-key keymap "d" 'lsdb-mode-delete-entry)
 559     (define-key keymap "e" 'lsdb-mode-edit-entry)
 560     (define-key keymap "s" 'lsdb-mode-save)
 561     (define-key keymap "q" 'lsdb-mode-quit-window)
 562     (define-key keymap "g" 'lsdb-mode-lookup)
 563     (define-key keymap "p" 'lsdb-mode-previous-record)
 564     (define-key keymap "n" 'lsdb-mode-next-record)
 565     (define-key keymap " " 'scroll-up)
 566     (define-key keymap [delete] 'scroll-down)
 567     (define-key keymap "\177" 'scroll-down)
 568     (define-key keymap [backspace] 'scroll-down)
 569     keymap)
 570   "LSDB's keymap.")
 571
 572 (define-derived-mode lsdb-mode fundamental-mode "LSDB"
 573   "Major mode for browsing LSDB records."
 574   (setq buffer-read-only t)
 575   (if (featurep 'xemacs)
 576       ;; In XEmacs, setting `font-lock-defaults' only affects on
 577       ;; `find-file-hooks'.
 578       (font-lock-set-defaults)
 579     (set (make-local-variable 'font-lock-defaults)
 580          '(lsdb-font-lock-keywords t))))
 581
 582 (defun lsdb-narrow-to-record ()
 583   (narrow-to-region
 584    (previous-single-property-change (point) 'lsdb-record nil (point-min))
 585    (next-single-property-change (point) 'lsdb-record nil (point-max)))
 586   (goto-char (point-min)))
 587
 588 (defun lsdb-current-record ()
 589   (let ((record (get-text-property (point) 'lsdb-record)))
 590     (unless record
 591       (error "There is nothing to follow here"))
 592     record))
 593
 594 (defun lsdb-current-entry ()
 595   (save-excursion
 596     (beginning-of-line)
 597     (if (looking-at "^[^\t]")
 598         (let ((record (lsdb-current-record))
 599               (completion-ignore-case t))
 600           (completing-read
 601            "Which entry to modify: "
 602            (mapcar (lambda (entry)
 603                      (list (capitalize (symbol-name (car entry)))))
 604                    (cdr record))))
 605       (end-of-line)
 606       (re-search-backward "^\t\\([^\t][^:]+\\):")
 607       (match-string 1))))
 608
 609 (defun lsdb-mode-add-entry (entry-name)
 610   "Add an entry on the current line."
 611   (interactive
 612    (let ((completion-ignore-case t))
 613      (list (completing-read "Entry name: " lsdb-known-entry-names))))
 614   (beginning-of-line)
 615   (unless (symbolp entry-name)
 616     (setq entry-name (intern (downcase entry-name))))
 617   (when (assq entry-name (cdr (lsdb-current-record)))
 618     (error "The entry already exists"))
 619   (let ((marker (point-marker)))
 620     (lsdb-edit-form
 621      nil "Editing the entry."
 622      `(lambda (form)
 623         (when form
 624           (save-excursion
 625             (set-buffer lsdb-buffer-name)
 626             (goto-char ,marker)
 627             (let ((record (lsdb-current-record))
 628                   (inhibit-read-only t)
 629                   buffer-read-only)
 630               (setcdr record (cons (cons ',entry-name form) (cdr record)))
 631               (lsdb-puthash (car record) (cdr record)
 632                             lsdb-hash-table)
 633               (setq lsdb-hash-table-is-dirty t)
 634               (beginning-of-line 2)
 635               (add-text-properties
 636                (point)
 637                (progn
 638                  (lsdb-insert-entry (cons ',entry-name form))
 639                  (point))
 640                (list 'lsdb-record record)))))))))
 641
 642 (defun lsdb-mode-delete-entry (&optional entry-name dont-update)
 643   "Delete the entry on the current line."
 644   (interactive)
 645   (let ((record (lsdb-current-record))
 646         entry)
 647     (or entry-name
 648         (setq entry-name (lsdb-current-entry)))
 649     (setq entry (assq (intern (downcase entry-name)) (cdr record)))
 650     (when (and entry
 651                (not dont-update))
 652       (setcdr record (delq entry (cdr record)))
 653       (lsdb-puthash (car record) (cdr record)
 654                     lsdb-hash-table)
 655       (setq lsdb-hash-table-is-dirty t))
 656     (save-restriction
 657       (lsdb-narrow-to-record)
 658       (let ((case-fold-search t)
 659             (inhibit-read-only t)
 660             buffer-read-only)
 661         (goto-char (point-min))
 662         (if (re-search-forward
 663              (concat "^\t" (or entry-name
 664                                (lsdb-current-entry))
 665                      ":")
 666              nil t)
 667             (delete-region (match-beginning 0)
 668                            (if (re-search-forward
 669                                 "^\t[^\t][^:]+:" nil t)
 670                                (match-beginning 0)
 671                              (point-max))))))))
 672
 673 (defun lsdb-mode-edit-entry ()
 674   "Edit the entry on the current line."
 675   (interactive)
 676   (let* ((record (lsdb-current-record))
 677          (entry-name (intern (downcase (lsdb-current-entry))))
 678          (entry (assq entry-name (cdr record)))
 679          (marker (point-marker)))
 680     (lsdb-edit-form
 681      (cdr entry) "Editing the entry."
 682      `(lambda (form)
 683         (unless (equal form ',(cdr entry))
 684           (save-excursion
 685             (set-buffer lsdb-buffer-name)
 686             (goto-char ,marker)
 687             (let* ((record (lsdb-current-record))
 688                    (entry (assq ',entry-name (cdr record)))
 689                    (inhibit-read-only t)
 690                    buffer-read-only)
 691               (setcdr entry form)
 692               (setq lsdb-hash-table-is-dirty t)
 693               (lsdb-mode-delete-entry (symbol-name ',entry-name) t)
 694               (beginning-of-line)
 695               (add-text-properties
 696                (point)
 697                (progn
 698                  (lsdb-insert-entry (cons ',entry-name form))
 699                  (point))
 700                (list 'lsdb-record record)))))))))
 701
 702 (defun lsdb-mode-save ()
 703   "Save LSDB hash table into `lsdb-file'."
 704   (interactive)
 705   (if (not lsdb-hash-table-is-dirty)
 706       (message "(No changes need to be saved)")
 707     (when (or (interactive-p)
 708               (y-or-n-p "Save the LSDB now?"))
 709       (lsdb-save-file lsdb-file lsdb-hash-table)
 710       (setq lsdb-hash-table-is-dirty nil)
 711       (message "The LSDB was saved successfully."))))
 712
 713 (if (commandp 'quit-window)
 714     (defalias 'lsdb-mode-quit-window 'quit-window)
 715   (defun lsdb-mode-quit-window ()
 716     "Quit the current buffer."
 717     (interactive)
 718     (if (one-window-p)
 719         (bury-buffer)
 720       (delete-window))))
 721
 722 (defun lsdb-lookup-records (regexp &optional entry-name)
 723   (let (records)
 724     (lsdb-maphash
 725      (if entry-name
 726          (progn
 727            (unless (symbolp entry-name)
 728              (setq entry-name (intern (downcase entry-name))))
 729            (lambda (key value)
 730              (let ((entry (cdr (assq entry-name value)))
 731                    found)
 732                (unless (listp entry)
 733                  (setq entry (list entry)))
 734                (while (and (not found) entry)
 735                  (if (string-match regexp (pop entry))
 736                      (setq found t)))
 737                (if found
 738                    (push (cons key value) records)))))
 739        (lambda (key value)
 740          (if (string-match regexp key)
 741              (push (cons key value) records))))
 742      lsdb-hash-table)
 743     records))
 744
 745 (defvar lsdb-mode-lookup-history nil)
 746
 747 (defun lsdb-mode-lookup (regexp &optional entry-name)
 748   "Display all entries in the LSDB matching the REGEXP."
 749   (interactive
 750    (let* ((completion-ignore-case t)
 751           (entry-name
 752            (if current-prefix-arg
 753                (completing-read "Entry name: "
 754                                 lsdb-known-entry-names))))
 755      (list
 756       (read-from-minibuffer
 757        (if entry-name
 758            (format "Search records `%s' regexp: " entry-name)
 759          "Search records regexp: ")
 760        nil nil nil 'lsdb-mode-lookup-history)
 761       entry-name)))
 762   (lsdb-maybe-load-file)
 763   (let ((records (lsdb-lookup-records regexp entry-name)))
 764     (if records
 765         (lsdb-display-records records))))
 766
 767 ;;;###autoload
 768 (defalias 'lsdb 'lsdb-mode-lookup)
 769
 770 (defun lsdb-mode-next-record (&optional arg)
 771   "Go to the next record."
 772   (interactive "p")
 773   (unless arg                           ;called noninteractively?
 774     (setq arg 1))
 775   (if (< arg 0)
 776       (lsdb-mode-previous-record (- arg))
 777     (while (> arg 0)
 778       (goto-char (next-single-property-change
 779                   (point) 'lsdb-record nil (point-max)))
 780       (setq arg (1- arg)))))
 781
 782 (defun lsdb-mode-previous-record (&optional arg)
 783   "Go to the previous record."
 784   (interactive "p")
 785   (unless arg                           ;called noninteractively?
 786     (setq arg 1))
 787   (if (< arg 0)
 788       (lsdb-mode-next-record (- arg))
 789     (while (> arg 0)
 790       (goto-char (previous-single-property-change
 791                   (point) 'lsdb-record nil (point-min)))
 792       (setq arg (1- arg)))))
 793
 794 ;;;_ : Edit Forms -- stolen (and renamed) from gnus-eform.el
 795 (defvar lsdb-edit-form-buffer "*LSDB edit form*")
 796 (defvar lsdb-edit-form-done-function nil)
 797 (defvar lsdb-previous-window-configuration nil)
 798
 799 (defvar lsdb-edit-form-mode-map
 800   (let ((keymap (make-sparse-keymap)))
 801     (set-keymap-parent keymap emacs-lisp-mode-map)
 802     (define-key keymap "\C-c\C-c" 'lsdb-edit-form-done)
 803     (define-key keymap "\C-c\C-k" 'lsdb-edit-form-exit)
 804     keymap)
 805   "Edit form's keymap.")
 806
 807 (defun lsdb-edit-form-mode ()
 808   "Major mode for editing forms.
 809 It is a slightly enhanced emacs-lisp-mode.
 810
 811 \\{lsdb-edit-form-mode-map}"
 812   (interactive)
 813   (kill-all-local-variables)
 814   (setq major-mode 'lsdb-edit-form-mode
 815         mode-name "LSDB Edit Form")
 816   (use-local-map lsdb-edit-form-mode-map)
 817   (make-local-variable 'lsdb-edit-form-done-function)
 818   (make-local-variable 'lsdb-previous-window-configuration)
 819   (run-hooks 'lsdb-edit-form-mode-hook))
 820
 821 (defun lsdb-edit-form (form documentation exit-func)
 822   "Edit FORM in a new buffer.
 823 Call EXIT-FUNC on exit.  Display DOCUMENTATION in the beginning
 824 of the buffer."
 825   (let ((window-configuration
 826          (current-window-configuration)))
 827     (switch-to-buffer (get-buffer-create lsdb-edit-form-buffer))
 828     (lsdb-edit-form-mode)
 829     (setq lsdb-previous-window-configuration window-configuration
 830           lsdb-edit-form-done-function exit-func)
 831     (erase-buffer)
 832     (insert documentation)
 833     (unless (bolp)
 834       (insert "\n"))
 835     (goto-char (point-min))
 836     (while (not (eobp))
 837       (insert ";;; ")
 838       (forward-line 1))
 839     (insert ";; Type `C-c C-c' after you've finished editing.\n")
 840     (insert "\n")
 841     (let ((p (point)))
 842       (pp form (current-buffer))
 843       (insert "\n")
 844       (goto-char p))))
 845
 846 (defun lsdb-edit-form-done ()
 847   "Update changes and kill the current buffer."
 848   (interactive)
 849   (goto-char (point-min))
 850   (let ((form (condition-case nil
 851                   (read (current-buffer))
 852                 (end-of-file nil)))
 853         (func lsdb-edit-form-done-function))
 854     (lsdb-edit-form-exit)
 855     (funcall func form)))
 856
 857 (defun lsdb-edit-form-exit ()
 858   "Kill the current buffer."
 859   (interactive)
 860   (let ((window-configuration lsdb-previous-window-configuration))
 861     (kill-buffer (current-buffer))
 862     (set-window-configuration window-configuration)))
 863
 864 ;;;_. Interface to Semi-gnus
 865 ;;;###autoload
 866 (defun lsdb-gnus-insinuate ()
 867   "Call this function to hook LSDB into Semi-gnus."
 868   (add-hook 'gnus-article-prepare-hook 'lsdb-gnus-update-record)
 869   (add-hook 'gnus-save-newsrc-hook 'lsdb-mode-save))
 870
 871 (defvar gnus-current-headers)
 872 (defun lsdb-gnus-update-record ()
 873   (let ((entity gnus-current-headers)
 874         records)
 875     (with-temp-buffer
 876       (set-buffer-multibyte nil)
 877       (buffer-disable-undo)
 878       (mime-insert-entity entity)
 879       (setq records (lsdb-update-records))
 880       (when records
 881         (lsdb-display-record (car records))))))
 882
 883 ;;;_. Interface to Wanderlust
 884 ;;;###autoload
 885 (defun lsdb-wl-insinuate ()
 886   "Call this function to hook LSDB into Wanderlust."
 887   (add-hook 'wl-message-redisplay-hook 'lsdb-wl-update-record)
 888   (add-hook 'wl-summary-exit-hook 'lsdb-wl-hide-buffer)
 889   (add-hook 'wl-exit-hook 'lsdb-mode-save))
 890
 891 (defun lsdb-wl-update-record ()
 892   (save-excursion
 893     (set-buffer (wl-message-get-original-buffer))
 894     (let ((records (lsdb-update-records)))
 895       (when records
 896         (lsdb-display-record (car records))))))
 897
 898 (defun lsdb-wl-hide-buffer ()
 899   (let ((window (get-buffer-window lsdb-buffer-name)))
 900     (if window
 901         (delete-window window))))
 902
 903 ;;;_. Interface to MU-CITE
 904 (defun lsdb-mu-attribution (address)
 905   "Extract attribute information from LSDB."
 906   (let ((records
 907          (lsdb-lookup-records (concat "\\<" address "\\>") 'net)))
 908     (if records
 909         (cdr (assq 'attribution (cdr (car records)))))))
 910
 911 (defun lsdb-mu-set-attribution (attribution address)
 912   "Add attribute information to LSDB."
 913   (let ((records
 914          (lsdb-lookup-records (concat "\\<" address "\\>") 'net))
 915         entry)
 916     (when records
 917       (setq entry (assq 'attribution (cdr (car records))))
 918       (if entry
 919           (setcdr entry attribution)
 920         (setcdr (car records) (cons (cons 'attribution attribution)
 921                                     (cdr (car records))))
 922         (lsdb-puthash (car (car records)) (cdr (car records))
 923                       lsdb-hash-table)
 924         (setq lsdb-hash-table-is-dirty t)))))
 925
 926 (defun lsdb-mu-get-prefix-method ()
 927   "A mu-cite method to return a prefix from LSDB or \">\".
 928 If an `attribution' value is found in LSDB, the value is returned.
 929 Otherwise \">\" is returned."
 930   (or (lsdb-mu-attribution (mu-cite-get-value 'address))
 931       ">"))
 932
 933 (defvar minibuffer-allow-text-properties)
 934
 935 (defvar lsdb-mu-history nil)
 936
 937 (defun lsdb-mu-get-prefix-register-method ()
 938   "A mu-cite method to return a prefix from LSDB or register it.
 939 If an `attribution' value is found in LSDB, the value is returned.
 940 Otherwise the function requests a prefix from a user.  The prefix will
 941 be registered to LSDB if the user wants it."
 942   (let ((address (mu-cite-get-value 'address)))
 943     (or (lsdb-mu-attribution address)
 944         (let* (minibuffer-allow-text-properties
 945                (result (read-string "Citation name? "
 946                                     (or (mu-cite-get-value 'x-attribution)
 947                                         (mu-cite-get-value 'full-name))
 948                                     'lsdb-mu-history)))
 949           (if (and (not (string-equal result ""))
 950                    (y-or-n-p (format "Register \"%s\"? " result)))
 951               (lsdb-mu-set-attribution result address))
 952           result))))
 953
 954 (defun lsdb-mu-get-prefix-register-verbose-method ()
 955   "A mu-cite method to return a prefix using LSDB.
 956
 957 In this method, a user must specify a prefix unconditionally.  If an
 958 `attribution' value is found in LSDB, the value is used as a initial
 959 value to input the prefix.  The prefix will be registered to LSDB if
 960 the user wants it."
 961   (let* ((address (mu-cite-get-value 'address))
 962          (attribution (lsdb-mu-attribution address))
 963          minibuffer-allow-text-properties
 964          (result (read-string "Citation name? "
 965                               (or attribution
 966                                   (mu-cite-get-value 'x-attribution)
 967                                   (mu-cite-get-value 'full-name))
 968                               'lsdb-mu-history)))
 969     (if (and (not (string-equal result ""))
 970              (not (string-equal result attribution))
 971              (y-or-n-p (format "Register \"%s\"? " result)))
 972         (lsdb-mu-set-attribution result address))
 973     result))
 974
 975 (defvar mu-cite-methods-alist)
 976 ;;;###autoload
 977 (defun lsdb-mu-insinuate ()
 978   (add-hook 'mu-cite-instantiation-hook
 979             (lambda ()
 980               (setq mu-cite-methods-alist
 981                     (nconc
 982                      mu-cite-methods-alist
 983                      (list
 984                       (cons 'lsdb-prefix
 985                             #'lsdb-mu-get-prefix-method)
 986                       (cons 'lsdb-prefix-register
 987                             #'lsdb-mu-get-prefix-register-method)
 988                       (cons 'lsdb-prefix-register-verbose
 989                             #'lsdb-mu-get-prefix-register-verbose-method)))))))
 990
 991 ;;;_. X-Face Rendering
 992 (defun lsdb-expose-x-face ()
 993   (let* ((record (get-text-property (point-min) 'lsdb-record))
 994          (x-face (cdr (assq 'x-face (cdr record))))
 995          (limit "\r"))
 996     (when (and lsdb-insert-x-face-function
 997                x-face)
 998       (goto-char (point-min))
 999       (end-of-line)
1000       (if (fboundp 'propertize)
1001           (insert (propertize limit 'invisible t) " ")
1002         (put-text-property 0 1 'invisible t limit)
1003         (insert limit " "))
1004       (while x-face
1005         (funcall lsdb-insert-x-face-function (pop x-face))))))
1006
1007 ;; stolen (and renamed) from gnus-summary-x-face.el written by Akihiro Arisawa.
1008 (defvar lsdb-x-face-scale-factor 0.5
1009   "A number of scale factor used to scale down X-face image.
1010 See also `x-face-scale-factor'.")
1011
1012 (defun lsdb-insert-x-face-with-x-face-e21 (x-face)
1013   (require 'x-face-e21)
1014   (insert-image (x-face-create-image
1015                  x-face :scale-factor lsdb-x-face-scale-factor)))
1016
1017 (defun lsdb-insert-x-face-with-xemacs-glyph (x-face)
1018   (let ((glyph
1019          (make-glyph
1020           (vector 'xface :data (concat "X-Face: " x-face)))))
1021     (if glyph
1022         (set-extent-end-glyph
1023          (make-extent (point) (point))
1024          glyph))))
1025
1026 (require 'product)
1027 (provide 'lsdb)
1028
1029 (product-provide 'lsdb
1030   (product-define "LSDB" nil '(0 1)))
1031
1032 ;;;_* Local emacs vars.
1033 ;;; The following `outline-layout' local variable setting:
1034 ;;;  - closes all topics from the first topic to just before the third-to-last,
1035 ;;;  - shows the children of the third to last (config vars)
1036 ;;;  - and the second to last (code section),
1037 ;;;  - and closes the last topic (this local-variables section).
1038 ;;;Local variables:
1039 ;;;outline-layout: (0 : -1 -1 0)
1040 ;;;End:
1041
1042 ;;; lsdb.el ends here