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