mirror of
https://codeberg.org/cage/tinmop/
synced 2025-02-17 08:10:36 +01:00
- added a wrapper for 'fnmatch(3)';
- [kamid] upload works with wildcard (e.g. "/*.lisp"); - moved 'normalize-path' to filesystem-utils.
This commit is contained in:
parent
e7492af2bd
commit
31b9685737
@ -178,7 +178,7 @@
|
||||
(let* ((children (mapcar (lambda (a)
|
||||
(if (not (or (fs:backreference-dir-p a)
|
||||
(fs:loopback-reference-dir-p a)))
|
||||
(uri:normalize-path a)
|
||||
(fs:normalize-path a)
|
||||
a))
|
||||
(fs:collect-children path)))
|
||||
(files (remove-if #'fs:dirp children))
|
||||
@ -336,7 +336,7 @@
|
||||
|
||||
(defun jump-to-parent-node (window path)
|
||||
(when (fs:backreference-dir-p path)
|
||||
(let ((parent-path (uri:normalize-path path)))
|
||||
(let ((parent-path (fs:normalize-path path)))
|
||||
(win-clear window :redraw nil)
|
||||
(resync-rows-db window :selected-path parent-path :redraw t))))
|
||||
|
||||
@ -418,7 +418,9 @@
|
||||
(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 remote-path)
|
||||
(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)
|
||||
|
@ -391,6 +391,23 @@
|
||||
(push directory-path *temporary-directories-created*)
|
||||
directory-path)))
|
||||
|
||||
(cffi:defcfun (ffi-fnmatch "fnmatch")
|
||||
:int
|
||||
(pattern :pointer)
|
||||
(string :pointer)
|
||||
(flags :int))
|
||||
|
||||
(defun filename-pattern-match (pattern string)
|
||||
(cffi:with-foreign-string (ptr-pattern pattern)
|
||||
(cffi:with-foreign-string (ptr-string string)
|
||||
(zerop (ffi-fnmatch ptr-pattern ptr-string 0)))))
|
||||
|
||||
(defun children-matching-path (pattern)
|
||||
(let* ((parent (parent-dir-path pattern))
|
||||
(children (collect-children parent)))
|
||||
(remove-if-not (lambda (a) (filename-pattern-match pattern a))
|
||||
children)))
|
||||
|
||||
(defun recursive-delete (path)
|
||||
(if (regular-file-p path)
|
||||
(delete-file-if-exists path)
|
||||
@ -537,3 +554,59 @@
|
||||
(format nil (config:_ "~a Mib") (truncate (octects->units object :mib))))
|
||||
(t
|
||||
(format nil (config:_ "~a Gib") (truncate (octects->units object :gib)))))))
|
||||
|
||||
(defgeneric normalize-path (object))
|
||||
|
||||
(defmethod normalize-path ((object null))
|
||||
nil)
|
||||
|
||||
(defmethod normalize-path ((object string))
|
||||
(flet ((make-stack ()
|
||||
(make-instance 'stack:stack
|
||||
:test-fn #'string=))
|
||||
(fill-input-stack (stack)
|
||||
(loop
|
||||
for segment in (remove-if #'text-utils:string-empty-p
|
||||
(reverse (cl-ppcre:split "/" object)))
|
||||
do
|
||||
(stack:stack-push stack segment))))
|
||||
(let* ((ends-with-separator-p (text-utils:string-ends-with-p "/" object))
|
||||
(ends-with-dots nil)
|
||||
(input-stack (make-stack))
|
||||
(output-stack (make-stack)))
|
||||
(fill-input-stack input-stack)
|
||||
(labels ((fill-output-buffer ()
|
||||
(when (not (stack:stack-empty-p input-stack))
|
||||
(let ((popped (stack:stack-pop input-stack)))
|
||||
(cond
|
||||
((and (string= popped "..")
|
||||
(not (stack:stack-empty-p output-stack)))
|
||||
(stack:stack-pop output-stack)
|
||||
(when (stack:stack-empty-p input-stack)
|
||||
(setf ends-with-dots t)))
|
||||
((and (or (string= popped "..")
|
||||
(string= popped "."))
|
||||
(stack:stack-empty-p input-stack))
|
||||
(setf ends-with-dots t)
|
||||
(stack:stack-push output-stack "/"))
|
||||
((and (string/= popped ".")
|
||||
(string/= popped ".."))
|
||||
(stack:stack-push output-stack popped))))
|
||||
(fill-output-buffer)))
|
||||
(output-stack->list ()
|
||||
(reverse (loop
|
||||
for segment = (stack:stack-pop output-stack)
|
||||
while segment
|
||||
collect segment))))
|
||||
(fill-output-buffer)
|
||||
(let* ((joinable (output-stack->list))
|
||||
(merged (if joinable
|
||||
(if (or ends-with-separator-p
|
||||
ends-with-dots)
|
||||
(text-utils:wrap-with (text-utils:join-with-strings joinable
|
||||
"/")
|
||||
"/")
|
||||
(text-utils:strcat "/" (text-utils:join-with-strings joinable
|
||||
"/")))
|
||||
"/")))
|
||||
(cl-ppcre:regex-replace-all "//" merged ""))))))
|
||||
|
@ -272,15 +272,15 @@
|
||||
"/")
|
||||
(uri:path parsed)))))
|
||||
(make-gemini-iri original-host
|
||||
(uri:normalize-path path)
|
||||
(fs:normalize-path path)
|
||||
:query (uri:query parsed)
|
||||
:port original-port
|
||||
:fragment (uri:fragment parsed))))
|
||||
((null (uri:scheme parsed))
|
||||
(strcat +gemini-scheme+ ":"
|
||||
(to-s (uri:normalize-path parsed))))
|
||||
(to-s (fs:normalize-path parsed))))
|
||||
(t
|
||||
(to-s (uri:normalize-path parsed))))))
|
||||
(to-s (fs:normalize-path parsed))))))
|
||||
|
||||
(defun make-gemini-iri (host path &key
|
||||
(query nil)
|
||||
|
@ -114,7 +114,7 @@
|
||||
(gempub:gempub-file-p local-uri :ignore-errors t)))
|
||||
(push local-uri removed-known)
|
||||
(db:gempub-metadata-delete local-uri))))
|
||||
(loop for gempub-file in (mapcar #'uri:normalize-path all-gempub-files) do
|
||||
(loop for gempub-file in (mapcar #'fs:normalize-path all-gempub-files) do
|
||||
(when (not (db:gempub-metadata-find gempub-file))
|
||||
(push gempub-file added-file)
|
||||
(save-metadata gempub-file)))
|
||||
|
@ -306,13 +306,20 @@
|
||||
query
|
||||
fragment)))
|
||||
|
||||
(defmethod uri:normalize-path ((object iri))
|
||||
(let ((clean-path (uri:normalize-path (uri:path object)))
|
||||
(defmethod normalize-path ((object iri))
|
||||
(let ((clean-path (fs:normalize-path (uri:path object)))
|
||||
(copy (copy-iri object)))
|
||||
(when clean-path
|
||||
(setf (uri:path copy) clean-path))
|
||||
copy))
|
||||
|
||||
(defmethod normalize-path ((object uri:uri))
|
||||
(let ((clean-path (fs:normalize-path (uri:path object)))
|
||||
(copy (uri:copy-uri object)))
|
||||
(when clean-path
|
||||
(setf (uri:path copy) clean-path))
|
||||
copy))
|
||||
|
||||
(defun render-iri (iri &optional (stream *standard-output*))
|
||||
(flet ((render ()
|
||||
(with-output-to-string (string-stream)
|
||||
|
@ -317,6 +317,8 @@
|
||||
:clean-temporary-files
|
||||
:*temporary-directories-created*
|
||||
:temporary-directory
|
||||
:filename-pattern-match
|
||||
:children-matching-path
|
||||
:recursive-delete
|
||||
:clean-temporary-directories
|
||||
:with-anaphoric-temp-file
|
||||
@ -335,7 +337,8 @@
|
||||
:read-single-form
|
||||
:eq-filename
|
||||
:octects->units
|
||||
:octects->units-string))
|
||||
:octects->units-string
|
||||
:normalize-path))
|
||||
|
||||
(defpackage :os-utils
|
||||
(:use
|
||||
|
@ -1113,11 +1113,11 @@
|
||||
:accessor enqueue)))
|
||||
|
||||
(defun relative-path->absolute (path)
|
||||
(uri:normalize-path (fs:prepend-pwd path)))
|
||||
(fs:normalize-path (fs:prepend-pwd path)))
|
||||
|
||||
(defun render-directory-as-gemini-text (root-directory)
|
||||
(let* ((index-path (relative-path->absolute root-directory))
|
||||
(all-paths (mapcar #'uri:normalize-path
|
||||
(all-paths (mapcar #'fs:normalize-path
|
||||
(fs:collect-children index-path)))
|
||||
(link-lines ())
|
||||
(raw-text (with-output-to-string (stream)
|
||||
|
@ -2516,28 +2516,45 @@ printed, on the main window."
|
||||
"Upload a file"
|
||||
(when-let* ((win *filesystem-explorer-window*)
|
||||
(fields (line-oriented-window:selected-row-fields win))
|
||||
(destination-dir (fstree:tree-path fields)))
|
||||
(destination-dir (fstree:tree-path fields)))
|
||||
(labels ((build-actual-destination-file (source destination)
|
||||
(if (fs:extension-dir-p destination)
|
||||
(fs:cat-parent-dir destination
|
||||
(fs:path-last-element source))
|
||||
destination))
|
||||
(build-actual-paths (source)
|
||||
(let* ((all-children (remove-if #'fs:dirp
|
||||
(fs:children-matching-path source)))
|
||||
(destination (mapcar (lambda (a)
|
||||
(build-actual-destination-file a
|
||||
destination-dir))
|
||||
all-children)))
|
||||
(values all-children destination)))
|
||||
(on-input-complete (source-file)
|
||||
(cond
|
||||
((fs:dirp source-file)
|
||||
(error-message (format nil "~a is a directory" source-file)))
|
||||
((not (fs:file-exists-p source-file))
|
||||
(error-message (format nil "~a does not exists" source-file)))
|
||||
(t
|
||||
(when (string-not-empty-p source-file)
|
||||
(with-enqueued-process ()
|
||||
(with-blocking-notify-procedure
|
||||
((format nil (_ "Starting upload of ~a") source-file)
|
||||
(format nil (_ "Upload completed in ~a") destination-dir))
|
||||
(let ((destination-file (build-actual-destination-file source-file
|
||||
destination-dir)))
|
||||
(fstree:upload-treenode win source-file destination-file)
|
||||
(info-message destination-file)))))))))
|
||||
(when (string-not-empty-p source-file)
|
||||
(if (fs:dirp source-file)
|
||||
(error-message (format nil "~a is a directory" source-file))
|
||||
(with-enqueued-process ()
|
||||
(multiple-value-bind (sources destinations)
|
||||
(build-actual-paths source-file)
|
||||
(if (null sources)
|
||||
(error-message (format nil
|
||||
"no matching files for ~a"
|
||||
source-file))
|
||||
(loop for destination in destinations
|
||||
for source in sources
|
||||
do
|
||||
(with-blocking-notify-procedure
|
||||
((format nil
|
||||
(_ "Starting upload of ~a")
|
||||
destination)
|
||||
(format nil
|
||||
(_ "Upload of ~a completed in ~a")
|
||||
source
|
||||
destination))
|
||||
(fstree:upload-treenode win
|
||||
source
|
||||
destination))))))))))
|
||||
(ask-string-input #'on-input-complete
|
||||
:prompt (_ "Upload: ")
|
||||
:complete-fn #'complete:directory-complete))))
|
||||
|
@ -318,7 +318,6 @@
|
||||
(format string-stream "#~a" fragment))))))
|
||||
(write-string (render) stream)))
|
||||
|
||||
|
||||
(defmethod normalize-path ((object uri:uri))
|
||||
(let ((clean-path (normalize-path (uri:path object)))
|
||||
(copy (uri:copy-uri object)))
|
||||
@ -326,59 +325,6 @@
|
||||
(setf (uri:path copy) clean-path))
|
||||
copy))
|
||||
|
||||
(defgeneric normalize-path (object))
|
||||
|
||||
(defmethod normalize-path ((object null))
|
||||
nil)
|
||||
|
||||
(defmethod normalize-path ((object string))
|
||||
(flet ((make-stack ()
|
||||
(make-instance 'stack:stack
|
||||
:test-fn #'string=))
|
||||
(fill-input-stack (stack)
|
||||
(loop
|
||||
for segment in (remove-if #'string-empty-p
|
||||
(reverse (split "/" object)))
|
||||
do
|
||||
(stack:stack-push stack segment))))
|
||||
(let* ((ends-with-separator-p (string-ends-with-p "/" object))
|
||||
(ends-with-dots nil)
|
||||
(input-stack (make-stack))
|
||||
(output-stack (make-stack)))
|
||||
(fill-input-stack input-stack)
|
||||
(labels ((fill-output-buffer ()
|
||||
(when (not (stack:stack-empty-p input-stack))
|
||||
(let ((popped (stack:stack-pop input-stack)))
|
||||
(cond
|
||||
((and (string= popped "..")
|
||||
(not (stack:stack-empty-p output-stack)))
|
||||
(stack:stack-pop output-stack)
|
||||
(when (stack:stack-empty-p input-stack)
|
||||
(setf ends-with-dots t)))
|
||||
((and (or (string= popped "..")
|
||||
(string= popped "."))
|
||||
(stack:stack-empty-p input-stack))
|
||||
(setf ends-with-dots t)
|
||||
(stack:stack-push output-stack "/"))
|
||||
((and (string/= popped ".")
|
||||
(string/= popped ".."))
|
||||
(stack:stack-push output-stack popped))))
|
||||
(fill-output-buffer)))
|
||||
(output-stack->list ()
|
||||
(reverse (loop
|
||||
for segment = (stack:stack-pop output-stack)
|
||||
while segment
|
||||
collect segment))))
|
||||
(fill-output-buffer)
|
||||
(let* ((joinable (output-stack->list))
|
||||
(merged (if joinable
|
||||
(if (or ends-with-separator-p
|
||||
ends-with-dots)
|
||||
(wrap-with (join-with-strings joinable "/") "/")
|
||||
(strcat "/" (join-with-strings joinable "/")))
|
||||
"/")))
|
||||
(regex-replace-all "//" merged ""))))))
|
||||
|
||||
(defmethod to-s ((object uri:uri))
|
||||
(with-output-to-string (stream)
|
||||
(uri:render-uri object stream)))
|
||||
|
Loading…
x
Reference in New Issue
Block a user