Changeset 12289 in project for release/3/filepath/trunk/filepath.scm


Ignore:
Timestamp:
10/29/08 02:42:50 (13 years ago)
Author:
Ivan Raikov
Message:

More bug fixes and additional unit tests.

File:
1 edited

Legend:

Unmodified
Added
Removed
  • release/3/filepath/trunk/filepath.scm

    r12288 r12289  
    223223  (let ((ecs (if (string? ext) (string->list ext) ext))
    224224        (pcs (if (string? p) (string->list p) p)))
    225     (if (prefix? ext-separator ecs)
    226         (append p ext)
    227         (append p (list ext-separator) ext))))
    228 
    229 (define (has-extension? p)  (member ext-separator p))
     225    (if (null? ecs) pcs
     226        (if (prefix? (list (ext-separator)) ecs)
     227            (append pcs ecs)
     228            (append pcs (list (ext-separator)) ecs)))))
     229
     230(define (has-extension? p)  (member (ext-separator) p))
    230231
    231232(define (split-all-extensions p)
    232233  (match-let (((a b)  (split-file-name p)))
    233234    (match (scatter is-ext-separator? b)
    234            ((c . d)  (list a (intersperse b ext-separator)))
     235           ((c . d)  (list a (intersperse b (ext-separator))))
    235236           (else     (list p (list))))))
    236237
     
    283284    (match pcs
    284285           (((and x (? is-letter?))  #\: (and y (? is-path-separator?)) . xs)
    285             (list (add-slash (list x #\:) (cons y xs))))
     286            (add-slash (list x #\:) (cons y xs)))
    286287           (((and x (? is-letter?)) #\: . xs) 
    287288            (list (list x #\:) xs))
     
    324325(define (drop-drive p)  (second (split-drive p)))
    325326
    326 (define (has-drive? p)  (not (string-null? (take-drive p))))
    327 
    328 (define (is-drive? p)   (string-null? (drop-drive p)))
     327(define (has-drive? p)  (not (null? (take-drive p))))
     328
     329(define (is-drive? p)   (null? (drop-drive p)))
    329330
    330331
     
    348349
    349350(define (replace-base-name p name)
    350   (match-let (((a b) (split-file-name p)))
    351     (let ((ext (take-extension b)))
    352       (combine-always a (append name (list ext-separator) ext)))))
     351  (let ((ncs (if (string? name) (string->list name) name)))
     352    (match-let (((a b) (split-file-name p)))
     353       (let* ((ext (take-extension b))
     354              (ext (if (prefix? (list (ext-separator)) ext) ext
     355                       (cons (ext-separator) ext))))
     356         (combine-always a (append ncs ext))))))
    353357
    354358;; Is an item either a directory or the last character a path separator?
    355359(define (has-trailing-path-separator? p)
    356360  (let ((pcs (if (string? p) (string->list p) p)))
    357     (if (null? pcs) #f (is-path-separator? (last pcs)))))
     361    (and (not (null? pcs)) (is-path-separator? (last pcs)))))
    358362 
    359363(define (add-trailing-path-separator p)
     
    417421        (let*-values (((a b) (break is-path-separator? y))
    418422                      ((c d) (break (lambda (x) (not (is-path-separator? x))) b)))
    419           (append (append a c) (f d)))))
     423          (cons (append a c) (f d)))))
    420424  (let ((pcs (if (string? p) (string->list p) p)))
    421425    (match-let (((drive path)  (split-drive pcs)))
    422                (append drive (f path)))))
    423            
    424            
     426               (append (if (null? drive) (list) (list drive)) (f path)))))
    425427
    426428;; Just as 'splitPath', but don't add the trailing slashes to each element.
    427429;; splitDirectories "test/file" == ["test","file"]
    428430;; splitDirectories "/test/file" == ["/","test","file"]
    429 ;; Valid x => joinPath (splitDirectories x) `equalFilePath` x
    430431;; splitDirectories "" == []
    431432
     
    437438         (path-components (split-path pcs)))
    438439    (if (has-drive? pcs)
    439         (cons (first (path-components)) (map g (cdr path-components)))
     440        (cons (car path-components) (map g (cdr path-components)))
    440441        (map g path-components))))
    441442
     
    482483;; Posix:   makeRelative "some/path" "some/path/a/b/c" == "a/b/c"
    483484
    484 ;;        takeAbs (x:_) | isPathSeparator x = [pathSeparator]
    485 ;;        takeAbs x = map (\y -> if isPathSeparator y then pathSeparator else toLower y) $ takeDrive x
    486485(define (make-relative root path)
    487486  (define (drop-abs p)
     
    491490  (define (take-abs p)
    492491    (match p (((and x (? is-path-separator?)) . xs) (list (path-separator)))
    493            (else (map (lambda (y) (if (is-path-separator? y) (path-separator) (char-downcase y))) (take-drive p)))))
    494 
    495   (define (f x y)
     492           (else (map (lambda (y) (if (is-path-separator? y) (path-separator) (char-downcase y)))
     493                      (take-drive p)))))
     494
     495  (define (f x y pcs)
    496496    (if (null? x) (drop-while is-path-separator? y)
    497497        (match-let (((x1 x2)  (g x))
    498498                    ((y1 y2)  (g y)))
    499                    (if (path-equal? x1 y1) (f x2 y2) path))))
     499                   (if (path-equal? x1 y1) (f x2 y2 pcs) pcs))))
    500500
    501501  (define (g x)
     
    508508    (cond ((path-equal? rcs pcs)  (list #\.))
    509509          ((not (equal? (take-abs rcs) (take-abs pcs)))  pcs)
    510           (else (f (drop-abs rcs) (drop-abs pcs))))))
     510          (else (f (drop-abs rcs) (drop-abs pcs) pcs)))))
    511511
    512512;; Normalise a file
     
    516516;;  Posix:   normalise "../bob/fred/" == "../bob/fred/"
    517517;;  Posix:   normalise "./bob/fred/" == "bob/fred/"
     518;;  Posix:   normalise "./" == "./"
    518519;;  Windows: normalise "c:\\file/bob\\" == "C:\\file\\bob\\"
    519520;;  Windows: normalise "c:\\" == "C:\\"
     
    521522;;  Windows: normalise "c:/file" == "C:\\file"
    522523;;           normalise "." == "."
    523 ;;  Posix:   normalise "./" == "./"
    524524
    525525(define (normalise path)
     
    527527    (lambda (xs)
    528528      (match xs
    529              ((#\. . (and rest (? pair?))) ((drop-dots ax) rest))
     529             (((#\.) . (and rest (? pair?))) ((drop-dots ax) rest))
    530530             ((x . rest)  ((drop-dots (cons x ax)) rest))
    531531             (()          (reverse ax)))))
     
    536536            (prop-sep (cons a rest)))
    537537           (((and a (? is-path-separator?)) . rest)
    538             (cons (path-separator) (prop-sep rest)))))
     538            (cons (path-separator) (prop-sep rest)))
     539           ((x . rest)
     540            (cons x (prop-sep rest)))
     541           (() xs)))
    539542
    540543  (define f (compose join-path (drop-dots (list)) split-directories prop-sep))
     
    652655;; and convert it to a string
    653656
    654 (define (list-wrapper lst) (map list->string lst))
     657(define (list-wrapper lst)
     658  (begin ; (print "lst = " lst)
     659         (map list->string lst)))
    655660
    656661  ;; Path methods (environment $PATH)
     
    661666(define filepath:split-extension    (compose list-wrapper split-extension))
    662667(define filepath:take-extension     (compose list->string  take-extension))
     668(define filepath:drop-extension     (compose list->string drop-extension))
    663669(define filepath:replace-extension  (compose list->string replace-extension))
    664 (define filepath:drop-extension     (compose list->string drop-extension))
    665670(define filepath:add-extension      (compose list->string add-extension))
    666 (define filepath:split-all-extensions   (compose list->string split-all-extensions))
     671(define filepath:split-all-extensions   (compose list-wrapper split-all-extensions))
    667672(define filepath:drop-all-extensions    (compose list->string drop-all-extensions))
    668673(define filepath:take-all-extensions    (compose list->string take-all-extensions))
     
    670675
    671676;; Drive procedures
    672 (define filepath:split-drive  (compose list->string split-drive))
     677(define filepath:split-drive  (compose list-wrapper split-drive))
    673678(define filepath:join-drive   (compose list->string join-drive))
    674679(define filepath:take-drive   (compose list->string take-drive))
     
    678683
    679684;; Operations on a file path, as a list of directories
    680 (define filepath:split-file-name   (compose list->string split-file-name))
     685(define filepath:split-file-name   (compose list-wrapper split-file-name))
    681686(define filepath:take-file-name    (compose list->string take-file-name))
    682687(define filepath:replace-file-name (compose list->string replace-file-name))
     
    687692(define filepath:replace-directory (compose list->string replace-directory))
    688693(define filepath:combine           (compose list->string combine))
    689 (define filepath:split-path        (compose list->string split-path))
     694(define filepath:split-path        (compose list-wrapper split-path))
    690695(define filepath:join-path         (compose list->string join-path))
    691 (define filepath:split-directories (compose list->string split-directories))
     696(define filepath:split-directories (compose list-wrapper split-directories))
    692697
    693698;; Low-level procedures
Note: See TracChangeset for help on using the changeset viewer.