Changeset 12284 in project


Ignore:
Timestamp:
10/28/08 07:41:46 (13 years ago)
Author:
Ivan Raikov
Message:

Fixed some incorrect variable references.

File:
1 edited

Legend:

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

    r12283 r12284  
    6565  filepath:split-extension filepath:take-extension filepath:replace-extension
    6666  filepath:drop-extension filepath:add-extension filepath:has-extension?
    67   filepath:split-extensions filepath:drop-extensions filepath:take-extensions
     67  filepath:split-all-extensions filepath:drop-all-extensions filepath:take-all-extensions
    6868
    6969  ;; Drive procedures
    70   filepath:split-drive filepath:join-drive,
    71   filepath:take-drive filepath:has-drive filepath:drop-drive
     70  filepath:split-drive filepath:join-drive
     71  filepath:take-drive filepath:has-drive? filepath:drop-drive
    7272  filepath:is-drive?
    7373
     
    117117          (else #f))))
    118118       
    119 (define (safe-car x) (and (pair? x) (car x)))
    120 
    121119
    122120;; Utility char procedures
     
    124122(define (is-letter? c)  (char-set-contains? char-set:letter c))
    125123
    126 (define char-upcase-map
    127   (zip (char-set->list char-set:lower-case)
    128        (char-set->list char-set:upper-case)))
    129 
    130 (define (char-upcase c) (or (safe-car (alist-ref c char-upcase-map)) c))
    131 
    132 
    133 (define char-downcase-map
    134   (zip (char-set->list char-set:upper-case)
    135        (char-set->list char-set:lower-case)))
    136 
    137 (define (char-downcase c) (or (safe-car (alist-ref c char-downcase-map)) c))
     124;; (define char-upcase-map
     125;;   (zip (char-set->list char-set:lower-case)
     126;;        (char-set->list char-set:upper-case)))
     127
     128;; (define (char-upcase c) (or (safe-car (alist-ref c char-upcase-map)) c))
     129
     130;; (define char-downcase-map
     131;;   (zip (char-set->list char-set:upper-case)
     132;;        (char-set->list char-set:lower-case)))
     133
     134;; (define (char-downcase c) (or (safe-car (alist-ref c char-downcase-map)) c))
    138135
    139136
     
    142139(define is-posix?
    143140  (make-parameter
    144    (case (software-type)
    145      ((unix)  #t)
    146      ((macos) #t)
    147      (else #f)))
    148   boolean?)
     141   (or (equal? (software-type) 'unix)
     142       (equal? (software-type 'macos)))
     143   boolean?))
    149144 
    150145(define is-windows?
    151146  (make-parameter
    152    (case (software-type)
    153      ((windows) #t)
    154      (else #f))
     147   (equal? (software-type) 'windows)
    155148   boolean?))
    156149 
     
    211204
    212205(define (split-extension p)
    213   (let ((pcs (if (string? p) (string->list p) op)))
     206  (let ((pcs (if (string? p) (string->list p) p)))
    214207    (match-let (((a b)  (split-file-name pcs)))
    215208     (match (reverse (scatter is-ext-separator? b))
     
    231224  (let ((ecs (if (string? ext) (string->list ext) ext))
    232225        (pcs (if (string? p) (string->list p) p)))
    233     (if (prefix? extension-separator ecs)
     226    (if (prefix? ext-separator ecs)
    234227        (append p ext)
    235228        (append p (list ext-separator) ext))))
     
    259252
    260253(define (add-slash a xs)
    261   (let ((xcs (if (string? xs) (string->list xs) xs)))
     254  (let ((xcs (if (string? xs) (string->list xs) xs))
     255        (acs (if (string? a) (string->list a) a)))
    262256    (let-values (((c d) (span is-path-separator? xcs)))
    263                 (list (append a c) d))))
     257                (list (append acs c) d))))
    264258
    265259;; http://msdn.microsoft.com/library/default.asp?url=/library/en-us/fileio/fs/naming_a_file.asp
     
    277271                     ((#\U #\N #\C (and s4 (? is-path-separator?)) . _)
    278272                      (match (read-drive-share-name (drop xs 4))
    279                              ((a b)  (list (c$ (cons* s1 s2 #\? s3 (append (take xs 4) a))) (c$  b)))))
     273                             ((a b)  (list (cons* s1 s2 #\? s3 (append (take xs 4) a)) b))))
    280274                     (else
    281275                      (match (read-drive-letter xs)
    282                              ((a b) (list (c$ (cons* s1 s2 #\? s3 a)) (c$ b)))
     276                             ((a b) (list (cons* s1 s2 #\? s3 a) b))
    283277                             (else  #f))))))
    284278           (else #f))))
     
    289283    (match pcs
    290284           (((and x (? is-letter?))  #\: (and y (? is-path-separator?)) . xs)
    291             (list (add-slash (list x #\:)) (cons y xs)))
     285            (list (add-slash (list x #\:) (cons y xs))))
    292286           (((and x (? is-letter?)) #\: . xs) 
    293287            (list (list x #\:) xs))
     
    298292    (match pcs
    299293           (((and s1 (? is-path-separator?)) (and s2 (? is-path-separator?)) . xs)
    300             (match ((a b)  (read-drive-share-name xs))
    301                    (list (cons* s1 s2 a) b)))
     294            (match-let (((a b)  (read-drive-share-name xs)))
     295                       (list (cons* s1 s2 a) b)))
    302296           (else #f))))
    303297
     
    322316        ((is-path-separator? (last acs)) (append acs bcs))
    323317        (else (match acs
    324                      (((and a1 (? is-letter?)) #\:) (append a b))
    325                      (else (append a (list path-separator) b)))))))
     318                     (((and a1 (? is-letter?)) #\:) (append acs bcs))
     319                     (else (append acs (list path-separator) bcs)))))))
    326320
    327321
     
    338332
    339333;;; Split a filename into directory and file. 'combine' is the inverse.
    340 
    341334(define (split-file-name p)
    342335  (let ((pcs (if (string? p) (string->list p) p)))
    343     (match-let* (((c d)  (split-drive x))
     336    (match-let* (((c d)  (split-drive pcs))
    344337                 ((a b)  (break is-path-separator? (reverse d))))
    345338      (list (append c (reverse b)) (reverse a)))))
     
    348341  (drop-file-name (combine p r)))
    349342
    350 (define (drop-file-name p) (first (split-file p)))
    351 
    352 (define (take-file-name p) (second (split-file p)))
    353 
    354 (define (take-base-name p) (drop-extension (take-file p)))
     343(define (drop-file-name p) (first (split-file-name p)))
     344
     345(define (take-file-name p) (second (split-file-name p)))
     346
     347(define (take-base-name p) (drop-extension (take-file-name p)))
    355348
    356349(define (replace-base-name p name)
     
    372365  (let ((pcs (if (string? p) (string->list p) p)))
    373366    (if (and (has-trailing-path-separator? pcs) (not (is-drive? pcs)))
    374         (reverse (drop-while is-path-separator? (reverse pcs))) x)))
     367        (reverse (drop-while is-path-separator? (reverse pcs))) pcs)))
    375368
    376369(define (take-directory p)
     
    398391  (let ((acs (if (string? a) (string->list a) a))
    399392        (bcs (if (string? b) (string->list b) b)))
    400     (cond ((or (has-drive? b) (and (not (null? b)) (is-path-separator? (first b)))) b)
    401           (else (combine-always a b)))))
     393    (cond ((or (has-drive? bcs) (and (not (null? bcs)) (is-path-separator? (first bcs)))) bcs)
     394          (else (combine-always acs bcs)))))
    402395
    403396;; Combine two paths, assuming rhs is NOT absolute.
     
    405398  (let ((acs (if (string? a) (string->list a) a))
    406399        (bcs (if (string? b) (string->list b) b)))
    407     (cond ((null? a) b)
    408           ((null? b) a)
    409           ((is-path-separator? (last a))  (append a b))
    410           ((is-drive? a)  (join-drive a b))
    411           (else (append a (list path-separator) b)))))
     400    (cond ((null? acs) bcs)
     401          ((null? bcs) acs)
     402          ((is-path-separator? (last acs))  (append acs bcs))
     403          ((is-drive? acs)  (join-drive acs bcs))
     404          (else (append acs (list path-separator) bcs)))))
    412405
    413406
     
    422415  (define (f y)
    423416    (if (null? y) y
    424         (let-values* (((a b) (break is-path-separator? y))
     417        (let*-values (((a b) (break is-path-separator? y))
    425418                      ((c d) (break (lambda (x) (not (is-path-separator? x))) b)))
    426419          (append (append a c) (f d)))))
     
    441434    (let ((res (take-while (lambda (x) (not (is-path-separator? x))) x)))
    442435      (if (null? res) x res)))
    443   (let ((pcs (if (string? p) (string->list p) p)))
    444     (if (has-drive? p) (cons (first (path-components)) (map g (tail path-components))
     436  (let* ((pcs (if (string? p) (string->list p) p))
     437         (path-components (split-path pcs)))
     438    (if (has-drive? pcs)
     439        (cons (first (path-components)) (map g (cdr path-components)))
     440        (map g path-components))))
    445441
    446442
     
    488484;;        takeAbs (x:_) | isPathSeparator x = [pathSeparator]
    489485;;        takeAbs x = map (\y -> if isPathSeparator y then pathSeparator else toLower y) $ takeDrive x
    490 
    491 
    492486(define (make-relative root path)
    493487  (define (drop-abs p)
    494488    (match p (((and x (? is-path-separator?)) . xs) xs)
    495489           (else (drop-drive p))))
     490
    496491  (define (take-abs p)
    497492    (match p (((and x (? is-path-separator?)) . xs) (list path-separator))
    498            (else (map (lambda (y) (if (is-path-separator? y) path-separator (char-downcase y))) (take-drive x)))))
     493           (else (map (lambda (y) (if (is-path-separator? y) path-separator (char-downcase y))) (take-drive p)))))
     494
    499495  (define (f x y)
    500496    (if (null? x) (drop-while is-path-separator? y)
     
    502498                    ((y1 y2)  (g y)))
    503499                   (if (path-equal? x1 y1) (f x2 y2) path))))
     500
    504501  (define (g x)
    505     (match-let (((a b)  (break is-path-separator? (drop-while is-path-separator x))))
     502    (match-let (((a b)  (break is-path-separator? (drop-while is-path-separator? x))))
    506503       (list (drop-while is-path-separator? a) (drop-while is-path-separator? b) )))
     504
    507505  (let ((pcs (if (string? path) (string->list path) path))
    508506        (rcs (if (string? root) (string->list root) root)))
     507
    509508    (cond ((path-equal? rcs pcs)  (list #\.))
    510509          ((not (equal? (take-abs rcs) (take-abs pcs)))  pcs)
     
    528527    (lambda (xs)
    529528      (match xs
    530              ((#\. . (and rest (? pair?))) (drop-dots ax rest))
    531              ((x . rest)  (drop-dots (cons x ax) rest))
     529             ((#\. . (and rest (? pair?))) ((drop-dots ax) rest))
     530             ((x . rest)  ((drop-dots (cons x ax)) rest))
    532531             (()          (reverse ax)))))
    533532
     
    537536            (prop-sep (cons a rest)))
    538537           (((and a (? is-path-separator?)) . rest)
    539             (cons path-separator (prop-set rest)))))
     538            (cons path-separator (prop-sep rest)))))
    540539
    541540  (define f (compose join-path (drop-dots (list)) split-directories prop-sep))
    542541
    543542  (match-let (((drv pth)  (split-drive path)))
    544      (append (join-drive (normalize-drive drv) (f pth))
    545              (if (and (not (null? pth)) (is-path-separator (last pth)))
     543     (append (join-drive (normalise-drive drv) (f pth))
     544             (if (and (not (null? pth)) (is-path-separator? (last pth)))
    546545                 (list path-separator) (list)))))
    547546
     
    553552       
    554553
     554
    555555;; information for validity functions on Windows
    556556;; see http://msdn.microsoft.com/library/default.asp?url=/library/en-us/fileio/fs/naming_a_file.asp
     
    568568
    569569
    570 (define (is-bad-elem? x) (member (map char-upcase (drop-extensions x)) bad-elems))
     570(define (is-bad-elem? x)
     571  (member (map char-upcase (drop-all-extensions x)) bad-elems))
    571572
    572573(define (is-valid? p)
     
    599600               (append (h (reverse b)) (reverse a))))
    600601  (define (h x)
    601     (match-let ((( a b) (split-extensions x)))
     602    (match-let ((( a b) (split-all-extensions x)))
    602603               (if (is-bad-elem? a) (add-extension (append a (list #\_)) b) x)))
    603604  (join-path (map g (split-path p))))
     
    658659(define filepath:drop-extension     (compose list->string drop-extension))
    659660(define filepath:add-extension      (compose list->string add-extension))
    660 (define filepath:split-extensions   (compose list->string split-extensions))
    661 (define filepath:drop-extensions    (compose list->string drop-extensions))
    662 (define filepath:take-extensions    (compose list->string take-extensions))
     661(define filepath:split-all-extensions   (compose list->string split-all-extensions))
     662(define filepath:drop-all-extensions    (compose list->string drop-all-extensions))
     663(define filepath:take-all-extensions    (compose list->string take-all-extensions))
    663664(define filepath:has-extension? has-extension?)
    664665
     
    667668(define filepath:join-drive   (compose list->string join-drive))
    668669(define filepath:take-drive   (compose list->string take-drive))
    669 (define filepath:has-drive    (compose list->string has-drive))
    670670(define filepath:drop-drive   (compose list->string drop-drive))
     671(define filepath:has-drive?   has-drive?)
    671672(define filepath:is-drive?    is-drive?)
    672673
Note: See TracChangeset for help on using the changeset viewer.