diff --git a/dired-inline-preview.el b/dired-inline-preview.el new file mode 100644 index 0000000..93dad35 --- /dev/null +++ b/dired-inline-preview.el @@ -0,0 +1,140 @@ +;;; dired-inline-preview.el --- Inline previews in dired buffer +;; Copyright (C) 2019 Mikael Svahnberg +;; Copyright (C) 2014-- Matúš Goljer + +;; This program is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see . + +;;; Commentary: +;; This is heavily based on dired-subtree by Matúš Goljer, +;; but generalises it to more different types of previews. + +;;; Code: +(require 'dired-subtree) +(require 'pdf-info) + +(defgroup dired-inline-preview () + "Inline previews in dired buffer" + :group 'dired-hacks + :prefix "dired-inline-preview-") + +(defcustom dired-inline-preview-pdf-width 200 + "width of inlined PDF preview" + :type 'integer + :group 'dired-inline-preview) + +(defcustom dired-inline-preview-image-height 200 + "height of inlined image preview" + :type 'integer + :group 'dired-inline-preview) + +;; TODO: use image-type-file-name-regexps instead +(defcustom dired-inline-preview-image-extensions '("PBM" "XBM" "XPM" "GIF" "JPEG" "JPG" "TIFF" "TIF" "PNG" "SVG" "PS") + "list of filename extensions that should be inlined as images" + :type 'sexp + :group 'dired-inline-preview) + +(defcustom dired-inline-preview-text-lines 10 + "Number of lines to preview for text files" + :type 'integer + :group 'dired-inline-preview) +(defcustom dired-inline-preview-text-extensions '("TXT" "ORG" "TEX" "CSV") + "list of filename extensions that should be inlined as text" + :type 'sexp + :group 'dired-inline-preview) + +(defcustom dired-inline-preview-previewers '(dired-inline-preview--pdf dired-inline-preview--image dired-inline-preview--text) + "list of previewers to test" + :type 'sexp + :group 'dired-inline-preview) + +(defconst dired-inline-preview--dummy-file-details " ---------- 1 X X 0 Jan 01 00:01 " + "Dummy file attributes to fool dired-hide-details into not swallowing the preview") + +;;; Helpers +(defun dired-inline-preview--match-filename-extension (filename allowed-extensions) + "return t if the FILENAME extension is in the list of ALLOWED-EXTENSIONS, otherwise return nil." + (let* ((ext (upcase (or (file-name-extension filename) ""))) + (search-fun (apply-partially (lambda (file-extension allowed-extension) (string= file-extension (upcase (or allowed-extension "")))) ext))) + (seq-find search-fun allowed-extensions nil))) + +(defun dired-inline-preview--maybe-insert-text (text) + (unless (string-match "^[[:blank:]]*$" + (buffer-substring (line-beginning-position) + (line-end-position))) + (insert text))) + +(defun dired-inline-preview--fool-dired-hide-details (listing) + "Fool dired-hide-details by inserting a dummy file attributes list" + (with-temp-buffer + (insert listing) + (goto-char (point-min)) + (dired-inline-preview--maybe-insert-text dired-inline-preview--dummy-file-details) + (while (= (forward-line) 0) + (dired-inline-preview--maybe-insert-text dired-inline-preview--dummy-file-details)) + (buffer-string))) + + +;;; Previewers: +(defun dired-inline-preview--pdf (filename) + "return first page of FILENAME or nil" + (when (dired-inline-preview--match-filename-extension filename '("PDF")) + (with-temp-buffer + (insert ".") + (insert-image (create-image (pdf-info-renderpage 1 dired-inline-preview-pdf-width filename) 'imagemagick t)) + (insert "\n") + (buffer-string)))) + +(defun dired-inline-preview--image (filename) + "return inlined image or nil" + (when (dired-inline-preview--match-filename-extension filename dired-inline-preview-image-extensions) + (with-temp-buffer + (insert ".") + (insert-image (create-image filename 'imagemagick nil :height dired-inline-preview-image-height)) + (insert "\n") + (buffer-string)))) + +(defun dired-inline-preview--text (filename) + "return inlined text or nil" + (when (dired-inline-preview--match-filename-extension filename dired-inline-preview-text-extensions) + (with-temp-buffer + (insert-file-contents filename) + (goto-char (point-min)) + (let (out) + (dotimes (iter dired-inline-preview-text-lines out) + (forward-line))) + (delete-region (point) (point-max)) + (buffer-string)))) + + +;;; Entry points: +(defun dired-inline-preview (filename) + (interactive "P") + (seq-some (lambda (fun) (funcall fun filename)) dired-inline-preview-previewers)) + +(defun dired-inline-preview-insert-preview-or-subtree (orig-fun) + "Call the right insert function for a preview or a subtree" + (interactive) + (if (dired-subtree--dired-line-is-directory-or-link-p) + (apply orig-fun nil) + (unless (dired-subtree--is-expanded-p) + (let* ((filename (dired-get-filename nil)) + (listing (dired-inline-preview filename))) + (if listing (dired-subtree-insert--insert filename (dired-inline-preview--fool-dired-hide-details listing))))))) + +(advice-add 'dired-subtree-insert :around #'dired-inline-preview-insert-preview-or-subtree) + + + +(provide 'dired-inline-preview) +;;; dired-inline-preview.el ends here diff --git a/dired-subtree.el b/dired-subtree.el index 75a1709..64e7fed 100644 --- a/dired-subtree.el +++ b/dired-subtree.el @@ -487,60 +487,64 @@ Return a string suitable for insertion in `dired' buffer." (when (and (dired-subtree--dired-line-is-directory-or-link-p) (not (dired-subtree--is-expanded-p))) (let* ((dir-name (dired-get-filename nil)) - (listing (dired-subtree--readin (file-name-as-directory dir-name))) - beg end) - (read-only-mode -1) - (move-end-of-line 1) - ;; this is pretty ugly, I'm sure it can be done better - (save-excursion - (insert listing) - (setq end (+ (point) 2))) - (newline) - (setq beg (point)) - (let ((inhibit-read-only t)) - (remove-text-properties (1- beg) beg '(dired-filename))) - (let* ((ov (make-overlay beg end)) - (parent (dired-subtree--get-ov (1- beg))) - (depth (or (and parent (1+ (overlay-get parent 'dired-subtree-depth))) - 1)) - (face (intern (format "dired-subtree-depth-%d-face" depth)))) - (when dired-subtree-use-backgrounds - (overlay-put ov 'face face)) - ;; refactor this to some function - (overlay-put ov 'line-prefix - (if (stringp dired-subtree-line-prefix) - (if (not dired-subtree-use-backgrounds) - (apply 'concat (-repeat depth dired-subtree-line-prefix)) - (cond - ((eq nil dired-subtree-line-prefix-face) + (listing (dired-subtree--readin (file-name-as-directory dir-name)))) + (dired-subtree-insert--insert dir-name listing)))) + +(defun dired-subtree-insert--insert (filename listing) + "Insert LISTING under current FILENAME" + (let (beg end) + (read-only-mode -1) + (move-end-of-line 1) + ;; this is pretty ugly, I'm sure it can be done better + (save-excursion + (insert listing) + (setq end (+ (point) 2))) + (newline) + (setq beg (point)) + (let ((inhibit-read-only t)) + (remove-text-properties (1- beg) beg '(dired-filename))) + (let* ((ov (make-overlay beg end)) + (parent (dired-subtree--get-ov (1- beg))) + (depth (or (and parent (1+ (overlay-get parent 'dired-subtree-depth))) + 1)) + (face (intern (format "dired-subtree-depth-%d-face" depth)))) + (when dired-subtree-use-backgrounds + (overlay-put ov 'face face)) + ;; refactor this to some function + (overlay-put ov 'line-prefix + (if (stringp dired-subtree-line-prefix) + (if (not dired-subtree-use-backgrounds) + (apply 'concat (-repeat depth dired-subtree-line-prefix)) + (cond + ((eq nil dired-subtree-line-prefix-face) + (apply 'concat + (-repeat depth dired-subtree-line-prefix))) + ((eq 'subtree dired-subtree-line-prefix-face) + (concat + dired-subtree-line-prefix + (propertize (apply 'concat - (-repeat depth dired-subtree-line-prefix))) - ((eq 'subtree dired-subtree-line-prefix-face) - (concat - dired-subtree-line-prefix - (propertize - (apply 'concat - (-repeat (1- depth) dired-subtree-line-prefix)) - 'face face))) - ((eq 'parents dired-subtree-line-prefix-face) - (concat - dired-subtree-line-prefix - (apply 'concat - (--map - (propertize dired-subtree-line-prefix - 'face - (intern (format "dired-subtree-depth-%d-face" it))) - (number-sequence 1 (1- depth)))))))) - (funcall dired-subtree-line-prefix depth))) - (overlay-put ov 'dired-subtree-name dir-name) - (overlay-put ov 'dired-subtree-parent parent) - (overlay-put ov 'dired-subtree-depth depth) - (overlay-put ov 'evaporate t) - (push ov dired-subtree-overlays)) - (goto-char beg) - (dired-move-to-filename) - (read-only-mode 1) - (run-hooks 'dired-subtree-after-insert-hook)))) + (-repeat (1- depth) dired-subtree-line-prefix)) + 'face face))) + ((eq 'parents dired-subtree-line-prefix-face) + (concat + dired-subtree-line-prefix + (apply 'concat + (--map + (propertize dired-subtree-line-prefix + 'face + (intern (format "dired-subtree-depth-%d-face" it))) + (number-sequence 1 (1- depth)))))))) + (funcall dired-subtree-line-prefix depth))) + (overlay-put ov 'dired-subtree-name filename) + (overlay-put ov 'dired-subtree-parent parent) + (overlay-put ov 'dired-subtree-depth depth) + (overlay-put ov 'evaporate t) + (push ov dired-subtree-overlays)) + (goto-char beg) + (dired-move-to-filename) + (read-only-mode 1) + (run-hooks 'dired-subtree-after-insert-hook))) ;;;###autoload (defun dired-subtree-remove ()