Changeset 15813 in project for chicken/trunk/files.scm


Ignore:
Timestamp:
09/09/09 07:04:31 (11 years ago)
Author:
Kon Lovett
Message:

posixwin use of 'fx= 0' instead of 'zero?'
posixunix use of 'fx= 0' instead of 'zero?', fix for 'create-directory' when absolute pathname & easier to read
files common code for "is this a pds char?", added 'decompose-directory', rmvd redundent compile-time proc cache
files added 'decompose-directory'
data-structures 'random-seed' not here

File:
1 edited

Legend:

Unmodified
Added
Removed
  • chicken/trunk/files.scm

    r15207 r15813  
    4040  (usual-integrations)
    4141  (fixnum)
    42   (hide chop-pds)
     42  (hide chop-pds absolute-pathname-root root-origin root-directory split-directory)
    4343  (disable-interrupts) )
    4444
     
    165165;;; Pathname operations:
    166166
    167 (define absolute-pathname?
    168   (let ([string-match string-match]
    169         [regexp regexp]
    170         [string-append string-append])
    171     (let* ([drv (if ##sys#windows-platform "([A-Za-z]:)?" "")]
    172            [patt (string-append drv "[\\/\\\\].*")]
    173            [rx (regexp patt)] )
    174       (lambda (pn)
    175         (##sys#check-string pn 'absolute-pathname?)
    176         (pair? (string-match rx pn)) ) ) ) )
     167;; Platform specific absolute pathname operations:
     168;; absolute-pathname-root => #f or (<match> [<origin>] <root>)
     169;;
     170;; Not for general consumption
     171
     172(define absolute-pathname-root)
     173(define root-origin)
     174(define root-directory)
     175(let ((string-match string-match))
     176  (if ##sys#windows-platform
     177      (let ((rx (regexp "([A-Za-z]:)?([\\/\\\\]).*")))
     178        (set! absolute-pathname-root (lambda (pn) (string-match rx pn)))
     179        (set! root-origin (lambda (rt) (and rt (cadr rt))))
     180        (set! root-directory (lambda (rt) (and rt (caddr rt)))) )
     181      (let ((rx (regexp "([\\/\\\\]).*")))
     182        (set! absolute-pathname-root (lambda (pn) (string-match rx pn)))
     183        (set! root-origin (lambda (rt) #f))
     184        (set! root-directory (lambda (rt) (and rt (cadr rt)))) ) ) )
     185
     186(define (absolute-pathname? pn)
     187  (##sys#check-string pn 'absolute-pathname?)
     188  (pair? (absolute-pathname-root pn)) )
     189
     190(define-inline (*char-pds? ch) (memq ch '(#\\ #\/)))
    177191
    178192(define (chop-pds str pds)
     
    183197                  (if pds
    184198                      (##core#inline "C_substring_compare" str pds (fx- len pdslen) 0 pdslen)
    185                       (memq (##core#inline "C_subchar" str (fx- len pdslen))
    186                             '(#\/ #\\) ) ) )
     199                      (*char-pds? (##core#inline "C_subchar" str (fx- len pdslen)) ) ) )
    187200             (##sys#substring str 0 (fx- len pdslen))
    188201             str) ) ) )
     
    225238                (if pds
    226239                    (##core#inline "C_substring_compare" pds file 0 0 pdslen)
    227                     (memq (##core#inline "C_subchar" file 0) '(#\\ #\/))))
     240                    (*char-pds? (##core#inline "C_subchar" file 0))))
    228241           (##sys#substring file pdslen (##sys#size file))
    229242           file)
     
    249262
    250263(define decompose-pathname
    251   (let ([string-match string-match]
    252         [regexp regexp]
    253         [string-append string-append])
     264  (let ((string-match string-match))
    254265    (let* ([patt1 "^(.*[\\/\\\\])?([^\\/\\\\]+)(\\.([^\\/\\\\.]+))$"]
    255266           [patt2 "^(.*[\\/\\\\])?((\\.)?[^\\/\\\\]+)$"]
     
    258269           [strip-pds
    259270             (lambda (dir)
    260                 (and dir
    261                      (if (member dir '("/" "\\"))
    262                          dir
    263                          (chop-pds dir #f) ) ) )] )
     271               (and dir
     272                    (if (member dir '("/" "\\"))
     273                        dir
     274                        (chop-pds dir #f) ) ) )] )
    264275      (lambda (pn)
    265276        (##sys#check-string pn 'decompose-pathname)
     
    388399                               (set! r (##sys#string-append drive r))))
    389400                           r))))
    390                   ((memq (string-ref path i) '(#\\ #\/))
     401                  ((*char-pds? (string-ref path i))
    391402                   (when (and (null? parts) (fx= i prev))
    392403                     (set! abspath #t))
     
    404415
    405416
     417;; directory pathname => list of strings
     418;; does arg check
     419
     420(define split-directory
     421  (let ((string-split string-split) )
     422    (lambda (loc dir keep?)
     423      (##sys#check-string dir loc)
     424      (string-split dir "/\\" keep?) ) ) )
     425
    406426;; Directory string or list only contains path-separators
    407 ;; and/or current-directory names.
     427;; and/or current-directory (".") names.
    408428
    409429(define (directory-null? dir)
    410   (let loop ([lst
    411               (if (list? dir)
    412                   dir ; Don't bother to check for strings here
    413                   (begin
    414                     (##sys#check-string dir 'directory-null?)
    415                     (string-split dir "/\\" #t)))])
    416     (or (null? lst)
    417         (and (member (car lst) '("" "."))
    418              (loop (cdr lst)) ) ) ) )
     430  (let loop ((ls (if (list? dir) dir (split-directory 'directory-null? dir #t))))
     431    (or (null? ls)
     432        (and (member (car ls) '("" "."))
     433             (loop (cdr ls)) ) ) ) )
     434
     435;; Directory string => {<origin> <root> <directory-list>}
     436;; where any maybe #f when missing
     437
     438(define (decompose-directory dir)
     439  (define (strip-origin-prefix org decomp)
     440    #;(assert (or (not org) decomp)) ;cannot have an "origin" but no "decomp"
     441    (if (not org)
     442        decomp
     443        (let ((1st (car decomp)))
     444          (let ((olen (##sys#size org)))
     445            (if (not (##core#inline "C_substring_compare" org 1st 0 0 olen))
     446                ; then origin is not a prefix (really shouldn't happen)
     447                decomp
     448                ; else is a prefix
     449                (let ((rst (cdr decomp))
     450                      (elen (##sys#size 1st)) )
     451                  (if (fx= olen (##sys#size elen))
     452                      ; then origin is a list prefix
     453                      rst
     454                      ; else origin is a string prefix
     455                      (cons (##sys#substring 1st olen elen) rst) ) ) ) ) ) ) )
     456  (let* ((ls (split-directory 'decompose-directory dir #f))
     457         (rt (absolute-pathname-root dir))
     458         (org (root-origin rt)) )
     459    (values org (root-directory rt) (strip-origin-prefix org (and (not (null? ls)) ls))) ) )
Note: See TracChangeset for help on using the changeset viewer.