Changeset 12288 in project


Ignore:
Timestamp:
10/29/08 01:03:58 (13 years ago)
Author:
Ivan Raikov
Message:

Some bug fixes and added file with test cases.

Location:
release/3/filepath/trunk
Files:
1 added
2 edited

Legend:

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

    r12284 r12288  
    5454 (export
    5555
     56  filepath:posix filepath:is-windows? filepath:is-posix?
     57
    5658  ;; Separator predicates
    5759  filepath:path-separator filepath:path-separator-set
     
    137139;; Is the operating system environment POSIX or Windows like
    138140
    139 (define is-posix?
     141(define filepath:posix
    140142  (make-parameter
    141143   (or (equal? (software-type) 'unix)
    142        (equal? (software-type 'macos)))
    143    boolean?))
     144       (equal? (software-type 'macos)))))
     145
     146(define (is-posix?) (filepath:posix))
    144147 
    145 (define is-windows?
    146   (make-parameter
    147    (equal? (software-type) 'windows)
    148    boolean?))
     148(define (is-windows?) (not (is-posix?)))
    149149 
    150150 
     
    154154;;
    155155
    156 (define path-separator
    157   (cond (is-posix?     #\/)
    158         (is-windows?   #\\)
     156(define (path-separator)
     157  (cond ((is-posix?)     #\/)
     158        ((is-windows?)   #\\)
    159159        (else (error 'path-separator "unknown system environment"))))
    160160
    161161;; The set of all possible separators.
    162162
    163 (define path-separator-set
    164   (cond (is-posix?    (list->char-set (list #\/)))
    165         (is-windows?  (list->char-set (list #\\ #\/)))
     163(define (path-separator-set)
     164  (cond ((is-posix?)    (list->char-set (list #\/)))
     165        ((is-windows?)  (list->char-set (list #\\ #\/)))
    166166        (else         (error 'path-separator-set "unknown system environment"))))
    167167 
    168168(define (is-path-separator? x)
    169   (char-set-contains? path-separator-set x))
     169  (char-set-contains? (path-separator-set) x))
    170170
    171171;; The character that is used to separate the entries in the $PATH
    172172;; environment variable.
    173173
    174 (define search-path-separator
    175   (cond (is-posix?    #\:)
    176         (is-windows?  #\;)
     174(define (search-path-separator)
     175  (cond ((is-posix?)    #\:)
     176        ((is-windows?)  #\;)
    177177        (else         (error 'search-path-separator "unknown system environment"))))
    178178       
    179179(define (is-search-path-separator? x)
    180   (equal? x search-path-separator))
     180  (equal? x (search-path-separator)))
    181181
    182182;; File extension character
    183183
    184 (define ext-separator #\.)
     184(define (ext-separator) #\.)
    185185 
    186186(define (is-ext-separator? x)
    187   (equal? x ext-separator))
     187  (equal? x (ext-separator)))
    188188
    189189
     
    196196(define (split-search-path s)
    197197  (let ((cs (if (string? s) (string->list s) s)))
    198     (filter-map (lambda (x) (match x (()  (and is-posix? (list #\.))) (else x)))
     198    (filter-map (lambda (x) (match x (()  (and (is-posix?) (list #\.))) (else x)))
    199199                (scatter is-search-path-separator? cs))))
    200200
     
    206206  (let ((pcs (if (string? p) (string->list p) p)))
    207207    (match-let (((a b)  (split-file-name pcs)))
    208      (match (reverse (scatter is-ext-separator? b))
    209             ((c . d) (let ((ext  c)
    210                            (fp   (append a (intersperse (reverse d) ext-separator))))
    211                        (list fp ext)))
    212             (else    (list pcs ""))))))
     208      (let-values (((c d)  (break is-ext-separator? (reverse b))))
     209          (match d
     210                 (()       (list pcs (list)))
     211                 ((y . ys)  (list (append a (reverse ys)) (cons y (reverse c)))))))))
    213212
    214213(define (take-extension p)
     
    244243(define (split-drive p)
    245244  (let ((pcs (if (string? p) (string->list p) p)))
    246     (or (and is-posix? (let-values (((pre rest) (span is-path-separator? pcs)))
    247                                    (list  pre rest)))
    248         (read-drive-letter p)
    249         (read-drive-unc p)
    250         (read-drive-share p)
    251         (list (list) p))))
     245    (or (and (is-posix?)
     246             (let-values (((pre rest) (span is-path-separator? pcs)))
     247                         (and (not (null? pre)) (list pre rest))))
     248        (read-drive-letter pcs)
     249        (read-drive-unc pcs)
     250        (read-drive-share pcs)
     251        (list (list) pcs))))
    252252
    253253(define (add-slash a xs)
     
    298298(define (read-drive-share-name n)
    299299  (let ((ncs (if (string? n) (string->list n) n)))
    300     (match (break is-path-separator? ncs)
    301            ((a b) (add-slash a b)))))
     300    (let-values (((a b) (break is-path-separator? ncs)))
     301                (and (not (null? a)) (add-slash a b)))))
    302302
    303303
     
    311311  (let ((acs (if (string? a) (string->list a) a))
    312312        (bcs (if (string? b) (string->list b) b)))
    313   (cond (is-posix?    (append acs bcs))
     313  (cond ((is-posix?)    (append acs bcs))
    314314        ((null? acs)  bcs)
    315315        ((null? bcs)  acs)
     
    317317        (else (match acs
    318318                     (((and a1 (? is-letter?)) #\:) (append acs bcs))
    319                      (else (append acs (list path-separator) bcs)))))))
     319                     (else (append acs (list (path-separator)) bcs)))))))
    320320
    321321
     
    334334(define (split-file-name p)
    335335  (let ((pcs (if (string? p) (string->list p) p)))
    336     (match-let* (((c d)  (split-drive pcs))
    337                  ((a b)  (break is-path-separator? (reverse d))))
    338       (list (append c (reverse b)) (reverse a)))))
     336    (match-let (((c d)  (split-drive pcs)))
     337      (let-values (((a b)  (break is-path-separator? (reverse d))))
     338                  (list (append c (reverse b)) (reverse a))))))
    339339
    340340(define (replace-file-name p r)
     
    360360  (let ((pcs (if (string? p) (string->list p) p)))
    361361    (if (has-trailing-path-separator? pcs) pcs
    362         (append pcs (list path-separator)))))
     362        (append pcs (list (path-separator))))))
    363363
    364364(define (drop-trailing-path-separator p)
     
    402402          ((is-path-separator? (last acs))  (append acs bcs))
    403403          ((is-drive? acs)  (join-drive acs bcs))
    404           (else (append acs (list path-separator) bcs)))))
     404          (else (append acs (list (path-separator)) bcs)))))
    405405
    406406
     
    459459(define (path-equal? a b)
    460460  (define (f x)
    461     (if is-windows? (drop-trail-slash (map char-downcase (normalise x)))
     461    (if (is-windows?) (drop-trail-slash (map char-downcase (normalise x)))
    462462        (drop-trail-slash (normalise x))))
    463463  (define (drop-trail-slash x)
     
    490490
    491491  (define (take-abs p)
    492     (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)))))
     492    (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)))))
    494494
    495495  (define (f x y)
     
    500500
    501501  (define (g x)
    502     (match-let (((a b)  (break is-path-separator? (drop-while is-path-separator? x))))
     502    (let-values (((a b)  (break is-path-separator? (drop-while is-path-separator? x))))
    503503       (list (drop-while is-path-separator? a) (drop-while is-path-separator? b) )))
    504504
     
    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)))))
    539539
    540540  (define f (compose join-path (drop-dots (list)) split-directories prop-sep))
     
    543543     (append (join-drive (normalise-drive drv) (f pth))
    544544             (if (and (not (null? pth)) (is-path-separator? (last pth)))
    545                  (list path-separator) (list)))))
     545                 (list (path-separator)) (list)))))
    546546
    547547(define (normalise-drive drive)
    548   (define (rep-slash x) (if (is-path-separator? x) path-separator x))
    549   (if is-posix? drive
     548  (define (rep-slash x) (if (is-path-separator? x) (path-separator) x))
     549  (if (is-posix?) drive
    550550      (let ((x2 (map rep-slash drive)))
    551551        (if (read-drive-letter x2) (map char-upcase x2) drive))))
     
    574574  (let ((pcs (if (string? p) (string->list p) p)))
    575575    (and (not (null? pcs))
    576          (or is-posix?
     576         (or (is-posix?)
    577577             (let ((pcs1 (drop-drive pcs)))
    578578               (and (not (any is-bad-char? pcs1))
     
    597597(define (valid-elements p)
    598598  (define (g x)
    599     (match-let (((a b) (span is-path-separator? (reverse x))))
    600                (append (h (reverse b)) (reverse a))))
     599    (let-values (((a b) (span is-path-separator? (reverse x))))
     600                (append (h (reverse b)) (reverse a))))
    601601  (define (h x)
    602602    (match-let ((( a b) (split-all-extensions x)))
     
    607607  (let ((pcs (if (string? p) (string->list p) p)))
    608608    (cond ((null? pcs)  (list #\_))
    609           (is-posix?    pcs)
     609          ((is-posix?)    pcs)
    610610          ((and (>= (length pcs) 2) (every is-path-separator? pcs))
    611611           (append (take pcs 2) (string->list "drive")))
     
    637637;;; Exported interface
    638638
     639(define filepath:is-posix?    is-posix?)
     640(define filepath:is-windows?  is-windows?)
     641
    639642(define filepath:path-separator path-separator)
    640643(define filepath:path-separator-set path-separator-set)
     
    649652;; and convert it to a string
    650653
     654(define (list-wrapper lst) (map list->string lst))
     655
    651656  ;; Path methods (environment $PATH)
    652 (define filepath:split-search-path (compose list->string split-search-path))
    653 (define filepath:get-search-path   (compose list->string get-search-path))
     657(define filepath:split-search-path (compose list-wrapper split-search-path))
     658(define filepath:get-search-path   (compose list-wrapper get-search-path))
    654659
    655660  ;; Extension procedures
    656 (define filepath:split-extension    (compose list->string split-extension))
     661(define filepath:split-extension    (compose list-wrapper split-extension))
    657662(define filepath:take-extension     (compose list->string  take-extension))
    658663(define filepath:replace-extension  (compose list->string replace-extension))
  • release/3/filepath/trunk/filepath.setup

    r12283 r12288  
    66  (make-pathname #f fn ##sys#load-dynamic-extension))   
    77
    8 (compile -O2 -d0 -s
     8(compile -O -d2 -s
    99         ,@(if has-exports? '(-check-imports -emit-exports filepath.exports) '())
    1010         filepath.scm)
Note: See TracChangeset for help on using the changeset viewer.