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