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-Attribution\\|X-cite-me" nil attribution))
  80   "Alist of headers we are interested in.
  81 The format of elements of this list should be
  82      (FIELD-NAME REGEXP ENTRY STRING)
  83 where the last three elements are optional."
  84   :group 'lsdb
  85   :type 'list)
  86
  87 (defcustom lsdb-entry-type-alist
  88   '((net 5 ?,)
  89     (creation-date 2)
  90     (last-modified 2)
  91     (mailing-list 3 ?,)
  92     (attribution 3 ?.)
  93     (organization 3)
  94     (score -1))
  95   "Alist of entries to display.
  96 The format of elements of this list should be
  97      (ENTRY SCORE CLASS)
  98 where the last element is optional."
  99   :group 'lsdb
 100   :type 'list)
 101
 102 (defcustom lsdb-decode-field-body-function #'lsdb-decode-field-body
 103   "Field body decoder."
 104   :group 'lsdb
 105   :type 'function)
 106
 107 (defcustom lsdb-canonicalize-full-name-function
 108   #'lsdb-canonicalize-spaces-and-dots
 109   "Way to canonicalize full name."
 110   :group 'lsdb
 111   :type 'function)
 112
 113 (defcustom lsdb-print-record-function
 114   #'lsdb-print-record
 115   "Function to print LSDB record."
 116   :group 'lsdb
 117   :type 'function)
 118
 119 (defcustom lsdb-window-max-height 7
 120   "Maximum number of lines used to display LSDB record."
 121   :group 'lsdb
 122   :type 'integer)
 123
 124 ;;;_. Faces
 125 (defface lsdb-header-face
 126   '((t (:underline t)))
 127   "Face for the file header line in `lsdb-mode'."
 128   :group 'lsdb)
 129 (defvar lsdb-header-face 'lsdb-header-face)
 130
 131 (defface lsdb-field-name-face
 132   '((((class color) (background dark))
 133      (:foreground "PaleTurquoise" :bold t))
 134     (t (:bold t)))
 135   "Face for the message header line in `lsdb-mode'."
 136   :group 'lsdb)
 137 (defvar lsdb-field-name-face 'lsdb-field-name-face)
 138
 139 (defface lsdb-field-body-face
 140   '((((class color) (background dark))
 141      (:foreground "turquoise" :italic t))
 142     (t (:italic t)))
 143   "Face for the message header line in `lsdb-mode'."
 144   :group 'lsdb)
 145 (defvar lsdb-field-body-face 'lsdb-field-body-face)
 146
 147 (defconst lsdb-font-lock-keywords
 148   '(("^\\sw.*$"
 149      (0 lsdb-header-face))
 150     ("^\t\t.*$"
 151      (0 lsdb-field-body-face))
 152     ("^\t\\([^\t:]+:\\)[ \t]*\\(.*\\)$"
 153      (1 lsdb-field-name-face)
 154      (2 lsdb-field-body-face))))
 155
 156 (put 'lsdb-mode 'font-lock-defaults '(lsdb-font-lock-keywords t))
 157
 158 ;;;_* CODE - no user customizations below
 159 (defvar lsdb-hash-table nil
 160   "Internal hash table to hold LSDB records.")
 161
 162 (defvar lsdb-buffer-name "*LSDB*"
 163   "Buffer name to display LSDB record.")
 164
 165 (defvar lsdb-hash-table-is-dirty nil
 166   "Flag to indicate whether the hash table needs to be saved.")
 167
 168 ;;;_. Hash Table Emulation
 169 (if (fboundp 'make-hash-table)
 170     (progn
 171       (defalias 'lsdb-puthash 'puthash)
 172       (defalias 'lsdb-gethash 'gethash)
 173       (defalias 'lsdb-remhash 'remhash)
 174       (defalias 'lsdb-maphash 'maphash)
 175       (defalias 'lsdb-hash-table-size 'hash-table-size)
 176       (defalias 'lsdb-hash-table-count 'hash-table-count)
 177       (defalias 'lsdb-make-hash-table 'make-hash-table))
 178   (defun lsdb-puthash (key value hash-table)
 179     "Hash KEY to VALUE in HASH-TABLE."
 180     ;; Obarray is regarded as an open hash table, as a matter of
 181     ;; fact, rehashing doesn't make sense.
 182     (let (new-obarray)
 183       (when (> (car hash-table)
 184                (* (length (nth 1 hash-table)) 0.7))
 185         (setq new-obarray (make-vector (* (length (nth 1 hash-table)) 2) 0))
 186         (mapatoms
 187          (lambda (symbol)
 188            (set (intern (symbol-name symbol) new-obarray)
 189                 (symbol-value symbol)))
 190          (nth 1 hash-table))
 191         (setcdr hash-table (list new-obarray)))
 192       (set (intern key (nth 1 hash-table)) value)
 193       (setcar hash-table (1+ (car hash-table)))))
 194   (defun lsdb-gethash (key hash-table &optional default)
 195     "Find hash value for KEY in HASH-TABLE.
 196 If there is no corresponding value, return DEFAULT (which defaults to nil)."
 197     (let ((symbol (intern-soft key (nth 1 hash-table))))
 198       (if symbol
 199           (symbol-value symbol)
 200         default)))
 201   (defun lsdb-remhash (key hash-table)
 202     "Remove the entry for KEY from HASH-TABLE.
 203 Do nothing if there is no entry for KEY in HASH-TABLE."
 204     (unintern key (nth 1 hash-table))
 205     (setcar hash-table (1- (car hash-table))))
 206   (defun lsdb-maphash (function hash-table)
 207     "Map FUNCTION over entries in HASH-TABLE, calling it with two args,
 208 each key and value in HASH-TABLE.
 209
 210 FUNCTION may not modify HASH-TABLE, with the one exception that FUNCTION
 211 may remhash or puthash the entry currently being processed by FUNCTION."
 212     (mapatoms
 213      (lambda (symbol)
 214        (funcall function (symbol-name symbol) (symbol-value symbol)))
 215      hash-table))
 216   (defun lsdb-hash-table-size (hash-table)
 217     "Return the size of HASH-TABLE.
 218 This is the current number of slots in HASH-TABLE, whether occupied or not."
 219     (length (nth 1 hash-table)))
 220   (defalias 'lsdb-hash-table-count 'car)
 221   (defun lsdb-make-hash-table (&rest args)
 222     "Return a new empty hash table object."
 223     (list 0 (make-vector (or (plist-get args :size) 29) 0))))
 224
 225 ;;;_. Hash Table Reader/Writer
 226 (eval-and-compile
 227   (condition-case nil
 228       (progn
 229         ;; In XEmacs, hash tables can also be created by the lisp reader
 230         ;; using structure syntax.
 231         (read-from-string "#s(hash-table)")
 232         (defun lsdb-load-file (file)
 233           "Read the contents of FILE into a hash table."
 234           (save-excursion
 235             (set-buffer (find-file-noselect file))
 236             (re-search-forward "^#s")
 237             (beginning-of-line)
 238             (read (point-min-marker)))))
 239     (invalid-read-syntax
 240     (defun lsdb-load-file (file)
 241       "Read the contents of FILE into a hash table."
 242       (let* ((plist
 243               (with-temp-buffer
 244                 (insert-file-contents file)
 245                 (save-excursion
 246                   (re-search-forward "^#s")
 247                   (replace-match "")
 248                   (beginning-of-line)
 249                   (cdr (read (point-marker))))))
 250              (size (plist-get plist 'size))
 251              (data (plist-get plist 'data))
 252              (hash-table (lsdb-make-hash-table :size size :test 'equal)))
 253         (while data
 254           (lsdb-puthash (pop data) (pop data) hash-table))
 255         hash-table)))))
 256
 257 (defun lsdb-save-file (file hash-table)
 258   "Write the entries within HASH-TABLE into FILE."
 259   (let ((coding-system-for-write lsdb-file-coding-system))
 260     (with-temp-file file
 261       (if (and (or (featurep 'mule)
 262                    (featurep 'file-coding))
 263                lsdb-file-coding-system)
 264           (insert ";;; -*- coding: "
 265                   (if (symbolp lsdb-file-coding-system)
 266                       (symbol-name lsdb-file-coding-system)
 267                     ;; XEmacs
 268                     (coding-system-name lsdb-file-coding-system))
 269                   " -*-\n"))
 270       (insert "#s(hash-table size "
 271               (number-to-string (lsdb-hash-table-size hash-table))
 272               " test equal data (")
 273       (lsdb-maphash
 274        (lambda (key value)
 275          (insert (prin1-to-string key) " " (prin1-to-string value) " "))
 276        hash-table)
 277       (insert "))"))))
 278
 279 (defun lsdb-offer-save ()
 280   (if (and lsdb-hash-table-is-dirty
 281            (y-or-n-p "Save the LSDB now?"))
 282       (lsdb-save-file lsdb-file lsdb-hash-table)))
 283
 284 ;;;_. Mail Header Extraction
 285 (defun lsdb-fetch-field-bodies (regexp)
 286   (save-excursion
 287     (goto-char (point-min))
 288     (let ((case-fold-search t)
 289           field-bodies)
 290       (while (re-search-forward (concat "^\\(" regexp "\\):[ \t]*")
 291                                 nil t)
 292         (push (funcall lsdb-decode-field-body-function
 293                              (buffer-substring (point) (std11-field-end))
 294                              (match-string 1))
 295                     field-bodies))
 296       (nreverse field-bodies))))
 297
 298 (defun lsdb-canonicalize-spaces-and-dots (string)
 299   (while (string-match "  +\\|[\f\t\n\r\v]+\\|\\." string)
 300     (setq string (replace-match " " nil t string)))
 301   string)
 302
 303 (defun lsdb-extract-address-components (string)
 304   (let ((components (std11-extract-address-components string)))
 305     (if (nth 1 components)
 306         (if (car components)
 307             (list (nth 1 components)
 308                   (funcall lsdb-canonicalize-full-name-function
 309                            (car components)))
 310           (list (nth 1 components) (nth 1 components))))))
 311
 312 ;; stolen (and renamed) from nnheader.el
 313 (defun lsdb-decode-field-body (field-body field-name
 314                                           &optional mode max-column)
 315   (let ((multibyte enable-multibyte-characters))
 316     (unwind-protect
 317         (progn
 318           (set-buffer-multibyte t)
 319           (mime-decode-field-body field-body
 320                                   (if (stringp field-name)
 321                                       (intern (capitalize field-name))
 322                                     field-name)
 323                                   mode max-column))
 324       (set-buffer-multibyte multibyte))))
 325
 326 ;;;_. Record Management
 327 (defun lsdb-maybe-load-file ()
 328   (unless lsdb-hash-table
 329     (if (file-exists-p lsdb-file)
 330         (setq lsdb-hash-table (lsdb-load-file lsdb-file))
 331       (setq lsdb-hash-table (lsdb-make-hash-table :test 'equal)))))
 332
 333 (defun lsdb-update-record (sender &optional interesting)
 334   (let ((old (lsdb-gethash (nth 1 sender) lsdb-hash-table))
 335         (new (cons (cons 'net (list (car sender)))
 336                    interesting))
 337         merged
 338         record)
 339     (unless old
 340       (setq new (cons (cons 'creation-date (format-time-string "%Y-%m-%d"))
 341                       new)))
 342     (setq merged (lsdb-merge-record-entries old new)
 343           record (cons (nth 1 sender) merged))
 344     (unless (equal merged old)
 345       (let ((entry (assq 'last-modified (cdr record)))
 346             (last-modified (format-time-string "%Y-%m-%d")))
 347         (if entry
 348             (setcdr entry last-modified)
 349           (setcdr record (cons (cons 'last-modified last-modified)
 350                                (cdr record)))))
 351       (lsdb-puthash (car record) (copy-sequence (cdr record))
 352                     lsdb-hash-table)
 353       (setq lsdb-hash-table-is-dirty t))
 354     record))
 355
 356 (defun lsdb-update-records ()
 357   (lsdb-maybe-load-file)
 358   (let (senders recipients interesting alist records bodies entry)
 359     (save-restriction
 360       (std11-narrow-to-header)
 361       (setq senders
 362             (delq nil (mapcar #'lsdb-extract-address-components
 363                               (lsdb-fetch-field-bodies
 364                                lsdb-sender-headers)))
 365             recipients
 366             (delq nil (mapcar #'lsdb-extract-address-components
 367                               (lsdb-fetch-field-bodies
 368                                lsdb-recipients-headers))))
 369       (setq alist lsdb-interesting-header-alist)
 370       (while alist
 371         (setq bodies
 372               (mapcar
 373                (lambda (field-body)
 374                  (if (and (nth 1 (car alist))
 375                           (string-match (nth 1 (car alist)) field-body))
 376                      (replace-match (nth 3 (car alist)) nil nil field-body)
 377                    field-body))
 378                (lsdb-fetch-field-bodies (car (car alist)))))
 379         (when bodies
 380           (setq entry (or (nth 2 (car alist))
 381                           'notes))
 382           (push (cons entry
 383                       (if (eq ?. (nth 2 (assq entry lsdb-entry-type-alist)))
 384                           (car bodies)
 385                         bodies))
 386                 interesting))
 387         (setq alist (cdr alist))))
 388     (if senders
 389         (setq records (list (lsdb-update-record (pop senders) interesting))))
 390     (setq alist (nconc senders recipients))
 391     (while alist
 392       (setq records (cons (lsdb-update-record (pop alist)) records)))
 393     (nreverse records)))
 394
 395 (defun lsdb-merge-record-entries (old new)
 396   (setq old (copy-sequence old))
 397   (while new
 398     (let ((entry (assq (car (car new)) old))
 399           list pointer)
 400       (if (null entry)
 401           (setq old (nconc old (list (car new))))
 402         (if (listp (cdr entry))
 403             (progn
 404               (setq list (cdr (car new)) pointer list)
 405               (while pointer
 406                 (if (member (car pointer) (cdr entry))
 407                     (setq list (delq (car pointer) list)))
 408                 (setq pointer (cdr pointer)))
 409               (setcdr entry (nconc (cdr entry) list)))
 410           (setcdr entry (cdr (car new))))))
 411     (setq new (cdr new)))
 412   old)
 413
 414 ;;;_. Display Management
 415 (defun lsdb-temp-buffer-show-function (buffer)
 416   (save-selected-window
 417     (let ((window (or (get-buffer-window lsdb-buffer-name)
 418                       (progn
 419                         (select-window (get-largest-window))
 420                         (split-window-vertically))))
 421           height)
 422       (set-window-buffer window buffer)
 423       (select-window window)
 424       (unless (pos-visible-in-window-p (point-max))
 425         (enlarge-window (- lsdb-window-max-height (window-height))))
 426       (shrink-window-if-larger-than-buffer)
 427       (if (> (setq height (window-height))
 428              lsdb-window-max-height)
 429           (shrink-window (- height lsdb-window-max-height))
 430           (shrink-window-if-larger-than-buffer)))))
 431
 432 (defun lsdb-display-record (record)
 433   (let ((temp-buffer-show-function
 434          (function lsdb-temp-buffer-show-function)))
 435     (with-output-to-temp-buffer lsdb-buffer-name
 436       (set-buffer standard-output)
 437       (funcall lsdb-print-record-function record)
 438       (lsdb-mode))))
 439
 440 (defun lsdb-print-record (record)
 441   (insert (car record) "\n")
 442   (let ((entries
 443          (sort (cdr record)
 444                (lambda (entry1 entry2)
 445                  (> (or (nth 1 (assq (car entry1) lsdb-entry-type-alist))
 446                         0)
 447                     (or (nth 1 (assq (car entry2) lsdb-entry-type-alist))
 448                         0))))))
 449     (while entries
 450       (insert "\t" (capitalize (symbol-name (car (car entries)))) ": "
 451               (if (listp (cdr (car entries)))
 452                   (mapconcat #'identity (cdr (car entries))
 453                              (if (eq ?, (nth 2 (assq (car (car entries))
 454                                                      lsdb-entry-type-alist)))
 455                                  ", "
 456                                "\n\t\t"))
 457                 (cdr (car entries)))
 458               "\n")
 459       (setq entries (cdr entries)))))
 460
 461 ;;;_. Completion
 462 (defvar lsdb-last-completion nil)
 463 (defvar lsdb-last-candidates nil)
 464 (defvar lsdb-last-candidates-pointer nil)
 465
 466 (defun lsdb-complete-name ()
 467   "Complete the user full-name or net-address before point"
 468   (interactive)
 469   (lsdb-maybe-load-file)
 470   (let* ((start
 471           (save-excursion
 472             (re-search-backward "\\(\\`\\|[\n:,]\\)[ \t]*")
 473             (goto-char (match-end 0))
 474             (point)))
 475          pattern
 476          (case-fold-search t)
 477          (completion-ignore-case t))
 478     (unless (eq last-command this-command)
 479       (setq lsdb-last-candidates nil
 480             lsdb-last-candidates-pointer nil
 481             lsdb-last-completion (buffer-substring start (point))
 482             pattern (concat "\\<" lsdb-last-completion))
 483       (lsdb-maphash
 484        (lambda (key value)
 485          (let ((net (cdr (assq 'net value))))
 486            (if (string-match pattern key)
 487                (setq lsdb-last-candidates
 488                      (nconc lsdb-last-candidates
 489                             (mapcar (lambda (address)
 490                                       (if (equal key address)
 491                                           key
 492                                         (concat key " <" address ">")))
 493                                     net)))
 494              (while net
 495                (if (string-match pattern (car net))
 496                    (push (car net) lsdb-last-candidates))
 497                (setq net (cdr net))))))
 498        lsdb-hash-table))
 499     (unless lsdb-last-candidates-pointer
 500       (setq lsdb-last-candidates-pointer lsdb-last-candidates))
 501     (when lsdb-last-candidates-pointer
 502       (delete-region start (point))
 503       (insert (pop lsdb-last-candidates-pointer)))))
 504
 505 ;;;_. Major Mode (`lsdb-mode') Implementation
 506 (define-derived-mode lsdb-mode fundamental-mode "LSDB"
 507   "Major mode for browsing LSDB records."
 508   (setq buffer-read-only t)
 509   (if (featurep 'xemacs)
 510       ;; In XEmacs, setting `font-lock-defaults' only affects on
 511       ;; `find-file-hooks'.
 512       (font-lock-set-defaults)
 513     (set (make-local-variable 'font-lock-defaults)
 514          '(lsdb-font-lock-keywords t))))
 515
 516 ;;;_. Interface to Semi-gnus
 517 ;;;###autoload
 518 (defun lsdb-gnus-insinuate ()
 519   "Call this function to hook LSDB into Semi-gnus."
 520   (add-hook 'gnus-article-prepare-hook 'lsdb-gnus-update-record)
 521   (add-hook 'gnus-save-newsrc-hook 'lsdb-offer-save))
 522
 523 (defvar gnus-current-headers)
 524 (defun lsdb-gnus-update-record ()
 525   (let ((entity gnus-current-headers)
 526         records)
 527     (with-temp-buffer
 528       (set-buffer-multibyte nil)
 529       (buffer-disable-undo)
 530       (mime-insert-entity entity)
 531       (setq records (lsdb-update-records))
 532       (when records
 533         (lsdb-display-record (car records))))))
 534
 535 ;;;_. Interface to Wanderlust
 536 (defun lsdb-wl-insinuate ()
 537   "Call this function to hook LSDB into Wanderlust."
 538   (add-hook 'wl-message-redisplay-hook 'lsdb-wl-update-record)
 539   (add-hook 'wl-summary-exit-hook 'lsdb-wl-hide-buffer)
 540   (add-hook 'wl-exit-hook 'lsdb-offer-save))
 541
 542 (defun lsdb-wl-update-record ()
 543   (save-excursion
 544     (set-buffer (wl-message-get-original-buffer))
 545     (let ((records (lsdb-update-records)))
 546       (when records
 547         (lsdb-display-record (car records))))))
 548
 549 (defun lsdb-wl-hide-buffer ()
 550   (let ((window (get-buffer-window lsdb-buffer-name)))
 551     (if window
 552         (delete-window window))))
 553
 554 (provide 'lsdb)
 555
 556 ;;;_* Local emacs vars.
 557 ;;; The following `outline-layout' local variable setting:
 558 ;;;  - closes all topics from the first topic to just before the third-to-last,
 559 ;;;  - shows the children of the third to last (config vars)
 560 ;;;  - and the second to last (code section),
 561 ;;;  - and closes the last topic (this local-variables section).
 562 ;;;Local variables:
 563 ;;;outline-layout: (0 : -1 -1 0)
 564 ;;;End:
 565
 566 ;;; lsdb.el ends here