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           (let ((buffer (find-file-noselect file)))
 263             (unwind-protect
 264                 (save-excursion
 265                   (set-buffer buffer)
 266                   (re-search-forward "^#s")
 267                   (beginning-of-line)
 268                   (read (point-min-marker)))
 269               (kill-buffer buffer)))))
 270     (invalid-read-syntax
 271     (defun lsdb-load-file (file)
 272       "Read the contents of FILE into a hash table."
 273       (let* ((plist
 274               (with-temp-buffer
 275                 (insert-file-contents file)
 276                 (save-excursion
 277                   (re-search-forward "^#s")
 278                   (replace-match "")
 279                   (beginning-of-line)
 280                   (cdr (read (point-marker))))))
 281              (size (plist-get plist 'size))
 282              (data (plist-get plist 'data))
 283              (hash-table (lsdb-make-hash-table :size size :test 'equal)))
 284         (while data
 285           (lsdb-puthash (pop data) (pop data) hash-table))
 286         hash-table)))))
 287
 288 (defun lsdb-save-file (file hash-table)
 289   "Write the entries within HASH-TABLE into FILE."
 290   (let ((coding-system-for-write lsdb-file-coding-system))
 291     (with-temp-file file
 292       (if (and (or (featurep 'mule)
 293                    (featurep 'file-coding))
 294                lsdb-file-coding-system)
 295           (insert ";;; -*- coding: "
 296                   (if (symbolp lsdb-file-coding-system)
 297                       (symbol-name lsdb-file-coding-system)
 298                     ;; XEmacs
 299                     (coding-system-name lsdb-file-coding-system))
 300                   " -*-\n"))
 301       (insert "#s(hash-table size "
 302               (number-to-string (lsdb-hash-table-size hash-table))
 303               " test equal data (")
 304       (lsdb-maphash
 305        (lambda (key value)
 306          (insert (prin1-to-string key) " " (prin1-to-string value) " "))
 307        hash-table)
 308       (insert "))"))))
 309
 310 ;;;_. Mail Header Extraction
 311 (defun lsdb-fetch-field-bodies (regexp)
 312   (save-excursion
 313     (goto-char (point-min))
 314     (let ((case-fold-search t)
 315           field-bodies)
 316       (while (re-search-forward (concat "^\\(" regexp "\\):[ \t]*")
 317                                 nil t)
 318         (push (funcall lsdb-decode-field-body-function
 319                              (buffer-substring (point) (std11-field-end))
 320                              (match-string 1))
 321                     field-bodies))
 322       (nreverse field-bodies))))
 323
 324 (defun lsdb-canonicalize-spaces-and-dots (string)
 325   (while (string-match "  +\\|[\f\t\n\r\v]+\\|\\." string)
 326     (setq string (replace-match " " nil t string)))
 327   string)
 328
 329 (defun lsdb-extract-address-components (string)
 330   (let ((components (std11-extract-address-components string)))
 331     (if (nth 1 components)
 332         (if (car components)
 333             (list (nth 1 components)
 334                   (funcall lsdb-canonicalize-full-name-function
 335                            (car components)))
 336           (list (nth 1 components) (nth 1 components))))))
 337
 338 ;; stolen (and renamed) from nnheader.el
 339 (defun lsdb-decode-field-body (field-body field-name
 340                                           &optional mode max-column)
 341   (let ((multibyte enable-multibyte-characters))
 342     (unwind-protect
 343         (progn
 344           (set-buffer-multibyte t)
 345           (mime-decode-field-body field-body
 346                                   (if (stringp field-name)
 347                                       (intern (capitalize field-name))
 348                                     field-name)
 349                                   mode max-column))
 350       (set-buffer-multibyte multibyte))))
 351
 352 ;;;_. Record Management
 353 (defun lsdb-maybe-load-file ()
 354   (unless lsdb-hash-table
 355     (if (file-exists-p lsdb-file)
 356         (setq lsdb-hash-table (lsdb-load-file lsdb-file))
 357       (setq lsdb-hash-table (lsdb-make-hash-table :test 'equal)))))
 358
 359 (defun lsdb-update-record (sender &optional interesting)
 360   (let ((old (lsdb-gethash (nth 1 sender) lsdb-hash-table))
 361         (new (cons (cons 'net (list (car sender)))
 362                    interesting))
 363         merged
 364         record)
 365     (unless old
 366       (setq new (cons (cons 'creation-date (format-time-string "%Y-%m-%d"))
 367                       new)))
 368     (setq merged (lsdb-merge-record-entries old new)
 369           record (cons (nth 1 sender) merged))
 370     (unless (equal merged old)
 371       (let ((entry (assq 'last-modified (cdr record)))
 372             (last-modified (format-time-string "%Y-%m-%d")))
 373         (if entry
 374             (setcdr entry last-modified)
 375           (setcdr record (cons (cons 'last-modified last-modified)
 376                                (cdr record)))))
 377       (lsdb-puthash (car record) (cdr record)
 378                     lsdb-hash-table)
 379       (setq lsdb-hash-table-is-dirty t))
 380     record))
 381
 382 (defun lsdb-update-records ()
 383   (lsdb-maybe-load-file)
 384   (let (senders recipients interesting alist records bodies entry)
 385     (save-restriction
 386       (std11-narrow-to-header)
 387       (setq senders
 388             (delq nil (mapcar #'lsdb-extract-address-components
 389                               (lsdb-fetch-field-bodies
 390                                lsdb-sender-headers)))
 391             recipients
 392             (delq nil (mapcar #'lsdb-extract-address-components
 393                               (lsdb-fetch-field-bodies
 394                                lsdb-recipients-headers))))
 395       (setq alist lsdb-interesting-header-alist)
 396       (while alist
 397         (setq bodies
 398               (mapcar
 399                (lambda (field-body)
 400                  (if (and (nth 1 (car alist))
 401                           (string-match (nth 1 (car alist)) field-body))
 402                      (replace-match (nth 3 (car alist)) nil nil field-body)
 403                    field-body))
 404                (lsdb-fetch-field-bodies (car (car alist)))))
 405         (when bodies
 406           (setq entry (or (nth 2 (car alist))
 407                           'notes))
 408           (push (cons entry
 409                       (if (eq ?. (nth 2 (assq entry lsdb-entry-type-alist)))
 410                           (car bodies)
 411                         bodies))
 412                 interesting))
 413         (setq alist (cdr alist))))
 414     (if senders
 415         (setq records (list (lsdb-update-record (pop senders) interesting))))
 416     (setq alist (nconc senders recipients))
 417     (while alist
 418       (setq records (cons (lsdb-update-record (pop alist)) records)))
 419     (nreverse records)))
 420
 421 (defun lsdb-merge-record-entries (old new)
 422   (setq old (copy-sequence old))
 423   (while new
 424     (let ((entry (assq (car (car new)) old))
 425           list pointer)
 426       (if (null entry)
 427           (setq old (nconc old (list (car new))))
 428         (if (listp (cdr entry))
 429             (progn
 430               (setq list (cdr (car new)) pointer list)
 431               (while pointer
 432                 (if (member (car pointer) (cdr entry))
 433                     (setq list (delq (car pointer) list)))
 434                 (setq pointer (cdr pointer)))
 435               (setcdr entry (nconc (cdr entry) list)))
 436           (setcdr entry (cdr (car new))))))
 437     (setq new (cdr new)))
 438   old)
 439
 440 ;;;_. Display Management
 441 (defun lsdb-temp-buffer-show-function (buffer)
 442   (save-selected-window
 443     (let ((window (or (get-buffer-window lsdb-buffer-name)
 444                       (progn
 445                         (select-window (get-largest-window))
 446                         (split-window-vertically))))
 447           height)
 448       (set-window-buffer window buffer)
 449       (select-window window)
 450       (unless (pos-visible-in-window-p (point-max))
 451         (enlarge-window (- lsdb-window-max-height (window-height))))
 452       (shrink-window-if-larger-than-buffer)
 453       (if (> (setq height (window-height))
 454              lsdb-window-max-height)
 455           (shrink-window (- height lsdb-window-max-height))
 456           (shrink-window-if-larger-than-buffer)))))
 457
 458 (defun lsdb-display-record (record)
 459   "Display only one RECORD, then shrink the window as possible."
 460   (let ((temp-buffer-show-function
 461          (function lsdb-temp-buffer-show-function)))
 462     (lsdb-display-records (list record))))
 463
 464 (defun lsdb-display-records (records)
 465   (with-output-to-temp-buffer lsdb-buffer-name
 466     (set-buffer standard-output)
 467     (while records
 468       (save-restriction
 469         (narrow-to-region (point) (point))
 470         (funcall lsdb-print-record-function (car records))
 471         (add-text-properties (point-min) (point-max)
 472                              (list 'lsdb-record (car records)))
 473         (run-hooks 'lsdb-display-record-hook))
 474       (setq records (cdr records)))
 475     (lsdb-mode)))
 476
 477 (defsubst lsdb-entry-score (entry)
 478   (or (nth 1 (assq (car entry) lsdb-entry-type-alist)) 0))
 479
 480 (defun lsdb-insert-entry (entry)
 481   (insert "\t" (capitalize (symbol-name (car entry))) ": "
 482           (if (listp (cdr entry))
 483               (mapconcat
 484                #'identity (cdr entry)
 485                (if (eq ?, (nth 2 (assq (car entry) lsdb-entry-type-alist)))
 486                    ", "
 487                  "\n\t\t"))
 488             (cdr entry))
 489           "\n"))
 490
 491 (defun lsdb-print-record (record)
 492   (insert (car record) "\n")
 493   (let ((entries
 494          (sort (copy-sequence (cdr record))
 495                (lambda (entry1 entry2)
 496                  (> (lsdb-entry-score entry1) (lsdb-entry-score entry2))))))
 497     (while entries
 498       (if (>= (lsdb-entry-score (car entries)) 0)
 499           (lsdb-insert-entry (car entries)))
 500       (setq entries (cdr entries)))))
 501
 502 ;;;_. Completion
 503 (defvar lsdb-last-completion nil)
 504 (defvar lsdb-last-candidates nil)
 505 (defvar lsdb-last-candidates-pointer nil)
 506
 507 (defun lsdb-complete-name ()
 508   "Complete the user full-name or net-address before point"
 509   (interactive)
 510   (lsdb-maybe-load-file)
 511   (let* ((start
 512           (save-excursion
 513             (re-search-backward "\\(\\`\\|[\n:,]\\)[ \t]*")
 514             (goto-char (match-end 0))
 515             (point)))
 516          pattern
 517          (case-fold-search t)
 518          (completion-ignore-case t))
 519     (unless (eq last-command this-command)
 520       (setq lsdb-last-candidates nil
 521             lsdb-last-candidates-pointer nil
 522             lsdb-last-completion (buffer-substring start (point))
 523             pattern (concat "\\<" lsdb-last-completion))
 524       (lsdb-maphash
 525        (lambda (key value)
 526          (let ((net (cdr (assq 'net value))))
 527            (if (string-match pattern key)
 528                (setq lsdb-last-candidates
 529                      (nconc lsdb-last-candidates
 530                             (mapcar (lambda (address)
 531                                       (if (equal key address)
 532                                           key
 533                                         (concat key " <" address ">")))
 534                                     net)))
 535              (while net
 536                (if (string-match pattern (car net))
 537                    (push (car net) lsdb-last-candidates))
 538                (setq net (cdr net))))))
 539        lsdb-hash-table))
 540     (unless lsdb-last-candidates-pointer
 541       (setq lsdb-last-candidates-pointer lsdb-last-candidates))
 542     (when lsdb-last-candidates-pointer
 543       (delete-region start (point))
 544       (insert (pop lsdb-last-candidates-pointer)))))
 545
 546 ;;;_. Major Mode (`lsdb-mode') Implementation
 547 (defvar lsdb-mode-map
 548   (let ((keymap (make-sparse-keymap)))
 549     (define-key keymap "a" 'lsdb-mode-add-entry)
 550     (define-key keymap "d" 'lsdb-mode-delete-entry)
 551     (define-key keymap "e" 'lsdb-mode-edit-entry)
 552     (define-key keymap "s" 'lsdb-mode-save)
 553     (define-key keymap "q" 'lsdb-mode-quit-window)
 554     keymap)
 555   "LSDB's keymap.")
 556
 557 (if (commandp 'quit-window)
 558     (defalias 'lsdb-mode-quit-window 'quit-window)
 559   (defun lsdb-mode-quit-window ()
 560     (interactive)
 561     (if (one-window-p)
 562         (bury-buffer)
 563       (delete-window))))
 564
 565 (define-derived-mode lsdb-mode fundamental-mode "LSDB"
 566   "Major mode for browsing LSDB records."
 567   (setq buffer-read-only t)
 568   (if (featurep 'xemacs)
 569       ;; In XEmacs, setting `font-lock-defaults' only affects on
 570       ;; `find-file-hooks'.
 571       (font-lock-set-defaults)
 572     (set (make-local-variable 'font-lock-defaults)
 573          '(lsdb-font-lock-keywords t))))
 574
 575 (defun lsdb-narrow-to-record ()
 576   (narrow-to-region
 577    (or (previous-single-property-change (point) 'lsdb-record)
 578        (point-min))
 579    (or (next-single-property-change (point) 'lsdb-record)
 580        (point-max))))
 581
 582 (defun lsdb-current-entry ()
 583   (save-excursion
 584     (beginning-of-line)
 585     (if (looking-at "^[^\t]")
 586         (let ((record (get-text-property (point) 'lsdb-record))
 587               (completion-ignore-case t))
 588           (completing-read
 589            "Which entry to edit: "
 590            (mapcar (lambda (entry)
 591                      (list (capitalize (symbol-name (car entry)))))
 592                    (cdr record))))
 593       (end-of-line)
 594       (re-search-backward "^\t\\([^\t][^:]+\\):")
 595       (match-string 1))))
 596
 597 (defun lsdb-mode-add-entry (entry-name)
 598   "Add an entry on the current line."
 599   (interactive "sEntry name: ")
 600   (beginning-of-line)
 601   (unless (symbolp entry-name)
 602     (setq entry-name (intern (downcase entry-name))))
 603   (when (assq entry-name (cdr (get-text-property (point) 'lsdb-record)))
 604     (error "The entry already exists"))
 605   (let ((marker (point-marker)))
 606     (lsdb-edit-form
 607      nil "Editing the entry."
 608      `(lambda (form)
 609         (when form
 610           (save-excursion
 611             (set-buffer lsdb-buffer-name)
 612             (goto-char ,marker)
 613             (beginning-of-line)
 614             (let* ((record (get-text-property (point) 'lsdb-record))
 615                    (inhibit-read-only t)
 616                    buffer-read-only)
 617               (setcdr record (cons (cons ',entry-name form) (cdr record)))
 618               (lsdb-puthash (car record) (cdr record)
 619                             lsdb-hash-table)
 620               (setq lsdb-hash-table-is-dirty t)
 621               (beginning-of-line)
 622               (add-text-properties
 623                (point)
 624                (progn
 625                  (lsdb-insert-entry (cons ',entry-name form))
 626                  (point))
 627                (list 'lsdb-record record)))))))))
 628
 629 (defun lsdb-mode-delete-entry (&optional entry-name dont-update)
 630   "Delete the entry on the current line."
 631   (interactive)
 632   (let ((record (get-text-property (point) 'lsdb-record))
 633         entry)
 634     (or entry-name
 635         (setq entry-name (lsdb-current-entry)))
 636     (setq entry (assq (intern (downcase entry-name)) (cdr record)))
 637     (when (and entry
 638                (not dont-update))
 639       (setcdr record (delq entry (cdr record)))
 640       (lsdb-puthash (car record) (cdr record)
 641                     lsdb-hash-table)
 642       (setq lsdb-hash-table-is-dirty t))
 643     (save-restriction
 644       (lsdb-narrow-to-record)
 645       (let ((case-fold-search t)
 646             (inhibit-read-only t)
 647             buffer-read-only)
 648         (goto-char (point-min))
 649         (if (re-search-forward
 650              (concat "^\t" (or entry-name
 651                                (lsdb-current-entry))
 652                      ":")
 653              nil t)
 654             (delete-region (match-beginning 0)
 655                            (if (re-search-forward
 656                                 "^\t[^\t][^:]+:" nil t)
 657                                (match-beginning 0)
 658                              (point-max))))))))
 659
 660 (defun lsdb-mode-edit-entry ()
 661   "Edit the entry on the current line."
 662   (interactive)
 663   (let* ((record (get-text-property (point) 'lsdb-record))
 664          (entry-name (intern (downcase (lsdb-current-entry))))
 665          (entry (assq entry-name (cdr record)))
 666          (marker (point-marker)))
 667     (lsdb-edit-form
 668      (cdr entry) "Editing the entry."
 669      `(lambda (form)
 670         (unless (equal form ',entry-name)
 671           (save-excursion
 672             (set-buffer lsdb-buffer-name)
 673             (goto-char ,marker)
 674             (let* ((record (get-text-property (point) 'lsdb-record))
 675                    (entry (assq ',entry-name (cdr record)))
 676                    (inhibit-read-only t)
 677                    buffer-read-only)
 678               (setcdr entry form)
 679               (setq lsdb-hash-table-is-dirty t)
 680               (lsdb-mode-delete-entry (symbol-name ',entry-name) t)
 681               (beginning-of-line)
 682               (add-text-properties
 683                (point)
 684                (progn
 685                  (lsdb-insert-entry (cons ',entry-name form))
 686                  (point))
 687                (list 'lsdb-record record)))))))))
 688
 689 (defun lsdb-mode-save ()
 690   "Save LSDB hash table into `lsdb-file'."
 691   (interactive)
 692   (if (not lsdb-hash-table-is-dirty)
 693       (message "(No changes need to be saved)")
 694     (when (or (interactive-p)
 695               (y-or-n-p "Save the LSDB now?"))
 696       (lsdb-save-file lsdb-file lsdb-hash-table)
 697       (setq lsdb-hash-table-is-dirty nil))))
 698
 699 ;;;_ : Edit Forms -- stolen (and renamed) from gnus-eform.el
 700 (defvar lsdb-edit-form-buffer "*LSDB edit form*")
 701 (defvar lsdb-edit-form-done-function nil)
 702 (defvar lsdb-previous-window-configuration nil)
 703
 704 (defvar lsdb-edit-form-mode-map
 705   (let ((keymap (make-sparse-keymap)))
 706     (set-keymap-parent keymap emacs-lisp-mode-map)
 707     (define-key keymap "\C-c\C-c" 'lsdb-edit-form-done)
 708     (define-key keymap "\C-c\C-k" 'lsdb-edit-form-exit)
 709     keymap)
 710   "Edit form's keymap.")
 711
 712 (defun lsdb-edit-form-mode ()
 713   "Major mode for editing forms.
 714 It is a slightly enhanced emacs-lisp-mode.
 715
 716 \\{lsdb-edit-form-mode-map}"
 717   (interactive)
 718   (kill-all-local-variables)
 719   (setq major-mode 'lsdb-edit-form-mode
 720         mode-name "LSDB Edit Form")
 721   (use-local-map lsdb-edit-form-mode-map)
 722   (make-local-variable 'lsdb-edit-form-done-function)
 723   (make-local-variable 'lsdb-previous-window-configuration)
 724   (run-hooks 'lsdb-edit-form-mode-hook))
 725
 726 (defun lsdb-edit-form (form documentation exit-func)
 727   "Edit FORM in a new buffer.
 728 Call EXIT-FUNC on exit.  Display DOCUMENTATION in the beginning
 729 of the buffer."
 730   (let ((window-configuration
 731          (current-window-configuration)))
 732     (switch-to-buffer (get-buffer-create lsdb-edit-form-buffer))
 733     (lsdb-edit-form-mode)
 734     (setq lsdb-previous-window-configuration window-configuration
 735           lsdb-edit-form-done-function exit-func)
 736     (erase-buffer)
 737     (insert documentation)
 738     (unless (bolp)
 739       (insert "\n"))
 740     (goto-char (point-min))
 741     (while (not (eobp))
 742       (insert ";;; ")
 743       (forward-line 1))
 744     (insert ";; Type `C-c C-c' after you've finished editing.\n")
 745     (insert "\n")
 746     (let ((p (point)))
 747       (pp form (current-buffer))
 748       (insert "\n")
 749       (goto-char p))))
 750
 751 (defun lsdb-edit-form-done ()
 752   "Update changes and kill the current buffer."
 753   (interactive)
 754   (goto-char (point-min))
 755   (let ((form (condition-case nil
 756                   (read (current-buffer))
 757                 (end-of-file nil)))
 758         (func lsdb-edit-form-done-function))
 759     (lsdb-edit-form-exit)
 760     (funcall func form)))
 761
 762 (defun lsdb-edit-form-exit ()
 763   "Kill the current buffer."
 764   (interactive)
 765   (let ((window-configuration lsdb-previous-window-configuration))
 766     (kill-buffer (current-buffer))
 767     (set-window-configuration window-configuration)))
 768
 769 ;;;_. Interface to Semi-gnus
 770 ;;;###autoload
 771 (defun lsdb-gnus-insinuate ()
 772   "Call this function to hook LSDB into Semi-gnus."
 773   (add-hook 'gnus-article-prepare-hook 'lsdb-gnus-update-record)
 774   (add-hook 'gnus-save-newsrc-hook 'lsdb-mode-save))
 775
 776 (defvar gnus-current-headers)
 777 (defun lsdb-gnus-update-record ()
 778   (let ((entity gnus-current-headers)
 779         records)
 780     (with-temp-buffer
 781       (set-buffer-multibyte nil)
 782       (buffer-disable-undo)
 783       (mime-insert-entity entity)
 784       (setq records (lsdb-update-records))
 785       (when records
 786         (lsdb-display-record (car records))))))
 787
 788 ;;;_. Interface to Wanderlust
 789 (defun lsdb-wl-insinuate ()
 790   "Call this function to hook LSDB into Wanderlust."
 791   (add-hook 'wl-message-redisplay-hook 'lsdb-wl-update-record)
 792   (add-hook 'wl-summary-exit-hook 'lsdb-wl-hide-buffer)
 793   (add-hook 'wl-exit-hook 'lsdb-mode-save))
 794
 795 (defun lsdb-wl-update-record ()
 796   (save-excursion
 797     (set-buffer (wl-message-get-original-buffer))
 798     (let ((records (lsdb-update-records)))
 799       (when records
 800         (lsdb-display-record (car records))))))
 801
 802 (defun lsdb-wl-hide-buffer ()
 803   (let ((window (get-buffer-window lsdb-buffer-name)))
 804     (if window
 805         (delete-window window))))
 806
 807 ;;;_. X-Face Rendering
 808 (defun lsdb-expose-x-face ()
 809   (let* ((record (get-text-property (point-min) 'lsdb-record))
 810          (x-face (cdr (assq 'x-face (cdr record)))))
 811     (when (and lsdb-insert-x-face-function
 812                x-face)
 813       (goto-char (point-min))
 814       (end-of-line)
 815       (insert (propertize "\r" 'invisible t) " ")
 816       (while x-face
 817         (funcall lsdb-insert-x-face-function (pop x-face))))))
 818
 819 ;; stolen (and renamed) from gnus-summary-x-face.el written by Akihiro Arisawa.
 820 (defvar lsdb-x-face-scale-factor 0.5
 821   "A number of scale factor used to scale down X-face image.
 822 See also `x-face-scale-factor'.")
 823
 824 (defun lsdb-insert-x-face-with-x-face-e21 (x-face)
 825   (require 'x-face-e21)
 826   (insert-image (x-face-create-image
 827                  x-face :scale-factor lsdb-x-face-scale-factor)))
 828
 829 (provide 'lsdb)
 830
 831 ;;;_* Local emacs vars.
 832 ;;; The following `outline-layout' local variable setting:
 833 ;;;  - closes all topics from the first topic to just before the third-to-last,
 834 ;;;  - shows the children of the third to last (config vars)
 835 ;;;  - and the second to last (code section),
 836 ;;;  - and closes the last topic (this local-variables section).
 837 ;;;Local variables:
 838 ;;;outline-layout: (0 : -1 -1 0)
 839 ;;;End:
 840
 841 ;;; lsdb.el ends here