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