: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."
: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 0.5 | pnmtopng")
- (xpm "pngtopnm | pnmscale 0.5 | ppmtoxpm"))
+ '((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."
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)))
;; 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 "))"))
(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)
(process-connection-type nil)
(cached (cdr (assq type (lsdb-gethash x-face lsdb-x-face-cache))))
(marker (point-marker))
+ buffer
process)
(if cached
(lsdb-insert-x-face-image cached type marker)
+ (with-current-buffer (setq buffer (generate-new-buffer " *lsdb work*"))
+ (buffer-disable-undo)
+ (set-buffer-multibyte nil))
(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")))
- (process-send-string process (concat x-face "\n"))
- (process-send-eof process)
+ (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
+ (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))))
;;;_. Face Rendering
(defvar lsdb-face-cache
(process-connection-type nil)
(cached (cdr (assq type (lsdb-gethash face lsdb-face-cache))))
(marker (point-marker))
+ buffer
process)
(if cached
(lsdb-insert-face-image cached type marker)
+ (with-current-buffer (setq buffer (generate-new-buffer " *lsdb work*"))
+ (buffer-disable-undo)
+ (set-buffer-multibyte nil))
(setq process
(start-process-shell-command
- "lsdb-face-command" (generate-new-buffer " *lsdb work*")
+ "lsdb-face-command" buffer
(concat "{ "
- (nth 1 (assq type lsdb-face-command-alist))
+ (apply #'concat
+ (lsdb-substitute-variables
+ (cdr (assq type lsdb-face-command-alist))
+ 'scale-factor
+ (number-to-string lsdb-face-scale-factor)))
"; } 2> /dev/null")))
- (process-send-string process (base64-decode-string face))
- (process-send-eof process)
+ (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-face-image data ',type ,marker)
- (lsdb-puthash ,face (list (cons ',type data))
- lsdb-face-cache)))
- (kill-buffer (process-buffer process))))))))
+ (if (equal string "finished\n")
+ (let ((data
+ (with-current-buffer ,buffer
+ (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)
projects / elisp / lsdb.git / blobdiff