From fb81740331b97c490a4986e4237cbbc95b99ae38 Mon Sep 17 00:00:00 2001 From: ueno Date: Fri, 26 Apr 2002 22:46:00 +0000 Subject: [PATCH] * lsdb.el: Require pces for find-coding-system. (lsdb-file-coding-system): Call find-coding-system when setting the default value. (lsdb-save-file): Convert coding-system-name into string. (lsdb-lookup-records): Splitted from lsdb-mode-lookup. (lsdb-mu-attribution): New function. (lsdb-mu-set-attribution): New function. (lsdb-mu-get-prefix-method): New function. (lsdb-mu-get-prefix-register-method): New function. (lsdb-mu-get-prefix-register-verbose-method): New function. (lsdb-mu-insinuate): New function. (lsdb-mu-history): New variable. --- lsdb.el | 140 +++++++++++++++++++++++++++++++++++++++++++++++++++++---------- 1 file changed, 118 insertions(+), 22 deletions(-) diff --git a/lsdb.el b/lsdb.el index 94ad1f3..8391f1c 100644 --- a/lsdb.el +++ b/lsdb.el @@ -42,6 +42,7 @@ ;;; Code: (require 'poem) +(require 'pces) (require 'mime) ;;;_* USER CUSTOMIZATION VARIABLES: @@ -55,7 +56,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) @@ -299,7 +300,7 @@ This is the current number of slots in HASH-TABLE, whether occupied or not." (if (symbolp lsdb-file-coding-system) (symbol-name lsdb-file-coding-system) ;; XEmacs - (coding-system-name lsdb-file-coding-system)) + (symbol-name (coding-system-name lsdb-file-coding-system))) " -*-\n")) (insert "#s(hash-table size " (number-to-string (lsdb-hash-table-size hash-table)) @@ -717,6 +718,29 @@ This is the current number of slots in HASH-TABLE, whether occupied or not." (bury-buffer) (delete-window)))) +(defun lsdb-lookup-records (regexp &optional entry-name) + (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) @@ -734,26 +758,10 @@ This is the current number of slots in HASH-TABLE, whether occupied or not." "Search records regexp: ") nil nil nil 'lsdb-mode-lookup-history) entry-name))) - (let (records) - (lsdb-maybe-load-file) - (lsdb-maphash - (if entry-name - (lambda (key value) - (let ((entry (cdr (assq (intern (downcase 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) - (lsdb-display-records records))) + (lsdb-maybe-load-file) + (let ((records (lsdb-lookup-records regexp entry-name))) + (if records + (lsdb-display-records records)))) ;;;###autoload (defalias 'lsdb 'lsdb-mode-lookup) @@ -891,6 +899,94 @@ of the buffer." (if window (delete-window window)))) +;;;_. Interface to 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 + (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-table-is-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) + +(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 (defun lsdb-expose-x-face () (let* ((record (get-text-property (point-min) 'lsdb-record)) -- 1.7.10.4