mirror of https://codeberg.org/cage/tinmop/
- implemented querying file's metadata in filesystem window.
This commit is contained in:
parent
429acc7efe
commit
c6f741d3a8
|
@ -66,7 +66,14 @@
|
||||||
(filesystem-upload-function
|
(filesystem-upload-function
|
||||||
:initform #'upload-local-filesystem-node
|
:initform #'upload-local-filesystem-node
|
||||||
:accessor filesystem-upload-function
|
:accessor filesystem-upload-function
|
||||||
:type function))
|
:type function)
|
||||||
|
(filesystem-query-path-function
|
||||||
|
:initform #'query-local-filesystem-path
|
||||||
|
:accessor filesystem-query-path-function
|
||||||
|
:type function
|
||||||
|
:documentation "function with two parameter the path and a feature to query
|
||||||
|
Valid feature vaule are :size.
|
||||||
|
Returns nil if Returns nil if the path does not point to an actual file."))
|
||||||
(:documentation "A window that shows and allow interacting with a hierarchical filesystem"))
|
(:documentation "A window that shows and allow interacting with a hierarchical filesystem"))
|
||||||
|
|
||||||
(defmethod refresh-config :after ((object filesystem-tree-window))
|
(defmethod refresh-config :after ((object filesystem-tree-window))
|
||||||
|
@ -105,6 +112,14 @@
|
||||||
(bgcolor window)
|
(bgcolor window)
|
||||||
(fgcolor window)))
|
(fgcolor window)))
|
||||||
|
|
||||||
|
(defun query-local-filesystem-path (path what)
|
||||||
|
(case what
|
||||||
|
(:size
|
||||||
|
(and (fs:file-exists-p path)
|
||||||
|
(fs:file-size path)))
|
||||||
|
(otherwise
|
||||||
|
nil)))
|
||||||
|
|
||||||
(defun expand-local-filesystem-node (matching-node)
|
(defun expand-local-filesystem-node (matching-node)
|
||||||
(let ((path (tree-path (data matching-node))))
|
(let ((path (tree-path (data matching-node))))
|
||||||
(assert path)
|
(assert path)
|
||||||
|
@ -356,6 +371,23 @@
|
||||||
(win-clear window :redraw nil)
|
(win-clear window :redraw nil)
|
||||||
(resync-rows-db window :redraw t :selected-path parent-path)))
|
(resync-rows-db window :redraw t :selected-path parent-path)))
|
||||||
|
|
||||||
|
(defun filesystem-query-treenode (window path what)
|
||||||
|
(assert (member what '(:size)))
|
||||||
|
(when-let* ((root-node (filesystem-root window))
|
||||||
|
(matching-node (find-node root-node path))
|
||||||
|
(filep (not (tree-dir-p (data matching-node))))
|
||||||
|
(octects (funcall (filesystem-query-path-function window)
|
||||||
|
(tree-path (data matching-node))
|
||||||
|
what)))
|
||||||
|
(flet ((to-string (octects-data units)
|
||||||
|
(multiple-value-bind (size unit-measurement)
|
||||||
|
(fs:octects->units octects-data units)
|
||||||
|
(format nil "~,2f~a" size unit-measurement))))
|
||||||
|
(values octects
|
||||||
|
(to-string octects :kib)
|
||||||
|
(to-string octects :mib)
|
||||||
|
(to-string octects :gib)))))
|
||||||
|
|
||||||
(defmethod search-row ((object filesystem-tree-window) regex &key (redraw t))
|
(defmethod search-row ((object filesystem-tree-window) regex &key (redraw t))
|
||||||
(handler-case
|
(handler-case
|
||||||
(with-accessors ((row-selected-index row-selected-index)) object
|
(with-accessors ((row-selected-index row-selected-index)) object
|
||||||
|
|
|
@ -477,3 +477,15 @@
|
||||||
(flet ((strip (a) (strip-dirs-from-path (pathname->namestring a))))
|
(flet ((strip (a) (strip-dirs-from-path (pathname->namestring a))))
|
||||||
(string= (strip a)
|
(string= (strip a)
|
||||||
(strip b))))
|
(strip b))))
|
||||||
|
|
||||||
|
(define-constant +file-size-units+ '("KiB" "MiB" "GiB") :test #'equalp)
|
||||||
|
|
||||||
|
(defun octects->units (octects units)
|
||||||
|
(let* ((exponent (case units
|
||||||
|
(:kib 1)
|
||||||
|
(:mib 2)
|
||||||
|
(:gib 3)
|
||||||
|
(otherwise 1)))
|
||||||
|
(scaled (/ octects (expt 1024 exponent))))
|
||||||
|
(values scaled
|
||||||
|
(elt +file-size-units+ (1- exponent)))))
|
||||||
|
|
|
@ -331,7 +331,8 @@
|
||||||
:pathname->namestring
|
:pathname->namestring
|
||||||
:namestring->pathname
|
:namestring->pathname
|
||||||
:read-single-form
|
:read-single-form
|
||||||
:eq-filename))
|
:eq-filename
|
||||||
|
:octects->units))
|
||||||
|
|
||||||
(defpackage :os-utils
|
(defpackage :os-utils
|
||||||
(:use
|
(:use
|
||||||
|
@ -2035,6 +2036,7 @@
|
||||||
:create-treenode
|
:create-treenode
|
||||||
:download-treenode
|
:download-treenode
|
||||||
:upload-treenode
|
:upload-treenode
|
||||||
|
:filesystem-query-treenode
|
||||||
:resync-rows-db
|
:resync-rows-db
|
||||||
:init))
|
:init))
|
||||||
|
|
||||||
|
|
Loading…
Reference in New Issue