diff --git a/private/file-walker.rkt b/private/file-walker.rkt index 8aab1b2..1fc68de 100644 --- a/private/file-walker.rkt +++ b/private/file-walker.rkt @@ -6,6 +6,7 @@ racket/path "store.rkt" "log.rkt" + "util.rkt" file/glob) (provide make-file-walker @@ -37,30 +38,43 @@ (let ((path (gen))) (if (void? path) (values #f #f #f) - (let* ((str-path (path->string path)) - (ext* (path-get-extension path)) - (ext (string->symbol - (substring - (if (eq? ext* #f) - "." - (let ((e (string-downcase (bytes->string/utf-8 ext*)))) - (if (string-contains? e " ") - "." - e))) 1))) - (path-part (substring str-path base-path-len)) - (str-n-path (string-replace path-part "\\" "/")) - (info (let ((h (make-hash (list - (cons 'type 'dir) - (cons 'path str-n-path) - (cons 'ext ext))))) - (when (file-exists? path) - (hash-set! h 'type 'file) - (hash-set! h 'size (file-size path)) - (hash-set! h 'mtime (file-or-directory-modify-seconds path)) - ) - h)) + (let* ((bd (basedir path)) + (bn (format "~a" (basename path))) + (nbn (clean-os-basename bn)) ) - (filter-func base-path path info))) + + (unless (string=? bn nbn) + (with-handlers ([exn? (λ (e) + (warn-am "Cannot rename dirty filename: ~a" nbn))]) + (rename-file-or-directory (build-path bd bn) + (build-path bn nbn) #f) + (set! path (build-path bd nbn)) + )) + + (let* ((str-path (path->string path)) + (ext* (path-get-extension path)) + (ext (string->symbol + (substring + (if (eq? ext* #f) + "." + (let ((e (string-downcase (bytes->string/utf-8 ext*)))) + (if (string-contains? e " ") + "." + e))) 1))) + (path-part (substring str-path base-path-len)) + (str-n-path (string-replace path-part "\\" "/")) + (info (let ((h (make-hash (list + (cons 'type 'dir) + (cons 'path str-n-path) + (cons 'ext ext))))) + (when (file-exists? path) + (hash-set! h 'type 'file) + (hash-set! h 'size (file-size path)) + (hash-set! h 'mtime (file-or-directory-modify-seconds path)) + ) + h)) + ) + (filter-func base-path path info)))) ) ) ) @@ -168,7 +182,9 @@ (let-values (((base-path* path* info*) (file-admin base-path path info))) (values base-path* path* info*))))) (deleted #f)) + (init-db-sweep) + (letrec ((f (λ () (if (list? deleted) (if (null? deleted) @@ -201,3 +217,26 @@ (step-func base-path path info)))) ) + +(define (clean-os-basename name) + (let* ((s0 (format "~a" name)) + (s1 (list->string + (for/list ((ch (in-string s0))) + (if (or (< (char->integer ch) 32) + (memq ch '(#\< #\> #\: #\" #\/ #\\ #\| #\? #\*))) + #\- + ch)))) + (s2 (regexp-replace* #px"\\s+" s1 " ")) + (s3 (regexp-replace* #px"[- ]+" s2 " ")) + (s4 (string-trim s3 " .-_")) + (device-name (let* ((parts (string-split s4 ".")) + (first-part (if (null? parts) s4 (car parts)))) + first-part)) + (reserved? (regexp-match? + #px"(?i:^(con|prn|aux|nul|com[1-9]|lpt[1-9])$)" + device-name)) + (s5 (cond + ((string=? s4 "") "_") + (reserved? (string-append "_" s4)) + (else s4)))) + s5)) \ No newline at end of file