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