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