cage
/
tinmop
mirror of https://codeberg.org/cage/tinmop/
1
0
Fork 0
Code Issues

- added 'file-explorer-upload-mirror'.

This commit is contained in:
cage 2022-01-29 17:44:47 +01:00
parent b9e82736b1
commit dd3288b56d
5 changed files with 66 additions and 17 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
etc/init.lisp
View File

@ -632,6 +632,8 @@
(define-key "i" #'file-explorer-node-details *filesystem-explorer-keymap*)
(define-key "M" #'file-explorer-upload-mirror *filesystem-explorer-keymap*)
;;;; hooks
;; this module will install an hook to rewrite urls; By default it

26
src/filesystem-tree-window.lisp
View File

@ -419,17 +419,21 @@
(fs:create-file destination-file)
(funcall (filesystem-download-function window) matching-node destination-file)))
(defun upload-treenode (window source-file remote-path)
(when-let* ((root-node (filesystem-root window))
(parent-node (find-node root-node (fs:parent-dir-path remote-path)))
(parent-path (tree-path (data parent-node))))
(funcall (filesystem-upload-function window)
source-file
(fs:normalize-path remote-path))
(remove-all-children parent-node)
(expand-treenode window parent-path)
(win-clear window :redraw nil)
(resync-rows-db window :redraw t :selected-path remote-path)))
(defun upload-treenode (window source-file remote-path &key (force-upload nil))
(let ((root-node (filesystem-root window)))
(if force-upload
(funcall (filesystem-upload-function window)
source-file
(fs:normalize-path remote-path))
(when-let* ((parent-node (find-node root-node (fs:parent-dir-path remote-path)))
(parent-path (tree-path (data parent-node))))
(funcall (filesystem-upload-function window)
source-file
(fs:normalize-path remote-path))
(remove-all-children parent-node)
(expand-treenode window parent-path)
(win-clear window :redraw nil)
(resync-rows-db window :redraw t :selected-path remote-path)))))
(defun recursive-delete-node (window path)
(with-accessors ((root-node filesystem-root)

14
src/filesystem-utils.lisp
View File

@ -140,9 +140,12 @@
(nix:closedir ,dir)))))
(defun collect-children (parent-dir)
(let ((all-paths ()))
(let ((all-paths '()))
(fs:do-directory (path) parent-dir
(push path all-paths))
(if (or (backreference-dir-p path)
(loopback-reference-dir-p path))
(push path all-paths)
(push (normalize-path path) all-paths)))
(setf all-paths (sort all-paths #'string<))
all-paths))
@ -153,7 +156,8 @@
accum)
(t
(let* ((children (collect-children (first unvisited-dirs)))
(files (remove-if #'directory-exists-p children))
(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)
@ -187,8 +191,8 @@
(setf all-files (append all-files files))
(setf all-dirs (append all-dirs directories))
(loop for new-dir in directories do
(collect new-dir))))))
(collect root)
(collect new-dir))))))
(collect root)
(values all-files
all-dirs))))

3
src/package.lisp
View File

@ -2830,7 +2830,8 @@
:file-explorer-close-window
:file-explorer-open-node
:file-explorer-node-details
:file-explorer-edit-file))
:file-explorer-edit-file
:file-explorer-upload-mirror))
(defpackage :scheduled-events
(:use

38
src/ui-goodies.lisp
View File

@ -2733,3 +2733,41 @@ if the selected item represents a directory."
(path (fstree:tree-path fields)))
(fstree:edit-node win path)
(info-message (format nil (_ "File ~s was modified on server") path))))
(defun file-explorer-upload-mirror ()
"Upload a filesystem tree."
(when-let* ((win *filesystem-explorer-window*)
(fields (line-oriented-window:selected-row-fields win))
(destination-dir (if (fs:path-referencing-dir-p (fstree:tree-path fields))
(fstree:tree-path fields)
(fs:parent-dir-path (fstree:tree-path fields)))))
(labels ((build-actual-destination-path-clsr (destination-dir root-directory)
(lambda (a)
(fs:append-file-to-path destination-dir
(cl-ppcre:regex-replace root-directory
a
""))))
(on-input-complete (root-directory)
(with-enqueued-process ()
(when (string-not-empty-p root-directory)
(if (not (fs:dirp root-directory))
(error-message (format nil "~a is not directory" root-directory))
(let* ((children (fs::collect-tree (list root-directory)))
(remote-paths
(mapcar (build-actual-destination-path-clsr destination-dir
root-directory)
children)))
(mapcar (lambda (destination source)
(info-message (format nil (_"Uploading ~a") destination))
(with-enqueued-process ()
(fstree:upload-treenode win
source
destination
:force-upload t)))
remote-paths
children)
(info-message (_"Uploading completed."))))))))
(ask-string-input #'on-input-complete
:prompt (_ "Upload: ")
:complete-fn #'complete:directory-complete))))