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))))))
+  (let loop ([path (->path x)])
+    (define path-out (remove-ext path))
+    (if (equal? path path-out)
+        path
+        (loop path-out))))

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