Changeset 15813 in project


Ignore:
Timestamp:
09/09/09 07:04:31 (10 years ago)
Author:
kon
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

Location:
chicken/trunk
Files:
6 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))) ) )
  • chicken/trunk/manual/Unit data-structures

    r15773 r15813  
    284284
    285285
    286 === Random numbers
    287 
    288 
    289 ==== random-seed
    290 
    291  [procedure] (random-seed [SEED])
    292 
    293 Seeds the random number generator with {{SEED}} (an exact integer) or
    294 {{(current-seconds)}} if {{SEED}} is not given.
    295 
    296 
    297286=== Strings
    298287
  • chicken/trunk/manual/Unit files

    r15119 r15813  
    105105{{DIRECTORY}} may be a string or a list of strings.
    106106
     107==== decompose-directory
     108
     109<procedure>(decompose-directory DIRECTORY)</procedure>
     110
     111Returns 3 values: the {{base-origin}}, {{base-directory}}, and the
     112{{directory-elements}} for the {{DIRECTORY}}.
     113
     114; {{base-origin}} : a {{string}} or {{#f}}. The drive, if any.
     115; {{base-directory}} : a {{string}} or {{#f}}. A directory-separator when {{DIRECTORY}} is an {{absolute-pathname}}.
     116; {{directory-elements}} : a {{list-of string}} or {{#f}}. The non-directory-separator bits.
     117
     118{{DIRECTORY}} is a {{string}}.
     119
     120* On WIndows {{(decompose-directory "c:foo/bar")}} => {{"c:" #f ("foo" "bar")}}
     121
    107122
    108123=== Temporary files
  • chicken/trunk/posixunix.scm

    r15758 r15813  
    3232  (usual-integrations)
    3333  (hide ##sys#stat group-member _get-groups _ensure-groups posix-error
    34               ##sys#terminal-check
    35               check-time-vector)
     34        ##sys#terminal-check
     35        check-time-vector)
    3636  (not inline ##sys#interrupt-hook ##sys#user-interrupt-hook)
    3737  (foreign-declare #<<EOF
     
    490490     pathname-file process-fork file-close duplicate-fileno process-execute get-environment-variable
    491491     make-string make-input-port make-output-port ##sys#thread-block-for-i/o create-pipe
    492      process-wait pathname-strip-directory ##sys#expand-home-path directory
     492     process-wait pathname-strip-directory pathname-directory ##sys#expand-home-path directory
    493493     decompose-pathname ##sys#cons-flonum ##sys#decode-seconds ##sys#null-pointer ##sys#pointer->address
    494494     ##sys#substring ##sys#context-switch close-input-pipe close-output-pipe change-directory
     
    860860;;; Directory stuff:
    861861
     862#| ;has a problem w/ absolute-pathname (inf loop) & uses string-null?
    862863(define-inline (create-directory-helper name)
    863     (unless (zero? (##core#inline "C_mkdir" (##sys#make-c-string name)))
     864    (unless (fx= 0 (##core#inline "C_mkdir" (##sys#make-c-string name)))
    864865            (posix-error #:file-error 'create-directory
    865866                         "cannot create directory" name)))
     
    888889
    889890(define create-directory
    890   (let ((string=? string=?))
     891  (let ((string-length string-length))
    891892    (lambda (name #!optional parents?)
    892893      (##sys#check-string name 'create-directory)
    893       (if (not (string=? "" name))
     894      (if (fx< 0 (string-length name))
    894895          (let ((b (create-directory-check name)))
    895896            (if (not b)
     
    901902                ))
    902903          ))))
     904|#
     905
     906(define-inline (*directory? loc name)
     907  (and (fx= 0 (##core#inline "C_stat" (##sys#make-c-string name)))
     908       (foreign-value "C_isdir" bool) ) )
     909
     910(define-inline (*create-directory loc name)
     911  (unless (fx= 0 (##core#inline "C_mkdir" (##sys#make-c-string name)))
     912    (posix-error #:file-error loc "cannot create directory" name)) )
     913
     914(define create-directory
     915  (let ((decompose-pathname decompose-pathname)
     916        (pathname-directory pathname-directory) )
     917    (lambda (name #!optional parents?)
     918      (##sys#check-string name 'create-directory)
     919      (let ((name (##sys#expand-home-path name)))
     920        (unless (or (fx= 0 (##sys#size name)) (*directory? 'create-directory name))
     921          (if parents?
     922              (let loop ((dir (let-values (((dir file ext) (decompose-pathname name)))
     923                                (if file (make-pathname dir file ext) dir))))
     924                (when (and dir (not (*directory? 'create-directory dir)))
     925                  (loop (pathname-directory dir))
     926                  (*create-directory 'create-directory dir)) )
     927              (*create-directory 'create-directory name) ) ) ) ) ) )
    903928
    904929(define change-directory
    905930  (lambda (name)
    906931    (##sys#check-string name 'change-directory)
    907     (unless (zero? (##core#inline "C_chdir" (##sys#make-c-string (##sys#expand-home-path name))))
     932    (unless (fx= 0 (##core#inline "C_chdir" (##sys#make-c-string (##sys#expand-home-path name))))
    908933      (posix-error #:file-error 'change-directory "cannot change current directory" name) ) ) )
    909934
     
    911936  (lambda (name)
    912937    (##sys#check-string name 'delete-directory)
    913     (unless (zero? (##core#inline "C_rmdir" (##sys#make-c-string (##sys#expand-home-path name))))
     938    (unless (fx= 0 (##core#inline "C_rmdir" (##sys#make-c-string (##sys#expand-home-path name))))
    914939      (posix-error #:file-error 'delete-directory "cannot delete directory" name) ) ) )
    915940
     
    945970(define (directory? fname)
    946971  (##sys#check-string fname 'directory?)
    947   (let ((info (##sys#file-info (##sys#expand-home-path fname))))
    948     (and info (fx= 1 (##sys#slot info 4))) ) )
     972  (*directory? 'directory? (##sys#expand-home-path fname)) )
    949973
    950974(define current-directory
     
    23642388        [string-match string-match]
    23652389        [make-pathname make-pathname]
     2390        [pathname-file pathname-file]
    23662391        [directory? directory?] )
    23672392    (lambda (dir pred . action-id-limit)
  • chicken/trunk/posixwin.scm

    r15728 r15813  
    11581158
    11591159(define-inline (create-directory-helper name)
    1160     (unless (zero? (##core#inline "C_mkdir" (##sys#make-c-string name)))
     1160    (unless (fx= 0 (##core#inline "C_mkdir" (##sys#make-c-string name)))
    11611161            (##sys#update-errno)
    11621162            (##sys#signal-hook #:file-error 'create-directory
     
    11941194  (lambda (name)
    11951195    (##sys#check-string name 'change-directory)
    1196     (unless (zero? (##core#inline "C_chdir" (##sys#make-c-string (##sys#expand-home-path name))))
     1196    (unless (fx= 0 (##core#inline "C_chdir" (##sys#make-c-string (##sys#expand-home-path name))))
    11971197      (##sys#update-errno)
    11981198      (##sys#signal-hook #:file-error 'change-directory "cannot change current directory" name) ) ) )
     
    12011201  (lambda (name)
    12021202    (##sys#check-string name 'delete-directory)
    1203     (unless (zero? (##core#inline "C_rmdir" (##sys#make-c-string (##sys#expand-home-path name))))
     1203    (unless (fx= 0 (##core#inline "C_rmdir" (##sys#make-c-string (##sys#expand-home-path name))))
    12041204      (##sys#update-errno)
    12051205      (##sys#signal-hook #:file-error 'delete-directory "cannot delete directory" name) ) ) )
     
    20342034        [string-match string-match]
    20352035        [make-pathname make-pathname]
     2036        [pathname-file pathname-file]
    20362037        [directory? directory?] )
    20372038    (lambda (dir pred . action-id-limit)
  • chicken/trunk/tests/path-tests.scm

    r15119 r15813  
    2929(test "./" (normalize-pathname "" 'unix))
    3030(test ".\\" (normalize-pathname "" 'windows))
     31;this is weird
    3132(test "./" (normalize-pathname "/" 'unix))
     33(test "./" (normalize-pathname "/./" 'unix))
     34(test "./" (normalize-pathname "/." 'unix))
    3235(test "./" (normalize-pathname "./" 'unix))
    3336(test "a" (normalize-pathname "a"))
     
    5659(test "c:~/foo" (normalize-pathname "c:~/foo" 'unix))
    5760(test (string-append home "\\foo") (normalize-pathname "c:~\\foo" 'windows))
     61
     62(assert (directory-null? "/.//"))
     63(assert (directory-null? ""))
     64(assert (not (directory-null? "//foo//")))
     65
     66(test '(#f "/" (".")) (receive (decompose-directory "/.//")))
     67; 'normalize-pathname' can be weird
     68(test '(#f #f (".")) (receive (decompose-directory (normalize-pathname "/.//"))))
     69(test '(#f "/" #f) (receive (decompose-directory "///\\///")))
     70(test '(#f "/" ("foo")) (receive (decompose-directory "//foo//")))
     71(test '(#f "/" ("foo" "bar")) (receive (decompose-directory "//foo//bar")))
     72(test '(#f #f (" " "foo" "bar")) (receive (decompose-directory " //foo//bar")))
     73(test '(#f #f ("foo" "bar")) (receive (decompose-directory "foo//bar/")))
Note: See TracChangeset for help on using the changeset viewer.