diff --git a/sugar/file.rkt b/sugar/file.rkt index 9a37eae..50d4353 100644 --- a/sugar/file.rkt +++ b/sugar/file.rkt @@ -1,12 +1,36 @@ #lang racket/base -(require "define.rkt" "coerce/base.rkt" racket/path) +(require "define.rkt" "coerce/base.rkt") -;; does path have a certain extension +;; this is identical to `filename-extension` in `racket/path` +;; but will not treat hidden files as an extension (which IMHO is a bug) +(define (filename-extension name) + (let* ([name (file-name-from-path name)] + [name (and name (path->bytes name))]) + (cond [(and name (regexp-match #rx#".[.]([^.]+)$" name)) => cadr] + [else #f]))) + +(module+ test + (require rackunit) + (require (prefix-in rp: racket/path)) + (check-equal? (rp:filename-extension (string->path ".foo")) #"foo") ; bad behavior + (check-false (filename-extension (string->path ".foo")))) ; good behavior + + +;; this is pulled in from `racket/path` to avoid the dependency +(define (file-name-from-path name) + (unless (or (path-string? name) + (path-for-some-system? name)) + (raise-argument-error 'file-name-from-path "(or/c path-string? path-for-some-system?)" name)) + (let-values ([(base file dir?) (split-path name)]) + (and (not dir?) (path-for-some-system? file) file))) + + +;; does path have a certain extension, case-insensitively (define+provide+safe (has-ext? x ext) (pathish? stringish? . -> . boolean?) (define ext-of-path (filename-extension (->path x))) - (->boolean (and ext-of-path (equal? (string-downcase (bytes->string/utf-8 ext-of-path)) (string-downcase (->string ext)))))) + (and ext-of-path (equal? (string-downcase (bytes->string/utf-8 ext-of-path)) (string-downcase (->string ext))))) ;; get file extension as a string, or return #f @@ -40,25 +64,27 @@ (define pat (regexp (format "^~a" (regexp-quote starter)))) (and (regexp-match pat str) #t)) +(define (path-hidden? path) + ((->string (file-name-from-path path)) . starts-with? . ".")) + +;; with `remove-ext` and `remove-ext*`, +;; the policy is to pass through hidden files +;; though I can't remember why. ;; take one extension off path (define+provide+safe (remove-ext x) (pathish? . -> . path?) - ;; pass through hidden files (those starting with a dot) - (let ([x (->path x)]) - (if ((->string x) . starts-with? . ".") - x - (path-replace-suffix x "")))) + (let ([path (->path x)]) + (if (path-hidden? path) + path + (path-replace-suffix path "")))) ;; take all extensions off path (define+provide+safe (remove-ext* x) (pathish? . -> . path?) - ;; pass through hidden files (those starting with a dot) - (let ([x (->path x)]) - (if ((->string x) . starts-with? . ".") - x - (let ([path-with-removed-ext (remove-ext x)]) - (if (equal? x path-with-removed-ext) - x - (remove-ext* path-with-removed-ext)))))) \ No newline at end of file + (let loop ([path (->path x)]) + (define path-out (remove-ext path)) + (if (equal? path path-out) + path + (loop path-out)))) \ No newline at end of file diff --git a/sugar/test/main.rkt b/sugar/test/main.rkt index e779373..9c2edd0 100644 --- a/sugar/test/main.rkt +++ b/sugar/test/main.rkt @@ -147,6 +147,7 @@ (check-equal? (get-ext (->path "foo.txt")) "txt") (check-false (get-ext "foo")) + (check-false (get-ext ".foo")) (check-equal? (add-ext (string->path "foo") "txt") (string->path "foo.txt")) (check-equal? (remove-ext foo-path) foo-path) @@ -154,12 +155,20 @@ (check-equal? (remove-ext foo.txt-path) foo-path) (check-equal? (remove-ext foo.bar.txt-path) foo.bar-path) (check-not-equal? (remove-ext foo.bar.txt-path) foo-path) ; does not remove all extensions + ;; test remove-ext on paths that have "." prefix + (check-equal? (remove-ext (->path "./foo.txt.bar")) (->path "./foo.txt")) + (check-equal? (remove-ext (->path "../foo.txt.bar")) (->path "../foo.txt")) + (check-equal? (remove-ext (->path "/hidden/file/.foo.txt.bar")) (->path "/hidden/file/.foo.txt.bar")) ; hidden file won't change (check-equal? (remove-ext* foo-path) foo-path) (check-equal? (remove-ext* foo.txt-path) foo-path) (check-equal? (remove-ext* (->path ".foo.txt")) (->path ".foo.txt")) (check-not-equal? (remove-ext* foo.bar.txt-path) foo.bar-path) ; removes more than one ext (check-equal? (remove-ext* foo.bar.txt-path) foo-path) + ;; test remove-ext* on paths that have "." prefix + (check-equal? (remove-ext* (->path "./foo.txt.bar")) (->path "./foo")) + (check-equal? (remove-ext* (->path "../foo.txt.bar")) (->path "../foo")) + (check-equal? (remove-ext* (->path "/hidden/file/.foo.txt.bar")) (->path "/hidden/file/.foo.txt.bar")) ; hidden file won't change (check-true (has-binary-ext? "foo.MP3")) (check-false (has-binary-ext? "foo.py"))