1#lang racket/base 2 3(provide find-relative-path 4 simple-form-path 5 normalize-path 6 path-has-extension? 7 path-get-extension 8 filename-extension 9 file-name-from-path 10 path-only 11 some-system-path->string 12 string->some-system-path 13 path-element? 14 shrink-path-wrt) 15 16(define (simple-form-path p) 17 (unless (path-string? p) 18 (raise-argument-error 'simple-form-path "path-string?" p)) 19 (simplify-path (path->complete-path p))) 20 21;; Note that normalize-path does not normalize the case 22(define normalize-path 23 (letrec ([resolve-all 24 (lambda (path wrt) 25 (let ([orig-path (if (and wrt (not (complete-path? path))) 26 (path->complete-path path wrt) 27 path)]) 28 (let loop ([full-path orig-path][seen-paths (list orig-path)]) 29 (let ([resolved (resolve-path full-path)]) 30 (if (equal? resolved full-path) 31 (do-normalize-path resolved #f) 32 (let ([path (if (relative-path? resolved) 33 (build-path 34 (let-values ([(base name dir?) (split-path full-path)]) 35 base) 36 resolved) 37 resolved)]) 38 (if (member path seen-paths) 39 (error 'normalize-path "circular reference found\n path: ~a" path) 40 (let ([spath 41 ;; Use simplify-path to get rid of ..s, which can 42 ;; allow the path to grow indefinitely in a cycle. 43 ;; An exception must mean a cycle of links. 44 (with-handlers ([exn:fail:filesystem? 45 (lambda (x) 46 (error 'normalize-path "circular reference found\n path: ~a" path))]) 47 (simplify-path path))]) 48 (loop spath (cons path seen-paths))))))))))] 49 [resolve 50 (lambda (path) 51 (if (equal? path (resolve-path path)) 52 path 53 (resolve-all path #f)))] 54 [normalize-path 55 (case-lambda 56 [(orig-path) (do-normalize-path orig-path (current-directory))] 57 [(orig-path wrt) 58 (unless (and (path-string? wrt) (complete-path? wrt)) 59 (raise-argument-error 'normalize-path "(and/c path-string? complete-path?)" wrt)) 60 (do-normalize-path orig-path wrt)])] 61 [error-not-a-dir 62 (lambda (path) 63 (error 'normalize-path 64 "element within the input path is not a directory or does not exist\n element: ~a" 65 path))] 66 [do-normalize-path 67 (lambda (orig-path wrt) 68 (let normalize ([path (cleanse-path orig-path)]) 69 (let-values ([(base name dir?) (split-path path)]) 70 (cond 71 [(eq? name 'up) 72 (let up ([base (if (eq? base 'relative) 73 wrt 74 (resolve-all base wrt))]) 75 (if (directory-exists? base) 76 (let-values ([(prev name dir?) (split-path base)]) 77 (cond 78 [(not prev) 79 (error 'normalize-path 80 "root has no parent directory\n root path: ~a" 81 orig-path)] 82 [else 83 (let ([prev 84 (if (eq? prev 'relative) 85 wrt 86 (normalize prev))]) 87 (cond 88 [(eq? name 'same) (up prev)] 89 [(eq? name 'up) (up (up prev))] 90 [else prev]))])) 91 (error-not-a-dir base)))] 92 [(eq? name 'same) 93 (cond 94 [(eq? base 'relative) wrt] 95 [else (let ([n (normalize base)]) 96 (if (directory-exists? n) 97 n 98 (error-not-a-dir n)))])] 99 [(not base) (path->complete-path path)] 100 [else 101 (let* ([base (if (eq? base 'relative) 102 (normalize wrt) 103 (normalize base))] 104 [path (if (directory-exists? base) 105 (build-path base name) 106 (error-not-a-dir base))] 107 [resolved (cleanse-path (resolve path))]) 108 (cond 109 [(relative-path? resolved) 110 (normalize (build-path base resolved))] 111 [(complete-path? resolved) 112 resolved] 113 [else (path->complete-path resolved base)]))]))))]) 114 normalize-path)) 115 116(define (do-explode-path who orig-path) 117 (define l (explode-path orig-path)) 118 (for ([p (in-list l)]) 119 (when (not (path-for-some-system? p)) 120 (raise-argument-error who 121 "(and/c path-for-some-system? simple-form?)" 122 orig-path))) 123 l) 124 125;; Arguments must be in simple form 126(define (find-relative-path directory filename 127 #:more-than-same? [more-than-same? #t] 128 #:more-than-root? [more-than-root? #f] 129 #:normalize-case? [normalize-case? #t]) 130 (let ([dir (do-explode-path 'find-relative-path directory)] 131 [file (do-explode-path 'find-relative-path filename)] 132 [normalize (lambda (p) 133 (if normalize-case? 134 (normal-case-path p) 135 p))]) 136 (if (and (equal? (normalize (car dir)) (normalize (car file))) 137 (or (not more-than-root?) 138 (not (eq? 'unix (if (string? directory) 139 (system-path-convention-type) 140 (path-convention-type directory)))) 141 (null? (cdr dir)) 142 (null? (cdr file)) 143 (equal? (normalize (cadr dir)) (normalize (cadr file))))) 144 (let loop ([dir (cdr dir)] 145 [file (cdr file)]) 146 (cond [(null? dir) (if (null? file) 147 (if more-than-same? 148 filename 149 (build-path 'same)) 150 (apply build-path file))] 151 [(null? file) (apply build-path/convention-type 152 (if (string? filename) 153 (system-path-convention-type) 154 (path-convention-type filename)) 155 (map (lambda (x) 'up) dir))] 156 [(equal? (normalize (car dir)) (normalize (car file))) 157 (loop (cdr dir) (cdr file))] 158 [else 159 (apply build-path (append (map (lambda (x) 'up) dir) file))])) 160 filename))) 161 162(define (file-name who name dir-ok?) 163 (unless (or (path-string? name) 164 (path-for-some-system? name)) 165 (raise-argument-error who "(or/c path-string? path-for-some-system?)" name)) 166 (let-values ([(base file dir?) (split-path name)]) 167 (and (or dir-ok? (not dir?)) 168 (path-for-some-system? file) file))) 169 170(define (file-name-from-path name) 171 (file-name 'file-name-from-path name #f)) 172 173(define (path-only name) 174 (unless (or (path-string? name) 175 (path-for-some-system? name)) 176 (raise-argument-error 'path-only "(or/c path-string? path-for-some-system?)" name)) 177 (let-values ([(base file dir?) (split-path name)]) 178 (cond [dir? (if (string? name) (string->path name) name)] 179 [(path-for-some-system? base) base] 180 [else #f]))) 181 182(define (path-has-extension? name sfx) 183 (unless (path-string? name) 184 (raise-argument-error 'path-extension=? "path-string?" name)) 185 (unless (or (bytes? sfx) (string? sfx)) 186 (raise-argument-error 'path-extension=? "(or/c bytes? string?)" name)) 187 (let-values ([(base file dir?) (split-path name)]) 188 (and base 189 (path? file) 190 (let* ([bs (path-element->bytes file)] 191 [sfx (if (bytes? sfx) sfx (string->bytes/utf-8 sfx))] 192 [len (bytes-length bs)] 193 [slen (bytes-length sfx)]) 194 (and (len . > . slen) 195 (bytes=? sfx (subbytes bs (- len slen)))))))) 196 197(define (path-get-extension name) 198 (let* ([name (file-name 'path-get-extension name #t)] 199 [name (and name (path->bytes name))]) 200 (cond [(and name (regexp-match #rx#"(?<=.)([.][^.]+)$" name)) => cadr] 201 [else #f]))) 202 203;; This old variant doesn't correctly handle filenames that start with ".": 204(define (filename-extension name) 205 (let* ([name (file-name 'filename-extension name #f)] 206 [name (and name (path->bytes name))]) 207 (cond [(and name (regexp-match #rx#"[.]([^.]+)$" name)) => cadr] 208 [else #f]))) 209 210(define (some-system-path->string path) 211 (unless (path-for-some-system? path) 212 (raise-argument-error 'some-system-path->string "path-for-some-system?" path)) 213 (bytes->string/utf-8 (path->bytes path))) 214 215(define (string->some-system-path path kind) 216 (unless (string? path) 217 (raise-argument-error 'string->some-system-path "string?" path)) 218 (unless (or (eq? kind 'unix) 219 (eq? kind 'windows)) 220 (raise-argument-error 'string->some-system-path "(or/c 'unix 'windows)" kind)) 221 (bytes->path (string->bytes/utf-8 path) kind)) 222 223(define (path-element? path) 224 (and (path-for-some-system? path) 225 (let-values ([(base name d?) (split-path path)]) 226 (and (eq? base 'relative) 227 (path-for-some-system? name))))) 228 229 230 231(define (shrink-path-wrt fn other-fns) 232 (unless (path? fn) 233 (raise-argument-error 234 'shrink-path-wrt 235 "path?" 236 0 fn other-fns)) 237 (unless (and (list? other-fns) (andmap path? other-fns)) 238 (raise-argument-error 239 'shrink-path-wrt 240 "(listof path?)" 241 1 fn other-fns)) 242 (define exp (reverse (explode-path fn))) 243 (define other-exps 244 (filter 245 (λ (x) (not (equal? exp x))) 246 (map (λ (fn) (reverse (explode-path fn))) 247 other-fns))) 248 (cond 249 [(null? other-exps) #f] 250 [else 251 (define size 252 (let loop ([other-exps other-exps] 253 [size 1]) 254 (cond 255 [(null? other-exps) size] 256 [else (let ([new-size (find-exp-diff (car other-exps) exp)]) 257 (loop (cdr other-exps) 258 (max new-size size)))]))) 259 (apply build-path (reverse (take-n size exp)))])) 260 261(define (take-n n lst) 262 (let loop ([n n] 263 [lst lst]) 264 (cond 265 [(zero? n) null] 266 [(null? lst) null] 267 [else (cons (car lst) (loop (- n 1) (cdr lst)))]))) 268 269(define (find-exp-diff p1 p2) 270 (let loop ([p1 p1] 271 [p2 p2] 272 [i 1]) 273 (cond 274 [(or (null? p1) (null? p2)) i] 275 [else (let ([f1 (car p1)] 276 [f2 (car p2)]) 277 (if (equal? f1 f2) 278 (loop (cdr p1) (cdr p2) (+ i 1)) 279 i))]))) 280