cage/tinmop
1
0
Fork 0
mirror of https://codeberg.org/cage/tinmop/ synced 2025-02-17 08:10:36 +01:00
Code Issues

- added a wrapper for 'fnmatch(3)';

Browse Source 
- [kamid] upload works with wildcard (e.g. "/*.lisp");
- moved 'normalize-path' to filesystem-utils.
This commit is contained in:
cage 2022-01-28 12:24:24 +01:00
parent e7492af2bd
commit 31b9685737
9 changed files with 130 additions and 82 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -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)

73
src/filesystem-utils.lisp
View File

@ -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 ""))))))

6
src/gemini/gemini-parser.lisp
View File

@ -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)

2
src/gempub.lisp
View File

@ -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)))

11
src/iri-parser.lisp
View 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)

5
src/package.lisp
View File

@ -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

4
src/program-events.lisp
View File

@ -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)

49
src/ui-goodies.lisp
View File

@ -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))))

54
src/uri-parser.lisp
View File

@ -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)))