~ chicken-core (chicken-5) /pathname.scm

  1;;;; pathname.scm - Pathname operations
  2;
  3; Copyright (c) 2008-2022, The CHICKEN Team
  4; Copyright (c) 2000-2007, Felix L. Winkelmann
  5; All rights reserved.
  6;
  7; Redistribution and use in source and binary forms, with or without
  8; modification, are permitted provided that the following conditions
  9; are met:
 10;
 11;   Redistributions of source code must retain the above copyright
 12;   notice, this list of conditions and the following disclaimer.
 13;
 14;   Redistributions in binary form must reproduce the above copyright
 15;   notice, this list of conditions and the following disclaimer in
 16;   the documentation and/or other materials provided with the
 17;   distribution.
 18;
 19;   Neither the name of the author nor the names of its contributors
 20;     may be used to endorse or promote products derived from this
 21;     software without specific prior written permission.
 22;
 23; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
 24; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
 25; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS
 26; FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
 27; COPYRIGHT HOLDERS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT,
 28; INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
 29; (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
 30; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
 31; HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,
 32; STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
 33; ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED
 34; OF THE POSSIBILITY OF SUCH DAMAGE.
 35
 36(declare
 37  (unit pathname)
 38  (uses data-structures irregex)
 39  (fixnum)
 40  (disable-interrupts))
 41
 42(module chicken.pathname
 43  (absolute-pathname? decompose-directory decompose-pathname
 44   directory-null? make-absolute-pathname make-pathname
 45   normalize-pathname pathname-directory pathname-extension
 46   pathname-file pathname-replace-directory pathname-replace-extension
 47   pathname-replace-file pathname-strip-directory
 48   pathname-strip-extension)
 49
 50(import scheme
 51        chicken.base
 52        chicken.fixnum
 53        chicken.irregex
 54        chicken.platform
 55        chicken.string)
 56
 57(include "common-declarations.scm")
 58
 59;;; Pathname operations:
 60
 61;; Platform specific absolute pathname operations:
 62;; absolute-pathname-root => #f or (<match> [<origin>] <root>)
 63;;
 64;; Not for general consumption
 65
 66(define absolute-pathname-root)
 67(define root-origin)
 68(define root-directory)
 69
 70(if ##sys#windows-platform
 71    (let ((rx (irregex "([A-Za-z]:)?([\\/\\\\]).*")))
 72      (set! absolute-pathname-root (lambda (pn) (irregex-match rx pn)))
 73      (set! root-origin (lambda (rt) (and rt (irregex-match-substring rt 1))))
 74      (set! root-directory (lambda (rt) (and rt (irregex-match-substring rt 2)))))
 75    (let ((rx (irregex "(/).*")))
 76      (set! absolute-pathname-root (lambda (pn) (irregex-match rx pn)))
 77      (set! root-origin (lambda (rt) #f))
 78      (set! root-directory (lambda (rt) (and rt (irregex-match-substring rt 1))))))
 79
 80(define (absolute-pathname? pn)
 81  (##sys#check-string pn 'absolute-pathname?)
 82  (irregex-match-data? (absolute-pathname-root pn)))
 83
 84(define-inline (*char-pds? ch)
 85  (if ##sys#windows-platform
 86      (memq ch '(#\\ #\/))
 87      (eq? #\/ ch)))
 88
 89(define (chop-pds str)
 90  (and str
 91       (let lp ((len (##sys#size str)))
 92	 (cond ((and (fx>= len 1)
 93		     (*char-pds? (##core#inline "C_subchar" str (fx- len 1))))
 94		(lp (fx- len 1)))
 95	       ((fx< len (##sys#size str))
 96		(##sys#substring str 0 len))
 97	       (else str)))))
 98
 99(define make-pathname)
100(define make-absolute-pathname)
101
102(let ((pds (if ##sys#windows-platform "\\" "/")))
103
104  (define (conc-dirs dirs)
105    (##sys#check-list dirs 'make-pathname)
106    (let loop ((strs dirs))
107      (if (null? strs)
108	  ""
109	  (let ((s1 (car strs)))
110	    (if (zero? (string-length s1))
111		(loop (cdr strs))
112		(string-append
113		 (chop-pds (car strs))
114		 pds
115		 (loop (cdr strs))))))))
116
117  (define (canonicalize-dirs dirs)
118    (cond ((or (not dirs) (null? dirs)) "")
119	  ((string? dirs) (conc-dirs (list dirs)))
120	  (else           (conc-dirs dirs))))
121
122  (define (_make-pathname loc dir file ext)
123    (let ((ext (or ext ""))
124	  (file (or file "")))
125      (##sys#check-string dir loc)
126      (##sys#check-string file loc)
127      (##sys#check-string ext loc)
128      (string-append
129       dir
130       (if (and (fx>= (##sys#size dir) 1)
131		(fx>= (##sys#size file) 1)
132		(*char-pds? (##core#inline "C_subchar" file 0)))
133	   (##sys#substring file 1 (##sys#size file))
134	   file)
135       (if (and (fx> (##sys#size ext) 0)
136		(not (char=? (##core#inline "C_subchar" ext 0) #\.)))
137	   "."
138	   "")
139       ext)))
140
141  (set! make-pathname
142    (lambda (dirs file #!optional ext)
143      (_make-pathname 'make-pathname (canonicalize-dirs dirs) file ext)))
144
145  (set! make-absolute-pathname
146    (lambda (dirs file #!optional ext)
147      (_make-pathname
148       'make-absolute-pathname
149       (let ((dir (canonicalize-dirs dirs)))
150	 (if (absolute-pathname? dir)
151	     dir
152	     (##sys#string-append pds dir)))
153       file ext))))
154
155(define decompose-pathname
156  (let* ((patt1 (if ##sys#windows-platform
157                    "^(.*[\\/\\\\])?([^\\/\\\\]+)(\\.([^\\/\\\\.]+))$"
158                    "^(.*/)?([^/]+)(\\.([^/.]+))$"))
159	 (patt2 (if ##sys#windows-platform
160                    "^(.*[\\/\\\\])?((\\.)?[^\\/\\\\]+)$"
161                    "^(.*/)?((\\.)?[^/]+)$"))
162	 (rx1 (irregex patt1))
163	 (rx2 (irregex patt2))
164         (strip-pds
165          (lambda (dir)
166            (and dir
167                 (let ((chopped (chop-pds dir)))
168                   (if (fx> (##sys#size chopped) 0)
169                       chopped
170                       (##sys#substring dir 0 1)))))))
171    (lambda (pn)
172      (##sys#check-string pn 'decompose-pathname)
173      (if (fx= 0 (##sys#size pn))
174	  (values #f #f #f)
175	  (let ((ms (irregex-search rx1 pn)))
176	    (if ms
177		(values
178		 (strip-pds (irregex-match-substring ms 1))
179		 (irregex-match-substring ms 2)
180		 (irregex-match-substring ms 4))
181		(let ((ms (irregex-search rx2 pn)))
182		  (if ms
183		      (values
184		       (strip-pds (irregex-match-substring ms 1))
185		       (irregex-match-substring ms 2)
186		       #f)
187		      (values (strip-pds pn) #f #f)))))))))
188
189(define pathname-directory
190  (lambda (pn)
191    (let-values (((dir file ext) (decompose-pathname pn)))
192      dir)))
193
194(define pathname-file
195  (lambda (pn)
196    (let-values (((dir file ext) (decompose-pathname pn)))
197      file)))
198
199(define pathname-extension
200  (lambda (pn)
201    (let-values (((dir file ext) (decompose-pathname pn)))
202      ext)))
203
204(define pathname-strip-directory
205  (lambda (pn)
206    (let-values (((dir file ext) (decompose-pathname pn)))
207      (make-pathname #f file ext))))
208
209(define pathname-strip-extension
210  (lambda (pn)
211    (let-values (((dir file ext) (decompose-pathname pn)))
212      (make-pathname dir file))))
213
214(define pathname-replace-directory
215  (lambda (pn dir)
216    (let-values (((_ file ext) (decompose-pathname pn)))
217      (make-pathname dir file ext))))
218
219(define pathname-replace-file
220  (lambda (pn file)
221    (let-values (((dir _ ext) (decompose-pathname pn)))
222      (make-pathname dir file ext))))
223
224(define pathname-replace-extension
225  (lambda (pn ext)
226    (let-values (((dir file _) (decompose-pathname pn)))
227      (make-pathname dir file ext))))
228
229;;; normalize pathname for a particular platform
230
231(define normalize-pathname
232  (let ((bldplt (if (eq? (software-version) 'mingw32) 'windows 'unix)))
233    (define (addpart part parts)
234      (cond ((string=? "." part) parts)
235            ((string=? ".." part)
236	     (if (or (null? parts)
237		     (string=? ".." (car parts)))
238		 (cons part parts)
239		 (cdr parts)))
240            (else (cons part parts))))
241    (lambda (path #!optional (platform bldplt))
242      (let ((sep (if (eq? platform 'windows) #\\ #\/)))
243        (define (pds? c)
244          (if (eq? platform 'windows)
245              (memq c '(#\/ #\\))
246              (eq? c #\/)))
247	(##sys#check-string path 'normalize-pathname)
248	(let ((len (##sys#size path))
249	      (type #f)
250	      (drive #f))
251	  (let loop ((i 0) (prev 0) (parts '()))
252	    (cond ((fx>= i len)
253		   (when (fx> i prev)
254		     (set! parts (addpart (##sys#substring path prev i) parts)))
255		   (if (null? parts)
256		       (let ((r (if (eq? type 'abs) (string sep) ".")))
257			 (if drive (##sys#string-append drive r) r))
258		       (let ((out (open-output-string))
259			     (parts (##sys#fast-reverse parts)))
260			 (display (car parts) out)
261			 (for-each
262			  (lambda (p)
263			    (##sys#write-char-0 sep out)
264			    (display p out))
265			  (cdr parts))
266			 (when (fx= i prev) (##sys#write-char-0 sep out))
267			 (let ((r (get-output-string out)))
268			   (when (eq? type 'abs)
269			     (set! r (##sys#string-append (string sep) r)))
270			   (when drive
271			     (set! r (##sys#string-append drive r)))
272			   r))))
273		  ((pds? (string-ref path i))
274		   (when (not type)
275		     (set! type (if (fx= i prev) 'abs 'rel)))
276		   (if (fx= i prev)
277		       (loop (fx+ i 1) (fx+ i 1) parts)
278		       (loop (fx+ i 1)
279			     (fx+ i 1)
280			     (addpart (##sys#substring path prev i) parts))))
281		  ((and (null? parts)
282			(char=? (string-ref path i) #\:)
283			(eq? platform 'windows))
284		   (set! drive (##sys#substring path 0 (fx+ i 1)))
285		   (loop (fx+ i 1) (fx+ i 1) '()))
286		  (else (loop (fx+ i 1) prev parts)))))))))
287
288;; directory pathname => list of strings
289;; does arg check
290
291(define split-directory
292  (lambda (loc dir keep?)
293    (##sys#check-string dir loc)
294    (string-split dir (if ##sys#windows-platform "/\\" "/") keep?)))
295
296;; Directory string or list only contains path-separators
297;; and/or current-directory (".") names.
298
299(define (directory-null? dir)
300  (let loop ((ls (if (list? dir) dir (split-directory 'directory-null? dir #t))))
301    (or (null? ls)
302        (and (member (car ls) '("" "."))
303             (loop (cdr ls))))))
304
305;; Directory string => {<origin> <root> <directory-list>}
306;; where any maybe #f when missing
307
308(define (decompose-directory dir)
309  (define (strip-origin-prefix org decomp)
310    #;(assert (or (not org) decomp)) ;cannot have an "origin" but no "decomp"
311    (if (not org)
312        decomp
313        (let ((1st (car decomp)))
314          (let ((olen (##sys#size org)))
315            (if (not (##core#inline "C_substring_compare" org 1st 0 0 olen))
316                ; then origin is not a prefix (really shouldn't happen)
317                decomp
318                ; else is a prefix
319                (let ((rst (cdr decomp))
320                      (elen (##sys#size 1st)))
321                  (if (fx= olen elen)
322                      ; then origin is a list prefix
323                      rst
324                      ; else origin is a string prefix
325                      (cons (##sys#substring 1st olen elen) rst))))))))
326  (let* ((ls (split-directory 'decompose-directory dir #f))
327         (rt (absolute-pathname-root dir))
328         (org (root-origin rt)))
329    (values org (root-directory rt) (strip-origin-prefix org (and (not (null? ls)) ls))))))