X-Git-Url: http://git.chise.org/gitweb/?a=blobdiff_plain;f=lsdb.el;h=9397d0442f4ca51492a41ddce6e55dc4d6d4d098;hb=52f0ea1a1fb1b7d01251fd1d5293fa1e1bf3e7d6;hp=57be8d3d27344e64120bb953dc619d05cab3f2d9;hpb=50aa9861c0c79fa2ddb028e9e0b220c667a411e7;p=elisp%2Flsdb.git diff --git a/lsdb.el b/lsdb.el index 57be8d3..9397d04 100644 --- a/lsdb.el +++ b/lsdb.el @@ -100,6 +100,7 @@ ("\\(X-URL\\|X-URI\\)" nil www) ("X-Attribution\\|X-cite-me" nil attribution) ("X-Face" nil x-face) + ("Face" nil face) (,lsdb-sender-headers nil sender)) "Alist of headers we are interested in. The format of elements of this list should be @@ -119,6 +120,7 @@ where the last three elements are optional." (aka 4 ?,) (score -1) (x-face -1) + (face -1) (sender -1)) "Alist of entry types for presentation. The format of elements of this list should be @@ -182,9 +184,14 @@ If non-nil, supersedes the return value of `lsdb-x-face-available-image-type'." :group 'lsdb :type 'symbol) +(defcustom lsdb-x-face-scale-factor 0.5 + "A number used to scale down or scale up X-Face images." + :group 'lsdb + :type 'number) + (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")) + '((pbm "{ echo '/* Width=48, Height=48 */'; uncompface; } | icontopbm | pnmscale " scale-factor) + (xpm "{ echo '/* Width=48, Height=48 */'; uncompface; } | icontopbm | pnmscale " scale-factor " | 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." @@ -203,7 +210,40 @@ The compressed face will be piped to this command." :group 'lsdb :type 'function) -(defcustom lsdb-print-record-hook '(lsdb-expose-x-face) +(defcustom lsdb-face-image-type nil + "A image type of displayed face. +If non-nil, supersedes the return value of `lsdb-x-face-available-image-type'." + :group 'lsdb + :type 'symbol) + +(defcustom lsdb-face-scale-factor 0.5 + "A number used to scale down or scale up Face images." + :group 'lsdb + :type 'number) + +(defcustom lsdb-face-command-alist + '((png "pngtopnm | pnmscale " scale-factor " | pnmtopng") + (xpm "pngtopnm | pnmscale " scale-factor " | ppmtoxpm")) + "An alist from an image type to a command to be executed to display a Face header. +The command will be executed in a sub-shell asynchronously. +The decoded field-body (actually a PNG data) will be piped to this command." + :group 'lsdb + :type 'list) + +(defcustom lsdb-insert-face-function + (if (static-if (featurep 'xemacs) + (or (featurep 'png) + (featurep 'xpm)) + (and (>= emacs-major-version 21) + (fboundp 'image-type-available-p) + (or (image-type-available-p 'png) + (image-type-available-p 'xpm)))) + #'lsdb-insert-face-asynchronously) + "Function to display Face." + :group 'lsdb + :type 'function) + +(defcustom lsdb-print-record-hook '(lsdb-expose-x-face lsdb-expose-face) "A hook called after a record is displayed." :group 'lsdb :type 'hook) @@ -320,6 +360,16 @@ It represents address to full-name mapping.") The function is called with one argument, the buffer to be displayed. Overrides `temp-buffer-show-function'.") +;;;_. Utility functions +(defun lsdb-substitute-variables (program variable value) + (setq program (copy-sequence program)) + (let ((pointer program)) + (while pointer + (setq pointer (memq variable program)) + (if pointer + (setcar pointer value))) + program)) + ;;;_. Hash Table Emulation (if (and (fboundp 'make-hash-table) (subrp (symbol-function 'make-hash-table))) @@ -452,11 +502,11 @@ This is the current number of slots in HASH-TABLE, whether occupied or not." ;; 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 (") + " test equal data (\n") (lsdb-maphash (lambda (key value) (let (print-level print-length) - (insert (prin1-to-string key) " " (prin1-to-string value) " "))) + (insert (prin1-to-string key) " " (prin1-to-string value) "\n"))) hash-table) (insert "))")) @@ -488,17 +538,16 @@ This is the current number of slots in HASH-TABLE, whether occupied or not." (setq tables (cdr tables)))))) ;;;_. Mail Header Extraction -(defun lsdb-fetch-field-bodies (regexp) +(defun lsdb-fetch-fields (regexp) (save-excursion (goto-char (point-min)) (let ((case-fold-search t) field-bodies) (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)) + (push (cons (match-string 1) + (buffer-substring (point) (std11-field-end))) + field-bodies)) (nreverse field-bodies)))) (defun lsdb-canonicalize-spaces-and-dots (string) @@ -609,8 +658,10 @@ This is the current number of slots in HASH-TABLE, whether occupied or not." ;;;_ : Update Records (defun lsdb-update-record (sender &optional interesting) (let ((old (lsdb-gethash (car sender) lsdb-hash-table)) - (new (cons (cons 'net (list (nth 1 sender))) - interesting)) + (new (if (nth 1 sender) + (cons (cons 'net (list (nth 1 sender))) + interesting) + interesting)) merged record full-name) @@ -649,25 +700,46 @@ This is the current number of slots in HASH-TABLE, whether occupied or not." (save-restriction (std11-narrow-to-header) (setq senders - (delq nil (mapcar #'lsdb-extract-address-components - (lsdb-fetch-field-bodies + (delq nil (mapcar (lambda (field) + (let ((components + (lsdb-extract-address-components + (cdr field)))) + (if components + (setcar + components + (funcall lsdb-decode-field-body-function + (car components) (car field)))) + components)) + (lsdb-fetch-fields lsdb-sender-headers))) recipients - (delq nil (mapcar #'lsdb-extract-address-components - (lsdb-fetch-field-bodies + (delq nil (mapcar (lambda (field) + (let ((components + (lsdb-extract-address-components + (cdr field)))) + (if components + (setcar + components + (funcall lsdb-decode-field-body-function + (car components) (car field)))) + components)) + (lsdb-fetch-fields lsdb-recipients-headers)))) (setq alist lsdb-interesting-header-alist) (while alist (setq bodies (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)))))) + (lambda (field) + (let ((field-body + (funcall lsdb-decode-field-body-function + (cdr field) (car field)))) + (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-fields (car (car alist)))))) (when bodies (setq entry (or (nth 2 (car alist)) 'notes)) @@ -1234,12 +1306,15 @@ then the name of this record will be edited." (lsdb-mode-edit-entry) (lsdb-mode-edit-record))) -(defun lsdb-mode-save (&optional dont-ask) +(defun lsdb-mode-save (&optional force) "Save LSDB hash table into `lsdb-file'." - (interactive (list t)) - (if (not lsdb-hash-tables-are-dirty) + (interactive "P") + (if (not (or force + lsdb-hash-tables-are-dirty)) (message "(No changes need to be saved)") - (when (or dont-ask + (when (or (interactive-p) ;Don't ask user if this + ;function is called as a + ;command. (not lsdb-verbose) (y-or-n-p "Save the LSDB now? ")) (lsdb-save-hash-tables) @@ -1736,37 +1811,153 @@ the user wants it." (process-connection-type nil) (cached (cdr (assq type (lsdb-gethash x-face lsdb-x-face-cache)))) (marker (point-marker)) + (buffer (generate-new-buffer " *lsdb work*")) 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*") + "lsdb-x-face-command" buffer (concat "{ " - (nth 1 (assq type lsdb-x-face-command-alist)) + (apply #'concat + (lsdb-substitute-variables + (cdr (assq type lsdb-x-face-command-alist)) + 'scale-factor + (number-to-string lsdb-x-face-scale-factor))) "; } 2> /dev/null"))) + (set-process-filter + process + `(lambda (process string) + (save-excursion + (set-buffer ,buffer) + (goto-char (point-max)) + (insert string)))) + (set-process-sentinel + process + `(lambda (process string) + (unwind-protect + (if (equal string "finished\n") + (let ((data + (with-current-buffer ,buffer + (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 ,buffer)))) (process-send-string process (concat x-face "\n")) - (process-send-eof process) + (process-send-eof process)))) + +;;;_. Face Rendering +(defvar lsdb-face-cache + (lsdb-make-hash-table :test 'equal)) + +(defun lsdb-face-available-image-type () + (static-if (featurep 'xemacs) + (if (featurep 'png) + 'png + (if (featurep 'xpm) + 'xpm)) + (and (>= emacs-major-version 21) + (fboundp 'image-type-available-p) + (if (image-type-available-p 'png) + 'png + (if (image-type-available-p 'xpm) + 'xpm))))) + +(defun lsdb-expose-face () + (let* ((record (get-text-property (point-min) 'lsdb-record)) + (face (cdr (assq 'face (cdr record)))) + (delimiter "\r ")) + (when (and lsdb-insert-face-function + 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 face + (funcall lsdb-insert-face-function (pop face))) + (point)) + 'lsdb-record record)))) + +(defun lsdb-insert-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-face-asynchronously (face) + (let* ((type (or lsdb-face-image-type + (lsdb-face-available-image-type))) + (shell-file-name lsdb-shell-file-name) + (shell-command-switch lsdb-shell-command-switch) + (coding-system-for-read 'binary) + (coding-system-for-write 'binary) + (process-connection-type nil) + (cached (cdr (assq type (lsdb-gethash face lsdb-face-cache)))) + (marker (point-marker)) + (buffer (generate-new-buffer " *lsdb work*")) + process) + (if cached + (lsdb-insert-face-image cached type marker) + (setq process + (start-process-shell-command + "lsdb-face-command" buffer + (concat "{ " + (apply #'concat + (lsdb-substitute-variables + (cdr (assq type lsdb-face-command-alist)) + 'scale-factor + (number-to-string lsdb-face-scale-factor))) + "; } 2> /dev/null"))) + (set-process-filter + process + `(lambda (process string) + (save-excursion + (set-buffer ,buffer) + (goto-char (point-max)) + (insert string)))) (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)))))))) + (if (equal string "finished\n") + (let ((data + (with-current-buffer ,buffer + (set-buffer-multibyte nil) + (buffer-string)))) + (lsdb-insert-face-image data ',type ,marker) + (lsdb-puthash ,face (list (cons ',type data)) + lsdb-face-cache))) + (kill-buffer ,buffer)))) + (process-send-string process (base64-decode-string face)) + (process-send-eof process)))) (require 'product) (provide 'lsdb) (product-provide 'lsdb - (product-define "LSDB" nil '(0 10))) + (product-define "LSDB" nil '(0 11))) ;;;_* Local emacs vars. ;;; The following `allout-layout' local variable setting: