;;; (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)
(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)
+ ("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))
(defcustom lsdb-entry-type-alist
'((net 5 ?,)
- (creation-date 2)
- (last-modified 3)
+ (creation-date 2 ?. t)
+ (last-modified 3 ?. t)
(mailing-list 4 ?,)
(attribution 4 ?.)
(organization 4)
- (www 1)
+ (www 4)
+ (aka 4)
(score -1)
(x-face -1))
- "Alist of entries to display.
+ "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)
:group 'lsdb
:type 'integer)
-(defgroup lsdb-x-face nil
- "The Lovely Sister Database, X-Face related settings."
- :group 'lsdb)
-
-(defcustom lsdb-display-small-x-face nil
- "If non-nil, downscale the size of X-Face image."
- :group 'lsdb-x-face
- :type 'float)
-
-(defcustom lsdb-uncompface-program (exec-installed-p "uncompface")
- "Name of the uncompface program."
- :group 'lsdb-x-face
- :type 'file)
+(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
- (and lsdb-uncompface-program
- (or (>= emacs-major-version 21)
- (and (featurep 'xemacs)
- (memq 'xbm (image-instantiator-format-list))))
- #'lsdb-insert-x-face)
- "A function to display X-Face."
- :group 'lsdb-x-face
+ (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-display-record-hook
- (if lsdb-insert-x-face-function
- #'lsdb-expose-x-face)
+(defcustom lsdb-print-record-hook '(lsdb-expose-x-face)
"A hook called after a record is displayed."
:group 'lsdb
:type 'hook)
: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)))
(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)
(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."
- (let ((buffer (find-file-noselect file)))
- (unwind-protect
- (save-excursion
- (set-buffer buffer)
- (re-search-forward "^#s")
- (beginning-of-line)
- (read (point-min-marker)))
- (kill-buffer buffer)))))
+ (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
- (symbol-name (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 (regexp)
(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
(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)
(let ((entry (assq 'last-modified (cdr record)))
(last-modified (format-time-string "%Y-%m-%d")))
(cdr record)))))
(lsdb-puthash (car record) (cdr record)
lsdb-hash-table)
- (setq lsdb-hash-table-is-dirty t))
+ (setq lsdb-hash-tables-are-dirty t))
+ (lsdb-puthash (nth 1 sender) (car sender) lsdb-reverse-hash-table)
record))
(defun lsdb-update-records ()
- (lsdb-maybe-load-file)
+ (lsdb-maybe-load-hash-tables)
(let (senders recipients interesting alist records bodies entry)
(save-restriction
(std11-narrow-to-header)
(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 (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))
(while records
(save-restriction
(narrow-to-region (point) (point))
- (lsdb-print-record (car records))
- (add-text-properties (point-min) (point-max)
- (list 'lsdb-record (car records)))
- (run-hooks 'lsdb-display-record-hook))
+ (lsdb-print-record (car records)))
(goto-char (point-max))
(setq records (cdr records)))
(lsdb-mode)))
(> (lsdb-entry-score entry1) (lsdb-entry-score entry2))))))
(while entries
(lsdb-insert-entry (car entries))
- (setq entries (cdr 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)
(defun lsdb-complete-name ()
"Complete the user full-name or net-address before point"
(interactive)
- (lsdb-maybe-load-file)
+ (lsdb-maybe-load-hash-tables)
(let* ((start
(save-excursion
(re-search-backward "\\(\\`\\|[\n:,]\\)[ \t]*")
(if (string-match pattern (car net))
(push (car net) lsdb-last-candidates))
(setq net (cdr net))))))
- lsdb-hash-table))
+ 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
(if (featurep 'xpm)
(list (vector 'xpm :data lsdb-pointer-xpm)))
(list (vector 'string :data chopped))))))
- (if glyph
- (progn
- (set-glyph-face glyph 'modeline-buffer-id)
- (cons lsdb-xemacs-modeline-left-extent glyph))
- (cons lsdb-xemacs-modeline-left-extent
- 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))))
(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)
(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))
+ (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]")
(setcdr record (cons (cons ',entry-name form) (cdr record)))
(lsdb-puthash (car record) (cdr record)
lsdb-hash-table)
- (setq lsdb-hash-table-is-dirty t)
+ (setq lsdb-hash-tables-are-dirty t)
(beginning-of-line 2)
(add-text-properties
(point)
(setcdr record (delq entry (cdr record)))
(lsdb-puthash (car record) (cdr record)
lsdb-hash-table)
- (setq lsdb-hash-table-is-dirty t))
+ (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)
(setcdr entry form)
- (setq lsdb-hash-table-is-dirty t)
+ (setq lsdb-hash-tables-are-dirty t)
(lsdb-mode-delete-entry (symbol-name ',entry-name) t)
(beginning-of-line)
(add-text-properties
(point))
(list 'lsdb-record record)))))))))
-(defun lsdb-mode-save (&optional ask)
+(defun lsdb-mode-save (&optional dont-ask)
"Save LSDB hash table into `lsdb-file'."
(interactive)
- (if (not lsdb-hash-table-is-dirty)
+ (if (not lsdb-hash-tables-are-dirty)
(message "(No changes need to be saved)")
(when (or (interactive-p)
- (not ask)
+ dont-ask
(y-or-n-p "Save the LSDB now?"))
- (lsdb-save-file lsdb-file lsdb-hash-table)
- (setq lsdb-hash-table-is-dirty nil)
+ (lsdb-save-hash-tables)
+ (setq lsdb-hash-tables-are-dirty nil)
(message "The LSDB was saved successfully."))))
-(if (commandp 'quit-window)
- (defalias 'lsdb-mode-quit-window 'quit-window)
- (defun lsdb-mode-quit-window ()
- "Quit the current buffer."
- (interactive)
- (if (one-window-p)
- (bury-buffer)
- (delete-window))))
+(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
(defvar lsdb-mode-lookup-history nil)
(defun lsdb-mode-lookup (regexp &optional entry-name)
- "Display all entries in the LSDB matching the REGEXP."
+ "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
"Search records regexp: ")
nil nil nil 'lsdb-mode-lookup-history)
entry-name)))
- (lsdb-maybe-load-file)
+ (lsdb-maybe-load-hash-tables)
(let ((records (lsdb-lookup-records regexp entry-name)))
(if records
(lsdb-display-records records))))
(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-wl-hide-buffer)
- (add-hook 'wl-exit-hook 'lsdb-mode-save))
+ (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))
(when records
(lsdb-display-record (car records))))))
-(defun lsdb-wl-hide-buffer ()
- (let ((window (get-buffer-window lsdb-buffer-name)))
- (if window
- (delete-window window))))
+;;;_. Interface to Mew written by Hideyuki SHIRAI <shirai@rdmg.mgcs.mei.co.jp>
+(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
(cdr (car records))))
(lsdb-puthash (car (car records)) (cdr (car records))
lsdb-hash-table)
- (setq lsdb-hash-table-is-dirty t)))))
+ (setq lsdb-hash-tables-are-dirty t)))))
(defun lsdb-mu-get-prefix-method ()
"A mu-cite method to return a prefix from LSDB or \">\".
#'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))))
- (limit "\r"))
+ (delimiter "\r "))
(when (and lsdb-insert-x-face-function
x-face)
(goto-char (point-min))
(end-of-line)
- (if (fboundp 'propertize)
- (insert (propertize limit 'invisible t) " ")
- (put-text-property 0 1 'invisible t limit)
- (insert limit " "))
- (while x-face
- (funcall lsdb-insert-x-face-function (pop x-face))))))
-
-(defun lsdb-call-process-on-string
- (program string &optional buffer &rest args)
- (if (eq buffer t)
- (setq buffer (current-buffer)))
- (let ((process (apply #'start-process program buffer program args))
- status exit-status)
- (unwind-protect
- (progn
- (set-process-sentinel process #'ignore) ;don't insert exit status
- (process-send-string process string)
- (process-send-eof process)
- (while (eq 'run (process-status process))
- (accept-process-output process 5))
- (setq status (process-status process)
- exit-status (process-exit-status process))
- (if (memq status '(stop signal))
- (error "%s exited abnormally: '%s'" program exit-status))
- (if (= 127 exit-status)
- (error "%s could not be found" program))
- (delete-process process))
- (if (and process (eq 'run (process-status process)))
- (interrupt-process process)))))
-
-(eval-and-compile
- (defun lsdb-mirror-bits (bits nbits)
- (if (= nbits 1)
- bits
- (logior (lsh (lsdb-mirror-bits (logand bits (1- (lsh 1 (/ nbits 2))))
- (/ nbits 2))
- (/ nbits 2))
- (lsdb-mirror-bits (lsh bits (- (/ nbits 2)))
- (/ nbits 2))))))
-(defconst lsdb-mirror-bytes
- (eval-when-compile
- (let ((table (make-vector 256 0))
- (i 0))
- (while (< i 256)
- (aset table i (logxor (lsdb-mirror-bits i 8) 255))
- (setq i (1+ i)))
- table)))
-
-(defun lsdb-convert-x-face-to-xbm (x-face &optional bit-reverse)
- (with-temp-buffer
- (lsdb-call-process-on-string
- lsdb-uncompface-program (concat x-face "\n") t)
- (set-buffer-multibyte nil)
- (let* ((result (make-string 288 ?\0))
- (index 0))
- (goto-char (point-min))
- (while (re-search-forward
- "0x\\([0-9A-F][0-9A-F]\\)\\([0-9A-F][0-9A-F]\\),\n?" nil
- t)
- (aset result
- (prog1 index
- (setq index (1+ index)))
- (car (read-from-string
- (concat "?\\x" (match-string 1)))))
- (aset result
- (prog1 index
- (setq index (1+ index)))
- (car (read-from-string
- (concat "?\\x" (match-string 2))))))
- (when bit-reverse
- (setq index 0)
- (while (< index 288)
- (aset result index
- (aref lsdb-mirror-bytes (aref result index)))
- (setq index (1+ index))))
- (list 48 48 result))))
-
-(autoload 'xbm-make-thumbnail "xbm-thumb")
-
-(defun lsdb-insert-x-face (x-face)
- (let ((data
- (if lsdb-display-small-x-face
- (xbm-make-thumbnail (lsdb-convert-x-face-to-xbm x-face t))
- (lsdb-convert-x-face-to-xbm x-face t))))
- (static-if (featurep 'xemacs)
- (let ((glyph (make-glyph (vector 'xbm :data data))))
- (if glyph
- (set-extent-end-glyph
- (make-extent (point) (point))
- glyph)))
- (insert-image
- (create-image
- (nth 2 data) 'xbm t :width (car data) :height (nth 1 data))))))
+ (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)
projects / elisp / lsdb.git / blobdiff