~ chicken-core (master) /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(import (only (scheme base) open-output-string get-output-string))
 57
 58(include "common-declarations.scm")
 59
 60;;; Pathname operations:
 61
 62;; Platform specific absolute pathname operations:
 63;; absolute-pathname-root => #f or (<match> [<origin>] <root>)
 64;;
 65;; Not for general consumption
 66
 67(define absolute-pathname-root)
 68(define root-origin)
 69(define root-directory)
 70
 71(if ##sys#windows-platform
 72    (let ((rx (irregex "([A-Za-z]:)?([\\/\\\\]).*")))
 73      (set! absolute-pathname-root (lambda (pn) (irregex-match rx pn)))
 74      (set! root-origin (lambda (rt) (and rt (irregex-match-substring rt 1))))
 75      (set! root-directory (lambda (rt) (and rt (irregex-match-substring rt 2)))))
 76    (let ((rx (irregex "(/).*")))
 77      (set! absolute-pathname-root (lambda (pn) (irregex-match rx pn)))
 78      (set! root-origin (lambda (rt) #f))
 79      (set! root-directory (lambda (rt) (and rt (irregex-match-substring rt 1))))))
 80
 81(define (absolute-pathname? pn)
 82  (##sys#check-string pn 'absolute-pathname?)
 83  (irregex-match-data? (absolute-pathname-root pn)))
 84
 85(define-inline (*char-pds? ch)
 86  (if ##sys#windows-platform
 87      (memq ch '(#\\ #\/))
 88      (eq? #\/ ch)))
 89
 90(define (chop-pds str)
 91  (and str
 92       (let lp ((len (string-length str)))
 93	 (cond ((and (fx>= len 1)
 94		     (*char-pds? (string-ref str (fx- len 1))))
 95		(lp (fx- len 1)))
 96	       ((fx< len (string-length str))
 97		(##sys#substring str 0 len))
 98	       (else str)))))
 99
100(define make-pathname)
101(define make-absolute-pathname)
102
103(let ((pds (if ##sys#windows-platform "\\" "/")))
104
105  (define (conc-dirs dirs)
106    (##sys#check-list dirs 'make-pathname)
107    (let loop ((strs dirs))
108      (if (null? strs)
109	  ""
110	  (let ((s1 (car strs)))
111	    (if (zero? (string-length s1))
112		(loop (cdr strs))
113		(string-append
114		 (chop-pds (car strs))
115		 pds
116		 (loop (cdr strs))))))))
117
118  (define (canonicalize-dirs dirs)
119    (cond ((or (not dirs) (null? dirs)) "")
120	  ((string? dirs) (conc-dirs (list dirs)))
121	  (else           (conc-dirs dirs))))
122
123  (define (_make-pathname loc dir file ext)
124    (let ((ext (or ext ""))
125	  (file (or file "")))
126      (##sys#check-string dir loc)
127      (##sys#check-string file loc)
128      (##sys#check-string ext loc)
129      (string-append
130       dir
131       (if (and (fx>= (string-length dir) 1)
132		(fx>= (string-length file) 1)
133		(*char-pds? (string-ref file 0)))
134	   (##sys#substring file 1 (string-length file))
135	   file)
136       (if (and (fx> (string-length ext) 0)
137		(not (char=? (string-ref ext 0) #\.)))
138	   "."
139	   "")
140       ext)))
141
142  (set! make-pathname
143    (lambda (dirs file #!optional ext)
144      (_make-pathname 'make-pathname (canonicalize-dirs dirs) file ext)))
145
146  (set! make-absolute-pathname
147    (lambda (dirs file #!optional ext)
148      (_make-pathname
149       'make-absolute-pathname
150       (let ((dir (canonicalize-dirs dirs)))
151	 (if (absolute-pathname? dir)
152	     dir
153	     (##sys#string-append pds dir)))
154       file ext))))
155
156(define decompose-pathname
157  (let* ((patt1 (if ##sys#windows-platform
158                    "^(.*[\\/\\\\])?([^\\/\\\\]+)(\\.([^\\/\\\\.]+))$"
159                    "^(.*/)?([^/]+)(\\.([^/.]+))$"))
160	 (patt2 (if ##sys#windows-platform
161                    "^(.*[\\/\\\\])?((\\.)?[^\\/\\\\]+)$"
162                    "^(.*/)?((\\.)?[^/]+)$"))
163	 (rx1 (irregex patt1))
164	 (rx2 (irregex patt2))
165         (strip-pds
166          (lambda (dir)
167            (and dir
168                 (let ((chopped (chop-pds dir)))
169                   (if (fx> (string-length chopped) 0)
170                       chopped
171                       (##sys#substring dir 0 1)))))))
172    (lambda (pn)
173      (##sys#check-string pn 'decompose-pathname)
174      (if (fx= 0 (string-length pn))
175	  (values #f #f #f)
176	  (let ((ms (irregex-search rx1 pn)))
177	    (if ms
178		(values
179		 (strip-pds (irregex-match-substring ms 1))
180		 (irregex-match-substring ms 2)
181		 (irregex-match-substring ms 4))
182		(let ((ms (irregex-search rx2 pn)))
183		  (if ms
184		      (values
185		       (strip-pds (irregex-match-substring ms 1))
186		       (irregex-match-substring ms 2)
187		       #f)
188		      (values (strip-pds pn) #f #f)))))))))
189
190(define pathname-directory
191  (lambda (pn)
192    (let-values (((dir file ext) (decompose-pathname pn)))
193      dir)))
194
195(define pathname-file
196  (lambda (pn)
197    (let-values (((dir file ext) (decompose-pathname pn)))
198      file)))
199
200(define pathname-extension
201  (lambda (pn)
202    (let-values (((dir file ext) (decompose-pathname pn)))
203      ext)))
204
205(define pathname-strip-directory
206  (lambda (pn)
207    (let-values (((dir file ext) (decompose-pathname pn)))
208      (make-pathname #f file ext))))
209
210(define pathname-strip-extension
211  (lambda (pn)
212    (let-values (((dir file ext) (decompose-pathname pn)))
213      (make-pathname dir file))))
214
215(define pathname-replace-directory
216  (lambda (pn dir)
217    (let-values (((_ file ext) (decompose-pathname pn)))
218      (make-pathname dir file ext))))
219
220(define pathname-replace-file
221  (lambda (pn file)
222    (let-values (((dir _ ext) (decompose-pathname pn)))
223      (make-pathname dir file ext))))
224
225(define pathname-replace-extension
226  (lambda (pn ext)
227    (let-values (((dir file _) (decompose-pathname pn)))
228      (make-pathname dir file ext))))
229
230;;; normalize pathname for a particular platform
231
232(define normalize-pathname
233  (let ((bldplt (if (eq? (software-version) 'mingw) 'windows 'unix)))
234    (define (addpart part parts)
235      (cond ((string=? "." part) parts)
236            ((string=? ".." part)
237	     (if (or (null? parts)
238		     (string=? ".." (car parts)))
239		 (cons part parts)
240		 (cdr parts)))
241            (else (cons part parts))))
242    (lambda (path #!optional (platform bldplt))
243      (let ((sep (if (eq? platform 'windows) #\\ #\/)))
244        (define (pds? c)
245          (if (eq? platform 'windows)
246              (memq c '(#\/ #\\))
247              (eq? c #\/)))
248	(##sys#check-string path 'normalize-pathname)
249	(let ((len (string-length path))
250	      (type #f)
251	      (drive #f))
252	  (let loop ((i 0) (prev 0) (parts '()))
253	    (cond ((fx>= i len)
254		   (when (fx> i prev)
255		     (set! parts (addpart (##sys#substring path prev i) parts)))
256		   (if (null? parts)
257		       (let ((r (if (eq? type 'abs) (string sep) ".")))
258			 (if drive (##sys#string-append drive r) r))
259		       (let ((out (open-output-string))
260			     (parts (##sys#fast-reverse parts)))
261			 (display (car parts) out)
262			 (for-each
263			  (lambda (p)
264			    (##sys#write-char-0 sep out)
265			    (display p out))
266			  (cdr parts))
267			 (when (fx= i prev) (##sys#write-char-0 sep out))
268			 (let ((r (get-output-string out)))
269			   (when (eq? type 'abs)
270			     (set! r (##sys#string-append (string sep) r)))
271			   (when drive
272			     (set! r (##sys#string-append drive r)))
273			   r))))
274		  ((pds? (string-ref path i))
275		   (when (not type)
276		     (set! type (if (fx= i prev) 'abs 'rel)))
277		   (if (fx= i prev)
278		       (loop (fx+ i 1) (fx+ i 1) parts)
279		       (loop (fx+ i 1)
280			     (fx+ i 1)
281			     (addpart (##sys#substring path prev i) parts))))
282		  ((and (null? parts)
283			(char=? (string-ref path i) #\:)
284			(eq? platform 'windows))
285		   (set! drive (##sys#substring path 0 (fx+ i 1)))
286		   (loop (fx+ i 1) (fx+ i 1) '()))
287		  (else (loop (fx+ i 1) prev parts)))))))))
288
289;; directory pathname => list of strings
290;; does arg check
291
292(define split-directory
293  (lambda (loc dir keep?)
294    (##sys#check-string dir loc)
295    (string-split dir (if ##sys#windows-platform "/\\" "/") keep?)))
296
297;; Directory string or list only contains path-separators
298;; and/or current-directory (".") names.
299
300(define (directory-null? dir)
301  (let loop ((ls (if (list? dir) dir (split-directory 'directory-null? dir #t))))
302    (or (null? ls)
303        (and (member (car ls) '("" "."))
304             (loop (cdr ls))))))
305
306;; Directory string => {<origin> <root> <directory-list>}
307;; where any maybe #f when missing
308
309(define (decompose-directory dir)
310  (define (strip-origin-prefix org decomp)
311    #;(assert (or (not org) decomp)) ;cannot have an "origin" but no "decomp"
312    (if (not org)
313        decomp
314        (let ((1st (car decomp)))
315          (let ((olen (string-length org)))
316            (if (not (##core#inline "C_u_i_substring_equal_p" org 1st 0 0 olen))
317                ; then origin is not a prefix (really shouldn't happen)
318                decomp
319                ; else is a prefix
320                (let ((rst (cdr decomp))
321                      (elen (string-length 1st)))
322                  (if (fx= olen elen)
323                      ; then origin is a list prefix
324                      rst
325                      ; else origin is a string prefix
326                      (cons (##sys#substring 1st olen elen) rst))))))))
327  (let* ((ls (split-directory 'decompose-directory dir #f))
328         (rt (absolute-pathname-root dir))
329         (org (root-origin rt)))
330    (values org (root-directory rt) (strip-origin-prefix org (and (not (null? ls)) ls))))))