diff --git a/file.rkt b/file.rkt index 19a2dd1..bbdf78c 100644 --- a/file.rkt +++ b/file.rkt @@ -1,6 +1,6 @@ #lang racket/base (require (for-syntax racket/base racket/syntax)) -(require racket/contract racket/path racket/match) +(require racket/contract racket/path) (require (only-in racket/path filename-extension)) (require "world.rkt" sugar/define sugar/file sugar/string sugar/coerce sugar/test) @@ -16,13 +16,13 @@ ;; use exists-proc to permit less strict matching. ;; for instance, maybe it's ok to find the source for the path. ((coerce/path? coerce/path?)((path? . -> . any/c)) . ->* . (or/c #f path?)) - (parameterize ([current-directory (dirname (->complete-path starting-path))]) - (let loop ([dir (current-directory)][path filename-to-find]) - (and dir ; dir is #f when it hits the top of the filesystem - (let ([completed-path (path->complete-path path)]) - (if (exists-proc completed-path) - (simplify-path completed-path) - (loop (dirname dir) (build-path 'up path)))))))) + (parameterize ([current-directory (dirname (->complete-path starting-path))]) + (let loop ([dir (current-directory)][path filename-to-find]) + (and dir ; dir is #f when it hits the top of the filesystem + (let ([completed-path (path->complete-path path)]) + (if (exists-proc completed-path) + (simplify-path completed-path) + (loop (dirname dir) (build-path 'up path)))))))) ;; for files like svg that are not source in pollen terms, @@ -81,24 +81,40 @@ (check-equal? (escape-last-ext "foo.html") (->path "foo_html")) (check-equal? (escape-last-ext "foo.html" #\$) (->path "foo$html"))) - +(define second cadr) +(define third caddr) +(define (last x) (car (reverse x))) (define+provide/contract (unescape-ext x [escape-char (world:current-extension-escape-char)]) - ((pathish?) (char?) . ->* . coerce/path?) + ((coerce/string?) (char?) . ->* . coerce/path?) ;; if x has an escaped extension, unescape it. - (define xstr (->string x)) - (define pat (regexp (format "(.*)[~a](.*)$" escape-char))) - (define results (regexp-match pat xstr)) - (if results - (match-let ([(list _ filename ext) results]) - (add-ext filename ext)) - x)) + (define-values (base name dir?) (split-path x)) + (cond + [dir? x] + [else + (define x-parts (explode-path x)) + (define filename (last x-parts)) + (define escaped-extension-pat (pregexp (format "(.*)[~a](\\S+)$" escape-char))) + (define results (regexp-match escaped-extension-pat (->string filename))) + (if results + (let* ([filename-without-ext (second results)] + [ext (third results)] + [new-filename (add-ext filename-without-ext ext)]) + (if (eq? base 'relative) + new-filename + (build-path base new-filename))) + x)])) (module-test-external (require sugar/coerce) (check-equal? (unescape-ext "foo") (->path "foo")) + (check-equal? (unescape-ext "foo_") (->path "foo_")) + (check-equal? (unescape-ext "foo_#$%") (->path "foo.#$%")) (check-equal? (unescape-ext "foo.html") (->path "foo.html")) (check-equal? (unescape-ext "foo_html") (->path "foo.html")) + (check-equal? (unescape-ext "foo_dir/bar") (->path "foo_dir/bar")) + (check-equal? (unescape-ext "foo_dir/bar.html") (->path "foo_dir/bar.html")) + (check-equal? (unescape-ext "foo_dir/bar_html") (->path "foo_dir/bar.html")) (check-equal? (unescape-ext "foo$html" #\$) (->path "foo.html")) (check-equal? (unescape-ext "foo_bar__html") (->path "foo_bar_.html")) (check-equal? (unescape-ext "foo$bar$$html" #\$) (->path "foo$bar$.html")))