X-Git-Url: http://git.chise.org/gitweb/?a=blobdiff_plain;f=lsdb.el;h=929ac958a5c13fb74664e690897bd79cd4bea335;hb=08c1b506f74296191b6a73debf651758126d6add;hp=3521ca1a71fa2274c2ea8728dfe6c273c4de2cc4;hpb=b42bf108994c8aa3e3d18661180e18c569b53ec9;p=elisp%2Flsdb.git diff --git a/lsdb.el b/lsdb.el index 3521ca1..929ac95 100644 --- a/lsdb.el +++ b/lsdb.el @@ -24,14 +24,34 @@ ;;; Commentary: +;;; For Semi-gnus: ;;; (autoload 'lsdb-gnus-insinuate "lsdb") ;;; (autoload 'lsdb-gnus-insinuate-message "lsdb") ;;; (add-hook 'gnus-startup-hook 'lsdb-gnus-insinuate) -;;; (add-hook 'message-setup-hook 'lsdb-gnus-insinuate-message) +;;; (add-hook 'message-setup-hook +;;; (lambda () +;;; (define-key message-mode-map "\M-\t" 'lsdb-complete-name))) + +;;; For Wanderlust, put the following lines into your ~/.wl: +;;; (require 'lsdb) +;;; (lsdb-wl-insinuate) +;;; (add-hook 'wl-draft-mode-hook +;;; (lambda () +;;; (define-key wl-draft-mode-map "\M-\t" 'lsdb-complete-name))) + +;;; For Mew, put the following lines into your ~/.mew: +;;; (autoload 'lsdb-mew-insinuate "lsdb") +;;; (add-hook 'mew-init-hook 'lsdb-mew-insinuate) +;;; (add-hook 'mew-draft-mode-hook +;;; (lambda () +;;; (define-key mew-draft-header-map "\M-I" 'lsdb-complete-name))) ;;; Code: +(require 'poem) +(require 'pces) (require 'mime) +(require 'static) ;;;_* USER CUSTOMIZATION VARIABLES: (defgroup lsdb nil @@ -44,7 +64,7 @@ :group 'lsdb :type 'file) -(defcustom lsdb-file-coding-system 'iso-2022-jp +(defcustom lsdb-file-coding-system (find-coding-system 'iso-2022-jp) "Coding system for `lsdb-file'." :group 'lsdb :type 'symbol) @@ -63,9 +83,14 @@ (defcustom lsdb-interesting-header-alist '(("Organization" nil organization) - ("\\(X-\\)?User-Agent\\|X-Mailer" nil user-agent) + ("\\(X-\\)?User-Agent\\|X-Mailer\\|X-Newsreader" nil user-agent) ("\\(X-\\)?ML-Name" nil mailing-list) - ("X-Attribution\\|X-cite-me" nil attribution)) + ("List-Id" "\\(.*\\)[ \t]+<[^>]+>\\'" mailing-list "\\1") + ("X-Sequence" "\\(.*\\)[ \t]+[0-9]+\\'" mailing-list "\\1") + ("Delivered-To" "mailing list[ \t]+\\([^@]+\\)@.*" mailing-list "\\1") + ("\\(X-URL\\|X-URI\\)" nil www) + ("X-Attribution\\|X-cite-me" nil attribution) + ("X-Face" nil x-face)) "Alist of headers we are interested in. The format of elements of this list should be (FIELD-NAME REGEXP ENTRY STRING) @@ -74,14 +99,26 @@ where the last three elements are optional." :type 'list) (defcustom lsdb-entry-type-alist - '((net 3 ?,) - (creation-date 2) - (mailing-list 1 ?,) - (attribution 1 ?.)) - "Alist of entries to display. + '((net 5 ?,) + (creation-date 2 ?. t) + (last-modified 3 ?. t) + (mailing-list 4 ?,) + (attribution 4 ?.) + (organization 4) + (www 4) + (aka 4) + (score -1) + (x-face -1)) + "Alist of entry types for presentation. The format of elements of this list should be - (ENTRY SCORE CLASS) -where the last element is optional." + (ENTRY SCORE [CLASS READ-ONLY]) +where the last two elements are optional. +Possible values for CLASS are `?.' and '?,'. If CLASS is `?.', the +entry takes a unique value which is overridden by newly assigned one +by `lsdb-mode-edit-entry' or such a command. If CLASS is `?,', the +entry can have multiple values separated by commas. +If the fourth element READ-ONLY is non-nil, it is assumed that the +entry cannot be modified." :group 'lsdb :type 'list) @@ -96,17 +133,62 @@ where the last element is optional." :group 'lsdb :type 'function) -(defcustom lsdb-print-record-function - #'lsdb-print-record - "Function to print LSDB record." - :group 'lsdb - :type 'function) - (defcustom lsdb-window-max-height 7 "Maximum number of lines used to display LSDB record." :group 'lsdb :type 'integer) +(defcustom lsdb-x-face-command-alist + '((pbm "{ echo '/* Width=48, Height=48 */'; uncompface; } | icontopbm | pnmscale 0.5") + (xpm "{ echo '/* Width=48, Height=48 */'; uncompface; } | icontopbm | pnmscale 0.5 | ppmtoxpm")) + "An alist from an image type to a command to be executed to display an X-Face header. +The command will be executed in a sub-shell asynchronously. +The compressed face will be piped to this command." + :group 'lsdb + :type 'list) + +(defcustom lsdb-insert-x-face-function + (if (static-if (featurep 'xemacs) + (featurep 'xpm) + (and (>= emacs-major-version 21) + (fboundp 'image-type-available-p) + (or (image-type-available-p 'pbm) + (image-type-available-p 'xpm)))) + #'lsdb-insert-x-face-asynchronously) + "Function to display X-Face." + :group 'lsdb + :type 'function) + +(defcustom lsdb-print-record-hook '(lsdb-expose-x-face) + "A hook called after a record is displayed." + :group 'lsdb + :type 'hook) + +(defcustom lsdb-display-records-sort-predicate nil + "A predicate to sort records." + :group 'lsdb + :type 'function) + +(defgroup lsdb-edit-form nil + "A mode for editing forms." + :group 'lsdb) + +(defcustom lsdb-edit-form-mode-hook nil + "Hook run in `lsdb-edit-form-mode' buffers." + :group 'lsdb-edit-form + :type 'hook) + +(defcustom lsdb-shell-file-name "/bin/sh" + "File name to load inferior shells from. +Bourne shell or its equivalent \(not tcsh) is needed for \"2>\"." + :group 'lsdb + :type 'string) + +(defcustom lsdb-shell-command-switch "-c" + "Switch used to have the shell execute its command line argument." + :group 'lsdb + :type 'string) + ;;;_. Faces (defface lsdb-header-face '((t (:underline t))) @@ -131,7 +213,7 @@ where the last element is optional." (defvar lsdb-field-body-face 'lsdb-field-body-face) (defconst lsdb-font-lock-keywords - '(("^\\sw.*$" + '(("^\\sw[^\r\n]*" (0 lsdb-header-face)) ("^\t\t.*$" (0 lsdb-field-body-face)) @@ -142,17 +224,27 @@ where the last element is optional." (put 'lsdb-mode 'font-lock-defaults '(lsdb-font-lock-keywords t)) ;;;_* CODE - no user customizations below +;;;_. Internal Variables (defvar lsdb-hash-table nil "Internal hash table to hold LSDB records.") +(defvar lsdb-reverse-hash-table nil + "The reverse lookup table for `lsdb-hash-table'. +It represents address to full-name mapping.") + (defvar lsdb-buffer-name "*LSDB*" "Buffer name to display LSDB record.") -(defvar lsdb-hash-table-is-dirty nil - "Flag to indicate whether the hash table needs to be saved.") +(defvar lsdb-hash-tables-are-dirty nil + "Flag to indicate whether the internal hash tables need to be saved.") + +(defvar lsdb-known-entry-names + (make-vector 29 0) + "An obarray used to complete an entry name.") ;;;_. Hash Table Emulation -(if (fboundp 'make-hash-table) +(if (and (fboundp 'make-hash-table) + (subrp (symbol-function 'make-hash-table))) (progn (defalias 'lsdb-puthash 'puthash) (defalias 'lsdb-gethash 'gethash) @@ -180,8 +272,10 @@ where the last element is optional." (defun lsdb-gethash (key hash-table &optional default) "Find hash value for KEY in HASH-TABLE. If there is no corresponding value, return DEFAULT (which defaults to nil)." - (or (intern-soft key (nth 1 hash-table)) - default)) + (let ((symbol (intern-soft key (nth 1 hash-table)))) + (if symbol + (symbol-value symbol) + default))) (defun lsdb-remhash (key hash-table) "Remove the entry for KEY from HASH-TABLE. Do nothing if there is no entry for KEY in HASH-TABLE." @@ -196,7 +290,7 @@ may remhash or puthash the entry currently being processed by FUNCTION." (mapatoms (lambda (symbol) (funcall function (symbol-name symbol) (symbol-value symbol))) - hash-table)) + (nth 1 hash-table))) (defun lsdb-hash-table-size (hash-table) "Return the size of HASH-TABLE. This is the current number of slots in HASH-TABLE, whether occupied or not." @@ -207,70 +301,107 @@ This is the current number of slots in HASH-TABLE, whether occupied or not." (list 0 (make-vector (or (plist-get args :size) 29) 0)))) ;;;_. Hash Table Reader/Writer +(defconst lsdb-secondary-hash-table-start-format + ";;; %S\n") + +(defmacro lsdb-secondary-hash-table-start (hash-table) + `(format lsdb-secondary-hash-table-start-format ',hash-table)) + (eval-and-compile (condition-case nil (progn ;; In XEmacs, hash tables can also be created by the lisp reader ;; using structure syntax. (read-from-string "#s(hash-table)") - (defun lsdb-load-file (file) - "Read the contents of FILE into a hash table." - (save-excursion - (set-buffer (find-file-noselect file)) - (re-search-forward "^#s") - (beginning-of-line) - (read (point-min-marker))))) + (defalias 'lsdb-read 'read)) (invalid-read-syntax - (defun lsdb-load-file (file) - "Read the contents of FILE into a hash table." - (let* ((plist - (with-temp-buffer - (insert-file-contents file) - (save-excursion - (re-search-forward "^#s") - (replace-match "") - (beginning-of-line) - (cdr (read (point-marker)))))) - (size (plist-get plist 'size)) - (data (plist-get plist 'data)) - (hash-table (lsdb-make-hash-table :size size :test 'equal))) - (while data - (lsdb-puthash (pop data) (pop data) hash-table)) - hash-table))))) - -(defun lsdb-save-file (file hash-table) - "Write the entries within HASH-TABLE into FILE." + (defun lsdb-read (&optional marker) + "Read one Lisp expression as text from MARKER, return as Lisp object." + (save-excursion + (goto-char marker) + (if (looking-at "^#s(") + (with-temp-buffer + (buffer-disable-undo) + (insert-buffer-substring (marker-buffer marker) marker) + (goto-char (point-min)) + (delete-char 2) + (let ((object (read (current-buffer))) + hash-table data) + (if (eq 'hash-table (car object)) + (progn + (setq hash-table + (lsdb-make-hash-table + :size (plist-get (cdr object) 'size) + :test 'equal) + data (plist-get (cdr object) 'data)) + (while data + (lsdb-puthash (pop data) (pop data) hash-table)) + hash-table) + object))))))))) + +(defun lsdb-load-hash-tables () + "Read the contents of `lsdb-file' into the internal hash tables." + (let ((buffer (find-file-noselect lsdb-file))) + (unwind-protect + (save-excursion + (set-buffer buffer) + (goto-char (point-min)) + (re-search-forward "^#s(") + (goto-char (match-beginning 0)) + (setq lsdb-hash-table (lsdb-read (point-marker))) + (if (re-search-forward + (concat "^" (lsdb-secondary-hash-table-start + lsdb-reverse-hash-table)) + nil t) + (setq lsdb-reverse-hash-table (lsdb-read (point-marker))))) + (kill-buffer buffer)))) + +(defun lsdb-insert-hash-table (hash-table) + (insert "#s(hash-table size " + ;; Reduce the actual size of the close hash table, because + ;; XEmacs doesn't have a distinction between index-size and + ;; hash-table-size. + (number-to-string (lsdb-hash-table-count hash-table)) + " test equal data (") + (lsdb-maphash + (lambda (key value) + (insert (prin1-to-string key) " " (prin1-to-string value) " ")) + hash-table) + (insert "))")) + +(defun lsdb-save-hash-tables () + "Write the records within the internal hash tables into `lsdb-file'." (let ((coding-system-for-write lsdb-file-coding-system)) - (with-temp-file file + (with-temp-file lsdb-file (if (and (or (featurep 'mule) (featurep 'file-coding)) lsdb-file-coding-system) - (insert ";;; -*- coding: " - (if (symbolp lsdb-file-coding-system) - (symbol-name lsdb-file-coding-system) - ;; XEmacs - (coding-system-name lsdb-file-coding-system)) - " -*-\n")) - (insert "#s(hash-table size " - (number-to-string (lsdb-hash-table-size hash-table)) - " test equal data (") - (lsdb-maphash - (lambda (key value) - (insert (prin1-to-string key) " " (prin1-to-string value) " ")) - hash-table) - (insert "))")))) + (let ((coding-system-name + (if (symbolp lsdb-file-coding-system) + (symbol-name lsdb-file-coding-system) + ;; XEmacs + (static-if (featurep 'xemacs) + (symbol-name (coding-system-name + lsdb-file-coding-system)))))) + (if coding-system-name + (insert ";;; -*- coding: " coding-system-name " -*-\n")))) + (lsdb-insert-hash-table lsdb-hash-table) + (insert "\n" (lsdb-secondary-hash-table-start + lsdb-reverse-hash-table)) + (lsdb-insert-hash-table lsdb-reverse-hash-table)))) ;;;_. Mail Header Extraction -(defun lsdb-fetch-field-bodies (entity regexp) +(defun lsdb-fetch-field-bodies (regexp) (save-excursion (goto-char (point-min)) (let ((case-fold-search t) field-bodies) - (while (re-search-forward (concat "^\\(" regexp "\\):[ \t]*") nil t) + (while (re-search-forward (concat "^\\(" regexp "\\):[ \t]*") + nil t) (push (funcall lsdb-decode-field-body-function - (buffer-substring (point) (std11-field-end)) - (match-string 1)) - field-bodies)) + (buffer-substring (point) (std11-field-end)) + (match-string 1)) + field-bodies)) (nreverse field-bodies)))) (defun lsdb-canonicalize-spaces-and-dots (string) @@ -282,69 +413,102 @@ This is the current number of slots in HASH-TABLE, whether occupied or not." (let ((components (std11-extract-address-components string))) (if (nth 1 components) (if (car components) - (list (nth 1 components) - (funcall lsdb-canonicalize-full-name-function - (car components))) + (list (funcall lsdb-canonicalize-full-name-function + (car components)) + (nth 1 components)) (list (nth 1 components) (nth 1 components)))))) ;; stolen (and renamed) from nnheader.el (defun lsdb-decode-field-body (field-body field-name &optional mode max-column) - (mime-decode-field-body field-body - (if (stringp field-name) - (intern (capitalize field-name)) - field-name) - mode max-column)) + (let ((multibyte enable-multibyte-characters)) + (unwind-protect + (progn + (set-buffer-multibyte t) + (mime-decode-field-body field-body + (if (stringp field-name) + (intern (capitalize field-name)) + field-name) + mode max-column)) + (set-buffer-multibyte multibyte)))) ;;;_. Record Management -(defun lsdb-maybe-load-file () +(defun lsdb-maybe-build-reverse-hash-table () + (unless lsdb-reverse-hash-table + (setq lsdb-reverse-hash-table (lsdb-make-hash-table :test 'equal)) + (lsdb-maphash + (lambda (key value) + (let ((net (cdr (assq 'net value)))) + (while net + (lsdb-puthash (pop net) key lsdb-reverse-hash-table)))) + lsdb-hash-table)) + (setq lsdb-hash-tables-are-dirty t)) + +(defun lsdb-maybe-load-hash-tables () (unless lsdb-hash-table (if (file-exists-p lsdb-file) - (setq lsdb-hash-table (lsdb-load-file lsdb-file)) - (setq lsdb-hash-table (lsdb-make-hash-table :test 'equal))))) + (lsdb-load-hash-tables) + (setq lsdb-hash-table (lsdb-make-hash-table :test 'equal))) + (lsdb-maybe-build-reverse-hash-table))) (defun lsdb-update-record (sender &optional interesting) - (let ((old (lsdb-gethash (nth 1 sender) lsdb-hash-table)) - (new (cons (cons 'net (list (car sender))) + (let ((old (lsdb-gethash (car sender) lsdb-hash-table)) + (new (cons (cons 'net (list (nth 1 sender))) interesting)) merged - record) + record + full-name) + ;; Look for the existing record from the reverse hash table. + ;; If it is found, regsiter the current full-name as AKA. + (unless old + (setq full-name (lsdb-gethash (nth 1 sender) lsdb-reverse-hash-table)) + (when full-name + (setq old (lsdb-gethash full-name lsdb-hash-table) + new (cons (list 'aka (car sender)) new)) + (setcar sender full-name))) (unless old (setq new (cons (cons 'creation-date (format-time-string "%Y-%m-%d")) new))) (setq merged (lsdb-merge-record-entries old new) - record (cons (nth 1 sender) merged)) + record (cons (car sender) merged)) (unless (equal merged old) - (lsdb-puthash (car record) (cdr record) lsdb-hash-table) - (setq lsdb-hash-table-is-dirty t)) + (let ((entry (assq 'last-modified (cdr record))) + (last-modified (format-time-string "%Y-%m-%d"))) + (if entry + (setcdr entry last-modified) + (setcdr record (cons (cons 'last-modified last-modified) + (cdr record))))) + (lsdb-puthash (car record) (cdr record) + lsdb-hash-table) + (setq lsdb-hash-tables-are-dirty t)) + (lsdb-puthash (nth 1 sender) (car sender) lsdb-reverse-hash-table) record)) -(defun lsdb-update-records (entity) - (lsdb-maybe-load-file) +(defun lsdb-update-records () + (lsdb-maybe-load-hash-tables) (let (senders recipients interesting alist records bodies entry) - (with-temp-buffer - (set-buffer-multibyte nil) - (buffer-disable-undo) - (mime-insert-entity entity) + (save-restriction (std11-narrow-to-header) (setq senders (delq nil (mapcar #'lsdb-extract-address-components (lsdb-fetch-field-bodies - entity lsdb-sender-headers))) + lsdb-sender-headers))) recipients (delq nil (mapcar #'lsdb-extract-address-components (lsdb-fetch-field-bodies - entity lsdb-recipients-headers)))) + lsdb-recipients-headers)))) (setq alist lsdb-interesting-header-alist) (while alist (setq bodies - (mapcar - (lambda (field-body) - (if (and (nth 1 (car alist)) - (string-match (nth 1 (car alist)) field-body)) - (replace-match (nth 3 (car alist)) nil nil field-body) - field-body)) - (lsdb-fetch-field-bodies entity (car (car alist))))) + (delq nil (mapcar + (lambda (field-body) + (if (nth 1 (car alist)) + (and (string-match (nth 1 (car alist)) + field-body) + (replace-match (nth 3 (car alist)) + nil nil field-body)) + field-body)) + (lsdb-fetch-field-bodies (car (car alist)))))) (when bodies (setq entry (or (nth 2 (car alist)) 'notes)) @@ -362,6 +526,7 @@ This is the current number of slots in HASH-TABLE, whether occupied or not." (nreverse records))) (defun lsdb-merge-record-entries (old new) + (setq old (copy-sequence old)) (while new (let ((entry (assq (car (car new)) old)) list pointer) @@ -394,116 +559,804 @@ This is the current number of slots in HASH-TABLE, whether occupied or not." (shrink-window-if-larger-than-buffer) (if (> (setq height (window-height)) lsdb-window-max-height) - (shrink-window (- height lsdb-window-max-height)) - (shrink-window-if-larger-than-buffer))))) + (shrink-window (- height lsdb-window-max-height))) + (set-window-start window (point-min))))) (defun lsdb-display-record (record) + "Display only one RECORD, then shrink the window as possible." (let ((temp-buffer-show-function (function lsdb-temp-buffer-show-function))) - (with-output-to-temp-buffer lsdb-buffer-name - (set-buffer standard-output) - (funcall lsdb-print-record-function record) - (lsdb-mode)))) + (lsdb-display-records (list record)))) + +(defun lsdb-display-records (records) + (with-output-to-temp-buffer lsdb-buffer-name + (set-buffer standard-output) + (setq records + (sort (copy-sequence records) + (or lsdb-display-records-sort-predicate + (lambda (record1 record2) + (string-lessp (car record1) (car record2)))))) + (while records + (save-restriction + (narrow-to-region (point) (point)) + (lsdb-print-record (car records))) + (goto-char (point-max)) + (setq records (cdr records))) + (lsdb-mode))) + +(defsubst lsdb-entry-score (entry) + (or (nth 1 (assq (car entry) lsdb-entry-type-alist)) 0)) + +(defun lsdb-insert-entry (entry) + (let ((entry-name (capitalize (symbol-name (car entry))))) + (intern entry-name lsdb-known-entry-names) + (if (>= (lsdb-entry-score entry) 0) + (insert "\t" entry-name ": " + (if (listp (cdr entry)) + (mapconcat + #'identity (cdr entry) + (if (eq ?, (nth 2 (assq (car entry) + lsdb-entry-type-alist))) + ", " + "\n\t\t")) + (cdr entry)) + "\n")))) (defun lsdb-print-record (record) (insert (car record) "\n") (let ((entries - (sort (cdr record) + (sort (copy-sequence (cdr record)) (lambda (entry1 entry2) - (> (or (nth 1 (assq (car entry1) lsdb-entry-type-alist)) - 0) - (or (nth 1 (assq (car entry2) lsdb-entry-type-alist)) - 0)))))) + (> (lsdb-entry-score entry1) (lsdb-entry-score entry2)))))) (while entries - (insert "\t" (capitalize (symbol-name (car (car entries)))) ": " - (if (listp (cdr (car entries))) - (mapconcat #'identity (cdr (car entries)) - (if (eq ?, (nth 2 (assq (car (car entries)) - lsdb-entry-type-alist))) - ", " - "\n\t\t")) - (cdr (car entries))) - "\n") - (setq entries (cdr entries))))) + (lsdb-insert-entry (car entries)) + (setq entries (cdr entries)))) + (add-text-properties (point-min) (point-max) + (list 'lsdb-record record)) + (run-hooks 'lsdb-print-record-hook)) ;;;_. Completion (defvar lsdb-last-completion nil) +(defvar lsdb-last-candidates nil) +(defvar lsdb-last-candidates-pointer nil) (defun lsdb-complete-name () "Complete the user full-name or net-address before point" (interactive) + (lsdb-maybe-load-hash-tables) (let* ((start (save-excursion (re-search-backward "\\(\\`\\|[\n:,]\\)[ \t]*") (goto-char (match-end 0)) (point))) - (string - (if (and (eq last-command this-command) - (stringp lsdb-last-completion)) - lsdb-last-completion - (buffer-substring start (point)))) - (pattern - (concat "\\`" string)) + pattern (case-fold-search t) - (completion-ignore-case t) - candidates) - (lsdb-maphash - (lambda (key value) - (let ((net (cdr (assq 'net value)))) - (if (string-match pattern key) - (setq candidates - (nconc candidates - (mapcar (lambda (address) - (list (concat key " <" address ">"))) - net))) - (while net - (if (string-match pattern (car net)) - (push (list (car net)) candidates)) - (setq net (cdr net)))))) - lsdb-hash-table) - (setq lsdb-last-completion (try-completion string candidates)) - (if (null lsdb-last-completion) - (error "No match") - (when (stringp lsdb-last-completion) - (delete-region start (point)) - (insert lsdb-last-completion))))) + (completion-ignore-case t)) + (unless (eq last-command this-command) + (setq lsdb-last-candidates nil + lsdb-last-candidates-pointer nil + lsdb-last-completion (buffer-substring start (point)) + pattern (concat "\\<" lsdb-last-completion)) + (lsdb-maphash + (lambda (key value) + (let ((net (cdr (assq 'net value)))) + (if (string-match pattern key) + (setq lsdb-last-candidates + (nconc lsdb-last-candidates + (mapcar (lambda (address) + (if (equal key address) + key + (concat key " <" address ">"))) + net))) + (while net + (if (string-match pattern (car net)) + (push (car net) lsdb-last-candidates)) + (setq net (cdr net)))))) + lsdb-hash-table) + ;; Sort candidates by the position where the pattern occurred. + (setq lsdb-last-candidates + (sort lsdb-last-candidates + (lambda (cand1 cand2) + (< (if (string-match pattern cand1) + (match-beginning 0)) + (if (string-match pattern cand2) + (match-beginning 0))))))) + (unless lsdb-last-candidates-pointer + (setq lsdb-last-candidates-pointer lsdb-last-candidates)) + (when lsdb-last-candidates-pointer + (delete-region start (point)) + (insert (pop lsdb-last-candidates-pointer))))) ;;;_. Major Mode (`lsdb-mode') Implementation +;;;_ : Modeline Buffer Identification +(defconst lsdb-pointer-xpm + "/* XPM */ +static char * lsdb_pointer_xpm[] = { +\"14 14 5 1\", +\" c None\", +\"+ c #FF9696\", +\"@ c #FF0000\", +\"# c #FF7575\", +\"$ c #FF5959\", +\" \", +\" +++ @@@ \", +\" +++## @@@@@ \", +\" ++### @@@@@ \", +\" +#####@@@@@ \", +\" +###$$@@@@@ \", +\" +###$$@@@@@ \", +\" ##$$$@@@@ \", +\" #$$$@@@ \", +\" $$@@@ \", +\" $@@ \", +\" @ \", +\" \", +\" \"};") + +(static-if (featurep 'xemacs) + (progn + (defvar lsdb-xemacs-modeline-left-extent + (copy-extent modeline-buffer-id-left-extent)) + + (defvar lsdb-xemacs-modeline-right-extent + (copy-extent modeline-buffer-id-right-extent)) + + (defun lsdb-modeline-buffer-identification (line) + "Decorate 1st element of `mode-line-buffer-identification' LINE. +Modify whole identification by side effect." + (let ((id (car line)) chopped) + (if (and (stringp id) (string-match "^LSDB:" id)) + (progn + (setq chopped (substring id 0 (match-end 0)) + id (substring id (match-end 0))) + (nconc + (list + (let ((glyph + (make-glyph + (nconc + (if (featurep 'xpm) + (list (vector 'xpm :data lsdb-pointer-xpm))) + (list (vector 'string :data chopped)))))) + (set-glyph-face glyph 'modeline-buffer-id) + (cons lsdb-xemacs-modeline-left-extent glyph)) + (cons lsdb-xemacs-modeline-right-extent id)) + (cdr line))) + line)))) + (condition-case nil + (progn + (require 'image) + (defun lsdb-modeline-buffer-identification (line) + "Decorate 1st element of `mode-line-buffer-identification' LINE. +Modify whole identification by side effect." + (let ((id (copy-sequence (car line))) + (image + (if (image-type-available-p 'xpm) + (create-image lsdb-pointer-xpm 'xpm t :ascent 'center)))) + (when (and image + (stringp id) (string-match "^LSDB:" id)) + (add-text-properties 0 (length id) + (list 'display image + 'rear-nonsticky (list 'display)) + id) + (setcar line id)) + line))) + (error + (defalias 'lsdb-modeline-buffer-identification 'identity)))) + +(defvar lsdb-mode-map + (let ((keymap (make-sparse-keymap))) + (define-key keymap "a" 'lsdb-mode-add-entry) + (define-key keymap "d" 'lsdb-mode-delete-entry) + (define-key keymap "e" 'lsdb-mode-edit-entry) + (define-key keymap "s" 'lsdb-mode-save) + (define-key keymap "q" 'lsdb-mode-quit-window) + (define-key keymap "g" 'lsdb-mode-lookup) + (define-key keymap "p" 'lsdb-mode-previous-record) + (define-key keymap "n" 'lsdb-mode-next-record) + (define-key keymap " " 'scroll-up) + (define-key keymap [delete] 'scroll-down) + (define-key keymap "\177" 'scroll-down) + (define-key keymap [backspace] 'scroll-down) + keymap) + "LSDB's keymap.") + +(defvar lsdb-modeline-string "") + (define-derived-mode lsdb-mode fundamental-mode "LSDB" "Major mode for browsing LSDB records." (setq buffer-read-only t) - (if (featurep 'xemacs) + (static-if (featurep 'xemacs) ;; In XEmacs, setting `font-lock-defaults' only affects on ;; `find-file-hooks'. (font-lock-set-defaults) (set (make-local-variable 'font-lock-defaults) - '(lsdb-font-lock-keywords t)))) + '(lsdb-font-lock-keywords t))) + (make-local-variable 'post-command-hook) + (setq post-command-hook 'lsdb-modeline-update) + (make-local-variable 'lsdb-modeline-string) + (setq mode-line-buffer-identification + (lsdb-modeline-buffer-identification + '("LSDB: " lsdb-modeline-string))) + (lsdb-modeline-update) + (force-mode-line-update)) + +(defun lsdb-modeline-update () + (let ((record + (get-text-property (if (eobp) (point-min) (point)) 'lsdb-record)) + net) + (if record + (progn + (setq net (car (cdr (assq 'net (cdr record))))) + (if (equal net (car record)) + (setq lsdb-modeline-string net) + (setq lsdb-modeline-string (concat (car record) " <" net ">")))) + (setq lsdb-modeline-string "")))) + +(defun lsdb-narrow-to-record () + "Narrow to the current record." + (let ((end (next-single-property-change (point) 'lsdb-record nil + (point-max)))) + (narrow-to-region + (previous-single-property-change (point) 'lsdb-record nil (point-min)) + end) + (goto-char (point-min)))) + +(defun lsdb-current-record () + "Return the current record name." + (let ((record (get-text-property (point) 'lsdb-record))) + (unless record + (error "There is nothing to follow here")) + record)) + +(defun lsdb-current-entry () + "Return the current entry name. +If the point is not on a entry line, it prompts to select a entry in +the current record." + (save-excursion + (beginning-of-line) + (if (looking-at "^[^\t]") + (let ((record (lsdb-current-record)) + (completion-ignore-case t)) + (completing-read + "Which entry to modify: " + (mapcar (lambda (entry) + (list (capitalize (symbol-name (car entry))))) + (cdr record)))) + (end-of-line) + (re-search-backward "^\t\\([^\t][^:]+\\):") + (match-string 1)))) + +(defun lsdb-mode-add-entry (entry-name) + "Add an entry on the current line." + (interactive + (let ((completion-ignore-case t)) + (list (completing-read "Entry name: " lsdb-known-entry-names)))) + (beginning-of-line) + (unless (symbolp entry-name) + (setq entry-name (intern (downcase entry-name)))) + (when (assq entry-name (cdr (lsdb-current-record))) + (error "The entry already exists")) + (let ((marker (point-marker))) + (lsdb-edit-form + nil "Editing the entry." + `(lambda (form) + (when form + (save-excursion + (set-buffer lsdb-buffer-name) + (goto-char ,marker) + (let ((record (lsdb-current-record)) + (inhibit-read-only t) + buffer-read-only) + (setcdr record (cons (cons ',entry-name form) (cdr record))) + (lsdb-puthash (car record) (cdr record) + lsdb-hash-table) + (setq lsdb-hash-tables-are-dirty t) + (beginning-of-line 2) + (add-text-properties + (point) + (progn + (lsdb-insert-entry (cons ',entry-name form)) + (point)) + (list 'lsdb-record record))))))))) + +(defun lsdb-mode-delete-entry (&optional entry-name dont-update) + "Delete the entry on the current line." + (interactive) + (let ((record (lsdb-current-record)) + entry) + (or entry-name + (setq entry-name (lsdb-current-entry))) + (setq entry (assq (intern (downcase entry-name)) (cdr record))) + (when (and entry + (not dont-update)) + (setcdr record (delq entry (cdr record))) + (lsdb-puthash (car record) (cdr record) + lsdb-hash-table) + (setq lsdb-hash-tables-are-dirty t)) + (save-restriction + (lsdb-narrow-to-record) + (let ((case-fold-search t) + (inhibit-read-only t) + buffer-read-only) + (goto-char (point-min)) + (if (re-search-forward + (concat "^\t" (or entry-name + (lsdb-current-entry)) + ":") + nil t) + (delete-region (match-beginning 0) + (if (re-search-forward + "^\t[^\t][^:]+:" nil t) + (match-beginning 0) + (point-max)))))))) + +(defun lsdb-mode-edit-entry () + "Edit the entry on the current line." + (interactive) + (let* ((record (lsdb-current-record)) + (entry-name (intern (downcase (lsdb-current-entry)))) + (entry (assq entry-name (cdr record))) + (marker (point-marker))) + (lsdb-edit-form + (cdr entry) "Editing the entry." + `(lambda (form) + (unless (equal form ',(cdr entry)) + (save-excursion + (set-buffer lsdb-buffer-name) + (goto-char ,marker) + (let* ((record (lsdb-current-record)) + (entry (assq ',entry-name (cdr record))) + (inhibit-read-only t) + buffer-read-only) + (setcdr entry form) + (setq lsdb-hash-tables-are-dirty t) + (lsdb-mode-delete-entry (symbol-name ',entry-name) t) + (beginning-of-line) + (add-text-properties + (point) + (progn + (lsdb-insert-entry (cons ',entry-name form)) + (point)) + (list 'lsdb-record record))))))))) + +(defun lsdb-mode-save (&optional dont-ask) + "Save LSDB hash table into `lsdb-file'." + (interactive) + (if (not lsdb-hash-tables-are-dirty) + (message "(No changes need to be saved)") + (when (or (interactive-p) + dont-ask + (y-or-n-p "Save the LSDB now?")) + (lsdb-save-hash-tables) + (setq lsdb-hash-tables-are-dirty nil) + (message "The LSDB was saved successfully.")))) + +(defun lsdb-mode-quit-window (&optional kill window) + "Quit the current buffer. +It partially emulates the GNU Emacs' of `quit-window'." + (interactive "P") + (unless window + (setq window (selected-window))) + (let ((buffer (window-buffer window))) + (unless (save-selected-window + (select-window window) + (one-window-p)) + (delete-window window)) + (if kill + (kill-buffer buffer) + (bury-buffer buffer)))) + +(defun lsdb-mode-hide-buffer () + "Hide the LSDB window." + (let ((window (get-buffer-window lsdb-buffer-name))) + (if window + (lsdb-mode-quit-window nil window)))) + +(defun lsdb-lookup-records (regexp &optional entry-name) + "Return the all records in the LSDB matching the REGEXP. +If the optional 2nd argument ENTRY-NAME is given, matching only +performed against the entry field." + (let (records) + (lsdb-maphash + (if entry-name + (progn + (unless (symbolp entry-name) + (setq entry-name (intern (downcase entry-name)))) + (lambda (key value) + (let ((entry (cdr (assq entry-name value))) + found) + (unless (listp entry) + (setq entry (list entry))) + (while (and (not found) entry) + (if (string-match regexp (pop entry)) + (setq found t))) + (if found + (push (cons key value) records))))) + (lambda (key value) + (if (string-match regexp key) + (push (cons key value) records)))) + lsdb-hash-table) + records)) + +(defvar lsdb-mode-lookup-history nil) + +(defun lsdb-mode-lookup (regexp &optional entry-name) + "Display the all records in the LSDB matching the REGEXP. +If the optional 2nd argument ENTRY-NAME is given, matching only +performed against the entry field." + (interactive + (let* ((completion-ignore-case t) + (entry-name + (if current-prefix-arg + (completing-read "Entry name: " + lsdb-known-entry-names)))) + (list + (read-from-minibuffer + (if entry-name + (format "Search records `%s' regexp: " entry-name) + "Search records regexp: ") + nil nil nil 'lsdb-mode-lookup-history) + entry-name))) + (lsdb-maybe-load-hash-tables) + (let ((records (lsdb-lookup-records regexp entry-name))) + (if records + (lsdb-display-records records)))) + +;;;###autoload +(defalias 'lsdb 'lsdb-mode-lookup) + +(defun lsdb-mode-next-record (&optional arg) + "Go to the next record." + (interactive "p") + (unless arg ;called noninteractively? + (setq arg 1)) + (if (< arg 0) + (lsdb-mode-previous-record (- arg)) + (while (> arg 0) + (goto-char (next-single-property-change + (point) 'lsdb-record nil (point-max))) + (setq arg (1- arg))))) + +(defun lsdb-mode-previous-record (&optional arg) + "Go to the previous record." + (interactive "p") + (unless arg ;called noninteractively? + (setq arg 1)) + (if (< arg 0) + (lsdb-mode-next-record (- arg)) + (while (> arg 0) + (goto-char (previous-single-property-change + (point) 'lsdb-record nil (point-min))) + (setq arg (1- arg))))) + +;;;_ : Edit Forms -- stolen (and renamed) from gnus-eform.el +(defvar lsdb-edit-form-buffer "*LSDB edit form*") +(defvar lsdb-edit-form-done-function nil) +(defvar lsdb-previous-window-configuration nil) + +(defvar lsdb-edit-form-mode-map + (let ((keymap (make-sparse-keymap))) + (set-keymap-parent keymap emacs-lisp-mode-map) + (define-key keymap "\C-c\C-c" 'lsdb-edit-form-done) + (define-key keymap "\C-c\C-k" 'lsdb-edit-form-exit) + keymap) + "Edit form's keymap.") + +(defun lsdb-edit-form-mode () + "Major mode for editing forms. +It is a slightly enhanced emacs-lisp-mode. + +\\{lsdb-edit-form-mode-map}" + (interactive) + (kill-all-local-variables) + (setq major-mode 'lsdb-edit-form-mode + mode-name "LSDB Edit Form") + (use-local-map lsdb-edit-form-mode-map) + (make-local-variable 'lsdb-edit-form-done-function) + (make-local-variable 'lsdb-previous-window-configuration) + (run-hooks 'lsdb-edit-form-mode-hook)) + +(defun lsdb-edit-form (form documentation exit-func) + "Edit FORM in a new buffer. +Call EXIT-FUNC on exit. Display DOCUMENTATION in the beginning +of the buffer." + (let ((window-configuration + (current-window-configuration))) + (switch-to-buffer (get-buffer-create lsdb-edit-form-buffer)) + (lsdb-edit-form-mode) + (setq lsdb-previous-window-configuration window-configuration + lsdb-edit-form-done-function exit-func) + (erase-buffer) + (insert documentation) + (unless (bolp) + (insert "\n")) + (goto-char (point-min)) + (while (not (eobp)) + (insert ";;; ") + (forward-line 1)) + (insert ";; Type `C-c C-c' after you've finished editing.\n") + (insert "\n") + (let ((p (point))) + (pp form (current-buffer)) + (insert "\n") + (goto-char p)))) + +(defun lsdb-edit-form-done () + "Update changes and kill the current buffer." + (interactive) + (goto-char (point-min)) + (let ((form (condition-case nil + (read (current-buffer)) + (end-of-file nil))) + (func lsdb-edit-form-done-function)) + (lsdb-edit-form-exit) + (funcall func form))) + +(defun lsdb-edit-form-exit () + "Kill the current buffer." + (interactive) + (let ((window-configuration lsdb-previous-window-configuration)) + (kill-buffer (current-buffer)) + (set-window-configuration window-configuration))) ;;;_. Interface to Semi-gnus ;;;###autoload (defun lsdb-gnus-insinuate () "Call this function to hook LSDB into Semi-gnus." (add-hook 'gnus-article-prepare-hook 'lsdb-gnus-update-record) - (add-hook 'gnus-save-newsrc-hook 'lsdb-gnus-offer-save)) - -(defvar message-mode-map) -(defun lsdb-gnus-insinuate-message () - "Call this function to hook LSDB into Message mode." - (define-key message-mode-map "\M-\t" 'lsdb-complete-name)) + (add-hook 'gnus-save-newsrc-hook 'lsdb-mode-save)) (defvar gnus-current-headers) (defun lsdb-gnus-update-record () - (let ((records (lsdb-update-records gnus-current-headers))) + (let ((entity gnus-current-headers) + records) + (with-temp-buffer + (set-buffer-multibyte nil) + (buffer-disable-undo) + (mime-insert-entity entity) + (setq records (lsdb-update-records)) + (when records + (lsdb-display-record (car records)))))) + +;;;_. Interface to Wanderlust +;;;###autoload +(defun lsdb-wl-insinuate () + "Call this function to hook LSDB into Wanderlust." + (add-hook 'wl-message-redisplay-hook 'lsdb-wl-update-record) + (add-hook 'wl-summary-exit-hook 'lsdb-mode-hide-buffer) + (add-hook 'wl-exit-hook 'lsdb-mode-save) + (add-hook 'wl-save-hook 'lsdb-mode-save)) + +(eval-when-compile + (autoload 'wl-message-get-original-buffer "wl-message")) +(defun lsdb-wl-update-record () + (save-excursion + (set-buffer (wl-message-get-original-buffer)) + (let ((records (lsdb-update-records))) + (when records + (lsdb-display-record (car records)))))) + +;;;_. Interface to Mew written by Hideyuki SHIRAI +(eval-when-compile + (autoload 'mew-sinfo-get-disp-msg "mew") + (autoload 'mew-current-get-fld "mew") + (autoload 'mew-current-get-msg "mew") + (autoload 'mew-frame-id "mew") + (autoload 'mew-cache-hit "mew")) + +;;;###autoload +(defun lsdb-mew-insinuate () + "Call this function to hook LSDB into Mew." + (add-hook 'mew-message-hook 'lsdb-mew-update-record) + (add-hook 'mew-summary-toggle-disp-msg-hook + (lambda () + (unless (mew-sinfo-get-disp-msg) + (lsdb-mode-hide-buffer)))) + (add-hook 'mew-suspend-hook 'lsdb-mode-hide-buffer) + (add-hook 'mew-quit-hook 'lsdb-mode-save) + (add-hook 'kill-emacs-hook 'lsdb-mode-save)) + +(defun lsdb-mew-update-record () + (let* ((fld (mew-current-get-fld (mew-frame-id))) + (msg (mew-current-get-msg (mew-frame-id))) + (cache (mew-cache-hit fld msg 'must-hit)) + records) + (save-excursion + (set-buffer cache) + (make-local-variable 'lsdb-decode-field-body-function) + (setq lsdb-decode-field-body-function + (lambda (body name) + (set-text-properties 0 (length body) nil body) + body)) + (when (setq records (lsdb-update-records)) + (lsdb-display-record (car records)))))) + +;;;_. Interface to MU-CITE +(eval-when-compile + (autoload 'mu-cite-get-value "mu-cite")) + +(defun lsdb-mu-attribution (address) + "Extract attribute information from LSDB." + (let ((records + (lsdb-lookup-records (concat "\\<" address "\\>") 'net))) + (if records + (cdr (assq 'attribution (cdr (car records))))))) + +(defun lsdb-mu-set-attribution (attribution address) + "Add attribute information to LSDB." + (let ((records + (lsdb-lookup-records (concat "\\<" address "\\>") 'net)) + entry) (when records - (lsdb-display-record (car records))))) + (setq entry (assq 'attribution (cdr (car records)))) + (if entry + (setcdr entry attribution) + (setcdr (car records) (cons (cons 'attribution attribution) + (cdr (car records)))) + (lsdb-puthash (car (car records)) (cdr (car records)) + lsdb-hash-table) + (setq lsdb-hash-tables-are-dirty t))))) + +(defun lsdb-mu-get-prefix-method () + "A mu-cite method to return a prefix from LSDB or \">\". +If an `attribution' value is found in LSDB, the value is returned. +Otherwise \">\" is returned." + (or (lsdb-mu-attribution (mu-cite-get-value 'address)) + ">")) + +(defvar minibuffer-allow-text-properties) -(defun lsdb-gnus-offer-save () - (if (and lsdb-hash-table-is-dirty - (y-or-n-p "Save the LSDB now?")) - (lsdb-save-file lsdb-file lsdb-hash-table))) +(defvar lsdb-mu-history nil) +(defun lsdb-mu-get-prefix-register-method () + "A mu-cite method to return a prefix from LSDB or register it. +If an `attribution' value is found in LSDB, the value is returned. +Otherwise the function requests a prefix from a user. The prefix will +be registered to LSDB if the user wants it." + (let ((address (mu-cite-get-value 'address))) + (or (lsdb-mu-attribution address) + (let* (minibuffer-allow-text-properties + (result (read-string "Citation name? " + (or (mu-cite-get-value 'x-attribution) + (mu-cite-get-value 'full-name)) + 'lsdb-mu-history))) + (if (and (not (string-equal result "")) + (y-or-n-p (format "Register \"%s\"? " result))) + (lsdb-mu-set-attribution result address)) + result)))) + +(defun lsdb-mu-get-prefix-register-verbose-method () + "A mu-cite method to return a prefix using LSDB. + +In this method, a user must specify a prefix unconditionally. If an +`attribution' value is found in LSDB, the value is used as a initial +value to input the prefix. The prefix will be registered to LSDB if +the user wants it." + (let* ((address (mu-cite-get-value 'address)) + (attribution (lsdb-mu-attribution address)) + minibuffer-allow-text-properties + (result (read-string "Citation name? " + (or attribution + (mu-cite-get-value 'x-attribution) + (mu-cite-get-value 'full-name)) + 'lsdb-mu-history))) + (if (and (not (string-equal result "")) + (not (string-equal result attribution)) + (y-or-n-p (format "Register \"%s\"? " result))) + (lsdb-mu-set-attribution result address)) + result)) + +(defvar mu-cite-methods-alist) +;;;###autoload +(defun lsdb-mu-insinuate () + (add-hook 'mu-cite-instantiation-hook + (lambda () + (setq mu-cite-methods-alist + (nconc + mu-cite-methods-alist + (list + (cons 'lsdb-prefix + #'lsdb-mu-get-prefix-method) + (cons 'lsdb-prefix-register + #'lsdb-mu-get-prefix-register-method) + (cons 'lsdb-prefix-register-verbose + #'lsdb-mu-get-prefix-register-verbose-method))))))) + +;;;_. X-Face Rendering +(defvar lsdb-x-face-cache + (lsdb-make-hash-table :test 'equal)) + +(defun lsdb-x-face-available-image-type () + (static-if (featurep 'xemacs) + (if (featurep 'xpm) + 'xpm) + (and (>= emacs-major-version 21) + (fboundp 'image-type-available-p) + (if (image-type-available-p 'pbm) + 'pbm + (if (image-type-available-p 'xpm) + 'xpm))))) + +(defun lsdb-expose-x-face () + (let* ((record (get-text-property (point-min) 'lsdb-record)) + (x-face (cdr (assq 'x-face (cdr record)))) + (delimiter "\r ")) + (when (and lsdb-insert-x-face-function + x-face) + (goto-char (point-min)) + (end-of-line) + (put-text-property 0 1 'invisible t delimiter) ;hide "\r" + (put-text-property + (point) + (progn + (insert delimiter) + (while x-face + (funcall lsdb-insert-x-face-function (pop x-face))) + (point)) + 'lsdb-record record)))) + +(defun lsdb-insert-x-face-image (data type marker) + (static-if (featurep 'xemacs) + (save-excursion + (set-buffer (marker-buffer marker)) + (goto-char marker) + (let* ((inhibit-read-only t) + buffer-read-only + (glyph (make-glyph (vector type :data data)))) + (set-extent-begin-glyph + (make-extent (point) (point)) + glyph))) + (save-excursion + (set-buffer (marker-buffer marker)) + (goto-char marker) + (let* ((inhibit-read-only t) + buffer-read-only + (image (create-image data type t :ascent 'center)) + (record (get-text-property (point) 'lsdb-record))) + (put-text-property (point) (progn + (insert-image image) + (point)) + 'lsdb-record record))))) + +(defun lsdb-insert-x-face-asynchronously (x-face) + (let* ((type (lsdb-x-face-available-image-type)) + (shell-file-name lsdb-shell-file-name) + (shell-command-switch lsdb-shell-command-switch) + (process-connection-type nil) + (cached (cdr (assq type (lsdb-gethash x-face lsdb-x-face-cache)))) + (marker (point-marker)) + process) + (if cached + (lsdb-insert-x-face-image cached type marker) + (setq process + (start-process-shell-command + "lsdb-x-face-command" (generate-new-buffer " *lsdb work*") + (concat "{ " + (nth 1 (assq type lsdb-x-face-command-alist)) + "; } 2> /dev/null"))) + (process-send-string process (concat x-face "\n")) + (process-send-eof process) + (set-process-sentinel + process + `(lambda (process string) + (unwind-protect + (when (and (buffer-live-p (marker-buffer ,marker)) + (equal string "finished\n")) + (let ((data + (with-current-buffer (process-buffer process) + (set-buffer-multibyte nil) + (buffer-string)))) + (lsdb-insert-x-face-image data ',type ,marker) + (lsdb-puthash ,x-face (list (cons ',type data)) + lsdb-x-face-cache))) + (kill-buffer (process-buffer process)))))))) + +(require 'product) (provide 'lsdb) +(product-provide 'lsdb + (product-define "LSDB" nil '(0 2))) + ;;;_* Local emacs vars. ;;; The following `outline-layout' local variable setting: ;;; - closes all topics from the first topic to just before the third-to-last,