mirror of https://codeberg.org/cage/tinmop/
- [kami] optimized deletion of file system trees.
This commit is contained in:
cage
parent
35d784a4c6
commit
321eede79c
|
|
@ -18,9 +18,9 @@
|
|||
(in-package :chats-list-window)
|
||||
|
||||
(defclass chats-list-window (focus-marked-window
|
||||
simple-line-navigation-window
|
||||
title-window
|
||||
border-window)
|
||||
simple-line-navigation-window
|
||||
title-window
|
||||
border-window)
|
||||
())
|
||||
|
||||
(defmethod refresh-config :after ((object chats-list-window))
|
||||
|
|
|
|||
|
|
@ -93,6 +93,17 @@
|
|||
:documentation "function with two parameter the path and a feature
|
||||
to query Valid feature values are :size. Returns nil if Returns
|
||||
nil if the path does not point to an actual file.")
|
||||
(filesystem-list-all-file-paths-function
|
||||
:initform #'fs:collect-tree
|
||||
:accessor filesystem-list-all-file-paths-function
|
||||
:type function
|
||||
:documentation "function with a single parameter, the
|
||||
path. Returns a list of path to all the reachable files from the
|
||||
argument as root directory e.g
|
||||
(funcall filesystem-list-all-file-paths-function \"foo/\")
|
||||
; => (foo/bar/baz
|
||||
foo/a/b
|
||||
...)")
|
||||
(filesystem-close-connection-function
|
||||
:initform (constantly t)
|
||||
:accessor filesystem-close-connection-function
|
||||
|
|
@ -105,22 +116,24 @@
|
|||
&key (handlers-plist nil) &allow-other-keys)
|
||||
(when handlers-plist
|
||||
(setf (filesystem-expand-function object)
|
||||
(getf handlers-plist :filesystem-expand-function)
|
||||
(filesystem-expand-function object)
|
||||
(getf handlers-plist :filesystem-expand-function)
|
||||
(filesystem-rename-function object)
|
||||
(getf handlers-plist :filesystem-rename-function)
|
||||
(filesystem-delete-function object)
|
||||
(getf handlers-plist :filesystem-delete-function)
|
||||
(filesystem-create-function object)
|
||||
(getf handlers-plist :filesystem-create-function)
|
||||
(filesystem-download-function object)
|
||||
(getf handlers-plist :filesystem-download-function)
|
||||
(filesystem-upload-function object)
|
||||
(getf handlers-plist :filesystem-upload-function)
|
||||
(filesystem-query-path-function object)
|
||||
(getf handlers-plist :filesystem-query-path-function)
|
||||
(filesystem-close-connection-function object)
|
||||
(getf handlers-plist :filesystem-expand-function))
|
||||
(setf (filesystem-expand-function object)
|
||||
(getf handlers-plist :filesystem-expand-function))
|
||||
(setf (filesystem-rename-function object)
|
||||
(getf handlers-plist :filesystem-rename-function))
|
||||
(setf (filesystem-delete-function object)
|
||||
(getf handlers-plist :filesystem-delete-function))
|
||||
(setf (filesystem-create-function object)
|
||||
(getf handlers-plist :filesystem-create-function))
|
||||
(setf (filesystem-download-function object)
|
||||
(getf handlers-plist :filesystem-download-function))
|
||||
(setf (filesystem-upload-function object)
|
||||
(getf handlers-plist :filesystem-upload-function))
|
||||
(setf (filesystem-query-path-function object)
|
||||
(getf handlers-plist :filesystem-query-path-function))
|
||||
(setf (filesystem-list-all-file-paths-function object)
|
||||
(getf handlers-plist :filesystem-list-all-file-paths-function))
|
||||
(setf (filesystem-close-connection-function object)
|
||||
(getf handlers-plist :filesystem-close-connection-function)))
|
||||
object)
|
||||
|
||||
|
|
@ -435,23 +448,49 @@
|
|||
(win-clear window :redraw nil)
|
||||
(resync-rows-db window :redraw t :selected-path remote-path)))))
|
||||
|
||||
(defun recursive-delete-node (window path)
|
||||
(defun recursive-delete-node (window path
|
||||
&key
|
||||
(progress-function (lambda (filename file-count all-files-number)
|
||||
(declare (ignore filename file-count all-files-number)))))
|
||||
(with-accessors ((root-node filesystem-root)
|
||||
(filesystem-expand-function filesystem-expand-function)) window
|
||||
(filesystem-expand-function filesystem-expand-function)
|
||||
(list-all-file-function filesystem-list-all-file-paths-function))
|
||||
window
|
||||
(let* ((matching-node (find-node root-node path))
|
||||
(filep (not (tree-dir-p (data matching-node)))))
|
||||
(if filep
|
||||
(delete-treenode window path)
|
||||
(when (not (or (fs:loopback-reference-dir-p path)
|
||||
(fs:backreference-dir-p path)))
|
||||
(%expand-treenode root-node
|
||||
(tree-path (data matching-node))
|
||||
filesystem-expand-function)
|
||||
(setf matching-node (find-node root-node path))
|
||||
(do-children (child matching-node)
|
||||
(let ((path-to-recurse (tree-path (data child))))
|
||||
(recursive-delete-node window path-to-recurse)))
|
||||
(delete-treenode window path))))))
|
||||
(multiple-value-bind (all-files-to-delete all-dirs-to-delete)
|
||||
(funcall list-all-file-function path)
|
||||
(let ((items-count 0)
|
||||
(items-total-number (+ (length all-files-to-delete)
|
||||
(length all-dirs-to-delete))))
|
||||
(flet ((delete-items (items)
|
||||
(loop for item in items
|
||||
for count from 0
|
||||
when (not (or (fs:backreference-dir-p item)
|
||||
(fs:loopback-reference-dir-p item)))
|
||||
do
|
||||
(let ((node (mtree:make-node (make-node-data item nil))))
|
||||
(incf items-count)
|
||||
(funcall (filesystem-delete-function window)
|
||||
node)
|
||||
(funcall progress-function
|
||||
item
|
||||
items-count
|
||||
items-total-number)))))
|
||||
(delete-items all-files-to-delete)
|
||||
(delete-items all-dirs-to-delete)
|
||||
(delete-items (list path))
|
||||
(when-let* ((parent-node (find-node root-node
|
||||
(fs:parent-dir-path path)))
|
||||
(parent-path (tree-path (data parent-node))))
|
||||
(remove-all-children parent-node)
|
||||
(expand-treenode window parent-path)
|
||||
(win-clear window :redraw nil)
|
||||
(resync-rows-db window :redraw t :selected-path parent-path))))))))))
|
||||
|
||||
(defun filesystem-query-treenode (window path what)
|
||||
(assert (member what '(:size :size-string :permissions :permissions-string :type)))
|
||||
|
|
|
|||
|
|
@ -120,10 +120,14 @@
|
|||
(text-utils:strcat file "." extension))
|
||||
|
||||
(defun cat-parent-dir (parent direntry)
|
||||
(if (or (backreference-dir-p direntry)
|
||||
(loopback-reference-dir-p direntry))
|
||||
(format nil "~a~a" parent direntry)
|
||||
(format nil "~a~a~a" parent *directory-sep* direntry)))
|
||||
(cond
|
||||
((or (backreference-dir-p direntry)
|
||||
(loopback-reference-dir-p direntry))
|
||||
(format nil "~a~a" parent direntry))
|
||||
((string= (string (alexandria:last-elt parent)) *directory-sep*)
|
||||
(format nil "~a~a" parent direntry))
|
||||
(t
|
||||
(format nil "~a~a~a" parent *directory-sep* direntry))))
|
||||
|
||||
(defmacro do-directory ((var) root &body body)
|
||||
(with-gensyms (dir)
|
||||
|
|
@ -149,23 +153,29 @@
|
|||
(setf all-paths (sort all-paths #'string<))
|
||||
all-paths))
|
||||
|
||||
(defun collect-tree (unvisited-dirs &optional (accum '()))
|
||||
(declare (optimize (debug 0) (speed 3)))
|
||||
(cond
|
||||
((null unvisited-dirs)
|
||||
accum)
|
||||
(t
|
||||
(let* ((children (collect-children (first unvisited-dirs)))
|
||||
(files (mapcar #'normalize-path
|
||||
(remove-if #'directory-exists-p children)))
|
||||
(directories (mapcar (lambda (a) (text-utils:strcat a "/"))
|
||||
(remove-if (lambda (a)
|
||||
(or (file-exists-p a)
|
||||
(backreference-dir-p a)
|
||||
(loopback-reference-dir-p a)))
|
||||
children))))
|
||||
(collect-tree (append (rest unvisited-dirs) directories)
|
||||
(append files accum))))))
|
||||
(defun collect-tree (root)
|
||||
(labels ((%collect-tree (unvisited-dirs
|
||||
&optional
|
||||
(accum-files '())
|
||||
(accum-dirs '()))
|
||||
(declare (optimize (debug 0) (speed 3)))
|
||||
(cond
|
||||
((null unvisited-dirs)
|
||||
(values accum-files accum-dirs))
|
||||
(t
|
||||
(let* ((children (collect-children (first unvisited-dirs)))
|
||||
(files (mapcar #'normalize-path
|
||||
(remove-if #'directory-exists-p children)))
|
||||
(directories (mapcar (lambda (a) (text-utils:strcat a "/"))
|
||||
(remove-if (lambda (a)
|
||||
(or (file-exists-p a)
|
||||
(backreference-dir-p a)
|
||||
(loopback-reference-dir-p a)))
|
||||
children))))
|
||||
(%collect-tree (append (rest unvisited-dirs) directories)
|
||||
(append files accum-files)
|
||||
(append directories accum-dirs)))))))
|
||||
(%collect-tree (list root))))
|
||||
|
||||
(defun backreference-dir-p (path)
|
||||
(string= (path-last-element path) ".."))
|
||||
|
|
|
|||
|
|
@ -158,25 +158,33 @@
|
|||
(9p:permissions-group-string mode)
|
||||
(9p:permissions-others-string mode))))))))))
|
||||
|
||||
(defun collect-tree (stream root-fid)
|
||||
(lambda (path)
|
||||
(let* ((*stream* stream)
|
||||
(*root-fid* root-fid))
|
||||
(with-cloned-root-fid (*stream* root-fid)
|
||||
(9p:collect-tree *stream* root-fid path)))))
|
||||
|
||||
(defun generate-filesystem-window-handlers (path host port
|
||||
query fragment
|
||||
client-certificate client-key)
|
||||
(with-open-ssl-stream (stream socket host port client-certificate client-key)
|
||||
(let* ((*stream* stream)
|
||||
(*root-fid* (9p:mount *stream* "/")))
|
||||
(list :query query
|
||||
:fragment fragment
|
||||
:socket socket
|
||||
:path path
|
||||
:filesystem-expand-function (expand-node *stream* *root-fid*)
|
||||
:filesystem-rename-function (rename-node *stream* *root-fid*)
|
||||
:filesystem-delete-function (delete-node *stream* *root-fid*)
|
||||
:filesystem-create-function (create-node *stream* *root-fid*)
|
||||
:filesystem-download-function (download-node *stream* *root-fid*)
|
||||
:filesystem-upload-function (upload-node *stream* *root-fid*)
|
||||
:filesystem-query-path-function (query-path *stream* *root-fid*)
|
||||
:filesystem-close-connection-function (lambda ()
|
||||
(9p:close-client socket))))))
|
||||
(list :query query
|
||||
:fragment fragment
|
||||
:socket socket
|
||||
:path path
|
||||
:filesystem-expand-function (expand-node *stream* *root-fid*)
|
||||
:filesystem-rename-function (rename-node *stream* *root-fid*)
|
||||
:filesystem-delete-function (delete-node *stream* *root-fid*)
|
||||
:filesystem-create-function (create-node *stream* *root-fid*)
|
||||
:filesystem-download-function (download-node *stream* *root-fid*)
|
||||
:filesystem-upload-function (upload-node *stream* *root-fid*)
|
||||
:filesystem-query-path-function (query-path *stream* *root-fid*)
|
||||
:filesystem-list-all-file-paths-function (collect-tree *stream* *root-fid*)
|
||||
:filesystem-close-connection-function (lambda ()
|
||||
(9p:close-client socket))))))
|
||||
|
||||
(defun iri->filesystem-window-handlers (kami-iri)
|
||||
(a:when-let ((parsed-iri (iri:iri-parse kami-iri :null-on-error t)))
|
||||
|
|
|
|||
|
|
@ -287,6 +287,7 @@
|
|||
:add-extension
|
||||
:do-directory
|
||||
:collect-children
|
||||
:collect-tree
|
||||
:backreference-dir-p
|
||||
:loopback-reference-dir-p
|
||||
:path-referencing-dir-p
|
||||
|
|
|
|||
|
|
@ -2670,18 +2670,26 @@ printed, on the main window."
|
|||
(when-let* ((win *filesystem-explorer-window*)
|
||||
(fields (line-oriented-window:selected-row-fields win))
|
||||
(path (fstree:tree-path fields)))
|
||||
(flet ((on-input-complete (maybe-accepted)
|
||||
(with-valid-yes-at-prompt (maybe-accepted y-pressed-p)
|
||||
(when y-pressed-p
|
||||
(info-message (format nil (_"deleting ~a") path))
|
||||
(with-enqueued-process ()
|
||||
(fstree:recursive-delete-node win path)
|
||||
(fstree:resync-rows-db win
|
||||
:selected-path (fs:parent-dir-path path)
|
||||
:redraw nil)
|
||||
(windows:win-clear win)
|
||||
(windows:draw win)
|
||||
(info-message (format nil (_"Completed") path)))))))
|
||||
(labels ((progress-print (file count item-number)
|
||||
(info-message (format nil
|
||||
(_ "deleting ~a (~a of ~a)")
|
||||
file
|
||||
count
|
||||
item-number)))
|
||||
(on-input-complete (maybe-accepted)
|
||||
(with-valid-yes-at-prompt (maybe-accepted y-pressed-p)
|
||||
(when y-pressed-p
|
||||
(info-message (format nil (_"Preparing to delete ~a") path))
|
||||
(with-enqueued-process ()
|
||||
(fstree:recursive-delete-node win
|
||||
path
|
||||
:progress-function #'progress-print)
|
||||
(fstree:resync-rows-db win
|
||||
:selected-path (fs:parent-dir-path path)
|
||||
:redraw nil)
|
||||
(windows:win-clear win)
|
||||
(windows:draw win)
|
||||
(info-message (format nil (_"Completed") path)))))))
|
||||
(ask-string-input #'on-input-complete
|
||||
:prompt
|
||||
(format nil (_ "Delete ~a? ") path)))))
|
||||
|
|
|
|||
Loading…
Reference in New Issue