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 (defun lsdb-offer-save ()
 264   (if (and lsdb-hash-table-is-dirty
 265            (y-or-n-p "Save the LSDB now?"))
 266       (lsdb-save-file lsdb-file lsdb-hash-table)))
 267
 268 ;;;_. Mail Header Extraction
 269 (defun lsdb-fetch-field-bodies (entity regexp)
 270   (save-excursion
 271     (goto-char (point-min))
 272     (let ((case-fold-search t)
 273           field-bodies)
 274       (while (re-search-forward (concat "^\\(" regexp "\\):[ \t]*") nil t)
 275         (push (funcall lsdb-decode-field-body-function
 276                        (buffer-substring (point) (std11-field-end))
 277                        (match-string 1))
 278               field-bodies))
 279       (nreverse field-bodies))))
 280
 281 (defun lsdb-canonicalize-spaces-and-dots (string)
 282   (while (string-match "  +\\|[\f\t\n\r\v]+\\|\\." string)
 283     (setq string (replace-match " " nil t string)))
 284   string)
 285
 286 (defun lsdb-extract-address-components (string)
 287   (let ((components (std11-extract-address-components string)))
 288     (if (nth 1 components)
 289         (if (car components)
 290             (list (nth 1 components)
 291                   (funcall lsdb-canonicalize-full-name-function
 292                            (car components)))
 293           (list (nth 1 components) (nth 1 components))))))
 294
 295 ;; stolen (and renamed) from nnheader.el
 296 (defun lsdb-decode-field-body (field-body field-name
 297                                           &optional mode max-column)
 298   (mime-decode-field-body field-body
 299                           (if (stringp field-name)
 300                               (intern (capitalize field-name))
 301                             field-name)
 302                           mode max-column))
 303
 304 ;;;_. Record Management
 305 (defun lsdb-maybe-load-file ()
 306   (unless lsdb-hash-table
 307     (if (file-exists-p lsdb-file)
 308         (setq lsdb-hash-table (lsdb-load-file lsdb-file))
 309       (setq lsdb-hash-table (lsdb-make-hash-table :test 'equal)))))
 310
 311 (defun lsdb-update-record (sender &optional interesting)
 312   (let ((old (lsdb-gethash (nth 1 sender) lsdb-hash-table))
 313         (new (cons (cons 'net (list (car sender)))
 314                    interesting))
 315         merged
 316         record)
 317     (unless old
 318       (setq new (cons (cons 'creation-date (format-time-string "%Y-%m-%d"))
 319                       new)))
 320     (setq merged (lsdb-merge-record-entries old new)
 321           record (cons (nth 1 sender) merged))
 322     (unless (equal merged old)
 323       (lsdb-puthash (car record) (cdr record) lsdb-hash-table)
 324       (setq lsdb-hash-table-is-dirty t))
 325     record))
 326
 327 (defun lsdb-update-records (entity)
 328   (lsdb-maybe-load-file)
 329   (let (senders recipients interesting alist records bodies entry)
 330     (with-temp-buffer
 331       (set-buffer-multibyte nil)
 332       (buffer-disable-undo)
 333       (mime-insert-entity entity)
 334       (std11-narrow-to-header)
 335       (setq senders
 336             (delq nil (mapcar #'lsdb-extract-address-components
 337                               (lsdb-fetch-field-bodies
 338                                entity lsdb-sender-headers)))
 339             recipients
 340             (delq nil (mapcar #'lsdb-extract-address-components
 341                               (lsdb-fetch-field-bodies
 342                                entity lsdb-recipients-headers))))
 343       (setq alist lsdb-interesting-header-alist)
 344       (while alist
 345         (setq bodies
 346               (mapcar
 347                (lambda (field-body)
 348                  (if (and (nth 1 (car alist))
 349                           (string-match (nth 1 (car alist)) field-body))
 350                      (replace-match (nth 3 (car alist)) nil nil field-body)
 351                    field-body))
 352                (lsdb-fetch-field-bodies entity (car (car alist)))))
 353         (when bodies
 354           (setq entry (or (nth 2 (car alist))
 355                           'notes))
 356           (push (cons entry
 357                       (if (eq ?. (nth 2 (assq entry lsdb-entry-type-alist)))
 358                           (car bodies)
 359                         bodies))
 360                 interesting))
 361         (setq alist (cdr alist))))
 362     (if senders
 363         (setq records (list (lsdb-update-record (pop senders) interesting))))
 364     (setq alist (nconc senders recipients))
 365     (while alist
 366       (setq records (cons (lsdb-update-record (pop alist)) records)))
 367     (nreverse records)))
 368
 369 (defun lsdb-merge-record-entries (old new)
 370   (while new
 371     (let ((entry (assq (car (car new)) old))
 372           list pointer)
 373       (if (null entry)
 374           (setq old (nconc old (list (car new))))
 375         (if (listp (cdr entry))
 376             (progn
 377               (setq list (cdr (car new)) pointer list)
 378               (while pointer
 379                 (if (member (car pointer) (cdr entry))
 380                     (setq list (delq (car pointer) list)))
 381                 (setq pointer (cdr pointer)))
 382               (setcdr entry (nconc (cdr entry) list)))
 383           (setcdr entry (cdr (car new))))))
 384     (setq new (cdr new)))
 385   old)
 386
 387 ;;;_. Display Management
 388 (defun lsdb-temp-buffer-show-function (buffer)
 389   (save-selected-window
 390     (let ((window (or (get-buffer-window lsdb-buffer-name)
 391                       (progn
 392                         (select-window (get-largest-window))
 393                         (split-window-vertically))))
 394           height)
 395       (set-window-buffer window buffer)
 396       (select-window window)
 397       (unless (pos-visible-in-window-p (point-max))
 398         (enlarge-window (- lsdb-window-max-height (window-height))))
 399       (shrink-window-if-larger-than-buffer)
 400       (if (> (setq height (window-height))
 401              lsdb-window-max-height)
 402           (shrink-window (- height lsdb-window-max-height))
 403           (shrink-window-if-larger-than-buffer)))))
 404
 405 (defun lsdb-display-record (record)
 406   (let ((temp-buffer-show-function
 407          (function lsdb-temp-buffer-show-function)))
 408     (with-output-to-temp-buffer lsdb-buffer-name
 409       (set-buffer standard-output)
 410       (funcall lsdb-print-record-function record)
 411       (lsdb-mode))))
 412
 413 (defun lsdb-print-record (record)
 414   (insert (car record) "\n")
 415   (let ((entries
 416          (sort (cdr record)
 417                (lambda (entry1 entry2)
 418                  (> (or (nth 1 (assq (car entry1) lsdb-entry-type-alist))
 419                         0)
 420                     (or (nth 1 (assq (car entry2) lsdb-entry-type-alist))
 421                         0))))))
 422     (while entries
 423       (insert "\t" (capitalize (symbol-name (car (car entries)))) ": "
 424               (if (listp (cdr (car entries)))
 425                   (mapconcat #'identity (cdr (car entries))
 426                              (if (eq ?, (nth 2 (assq (car (car entries))
 427                                                      lsdb-entry-type-alist)))
 428                                  ", "
 429                                "\n\t\t"))
 430                 (cdr (car entries)))
 431               "\n")
 432       (setq entries (cdr entries)))))
 433
 434 ;;;_. Completion
 435 (defvar lsdb-last-completion nil)
 436
 437 (defun lsdb-complete-name ()
 438   "Complete the user full-name or net-address before point"
 439   (interactive)
 440   (let* ((start
 441           (save-excursion
 442             (re-search-backward "\\(\\`\\|[\n:,]\\)[ \t]*")
 443             (goto-char (match-end 0))
 444             (point)))
 445          (string
 446           (if (and (eq last-command this-command)
 447                    (stringp lsdb-last-completion))
 448               lsdb-last-completion
 449             (buffer-substring start (point))))
 450          (pattern
 451           (concat "\\`" string))
 452          (case-fold-search t)
 453          (completion-ignore-case t)
 454          candidates)
 455     (lsdb-maphash
 456      (lambda (key value)
 457        (let ((net (cdr (assq 'net value))))
 458          (if (string-match pattern key)
 459              (setq candidates
 460                    (nconc candidates
 461                           (mapcar (lambda (address)
 462                                     (list (concat key " <" address ">")))
 463                                   net)))
 464            (while net
 465              (if (string-match pattern (car net))
 466                  (push (list (car net)) candidates))
 467              (setq net (cdr net))))))
 468      lsdb-hash-table)
 469     (setq lsdb-last-completion (try-completion string candidates))
 470     (if (null lsdb-last-completion)
 471         (error "No match")
 472       (when (stringp lsdb-last-completion)
 473         (delete-region start (point))
 474         (insert lsdb-last-completion)))))
 475
 476 ;;;_. Major Mode (`lsdb-mode') Implementation
 477 (define-derived-mode lsdb-mode fundamental-mode "LSDB"
 478   "Major mode for browsing LSDB records."
 479   (setq buffer-read-only t)
 480   (if (featurep 'xemacs)
 481       ;; In XEmacs, setting `font-lock-defaults' only affects on
 482       ;; `find-file-hooks'.
 483       (font-lock-set-defaults)
 484     (set (make-local-variable 'font-lock-defaults)
 485          '(lsdb-font-lock-keywords t))))
 486
 487 ;;;_. Interface to Semi-gnus
 488 ;;;###autoload
 489 (defun lsdb-gnus-insinuate ()
 490   "Call this function to hook LSDB into Semi-gnus."
 491   (add-hook 'gnus-article-prepare-hook 'lsdb-gnus-update-record)
 492   (add-hook 'gnus-save-newsrc-hook 'lsdb-offer-save))
 493
 494 (defvar message-mode-map)
 495 (defun lsdb-gnus-insinuate-message ()
 496   "Call this function to hook LSDB into Message mode."
 497   (define-key message-mode-map "\M-\t" 'lsdb-complete-name))
 498
 499 (defvar gnus-current-headers)
 500 (defun lsdb-gnus-update-record ()
 501   (let ((records (lsdb-update-records gnus-current-headers)))
 502     (when records
 503       (lsdb-display-record (car records)))))
 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