diff --git a/core/io/files/files.factor b/core/io/files/files.factor index 441dcfbee3..efa9096791 100755 --- a/core/io/files/files.factor +++ b/core/io/files/files.factor @@ -19,17 +19,17 @@ HOOK: make-directory io-backend ( path -- ) HOOK: delete-directory io-backend ( path -- ) +: path-separator? ( ch -- ? ) windows? "/\\" "/" ? member? ; + HOOK: root-directory? io-backend ( path -- ? ) -M: object root-directory? ( path -- ? ) "/" = ; +M: object root-directory? ( path -- ? ) path-separator? ; -! Words for accessing filesystem meta-data. - -: path-separator? ( ch -- ? ) - "/\\" member? ; +: trim-path-separators ( str -- newstr ) + [ path-separator? ] right-trim ; : path+ ( str1 str2 -- str ) - >r [ path-separator? ] right-trim "/" r> + >r trim-path-separators "/" r> [ path-separator? ] left-trim 3append ; : stat ( path -- directory? permissions length modified ) @@ -39,12 +39,15 @@ M: object root-directory? ( path -- ? ) "/" = ; : directory? ( path -- ? ) stat 3drop ; +: special-directory? ( name -- ? ) + { "." ".." } member? ; + : fixup-directory ( path seq -- newseq ) [ dup string? [ tuck path+ directory? 2array ] [ nip ] if ] curry* map - [ first { "." ".." } member? not ] subset ; + [ first special-directory? not ] subset ; : directory ( path -- seq ) normalize-directory dup (directory) fixup-directory ; @@ -62,17 +65,17 @@ TUPLE: no-parent-directory path ; \ no-parent-directory construct-boa throw ; : parent-directory ( path -- parent ) - { - { [ dup root-directory? ] [ ] } - { [ dup "/\\" split ".." over member? "." rot member? or ] - [ no-parent-directory ] } - { [ t ] [ dup last-path-separator - [ 1+ head ] [ 2drop "." ] if ] } - } cond ; + trim-path-separators + dup root-directory? [ ] [ + dup last-path-separator drop [ + 1+ cut + special-directory? + [ no-parent-directory ] when + ] when* + ] if ; : file-name ( path -- string ) - dup last-path-separator - [ 1+ tail ] [ drop ] if ; + dup last-path-separator [ 1+ tail ] [ drop ] if ; : resource-path ( path -- newpath ) \ resource-path get [ image parent-directory ] unless* @@ -82,8 +85,7 @@ TUPLE: no-parent-directory path ; "resource:" ?head [ resource-path ] when ; : make-directories ( path -- ) - normalize-pathname - { + normalize-pathname trim-path-separators { { [ dup "." = ] [ ] } { [ dup root-directory? ] [ ] } { [ dup empty? ] [ ] } @@ -94,19 +96,6 @@ TUPLE: no-parent-directory path ; ] } } cond drop ; -TUPLE: pathname string ; - -C: pathname - -M: pathname <=> [ pathname-string ] compare ; - -: home ( -- dir ) - { - { [ winnt? ] [ "USERPROFILE" os-env ] } - { [ wince? ] [ "" resource-path ] } - { [ unix? ] [ "HOME" os-env ] } - } cond ; - : copy-file ( from to -- ) dup parent-directory make-directories [ @@ -121,3 +110,16 @@ M: pathname <=> [ pathname-string ] compare ; >r dup directory swap r> [ >r >r first r> over path+ r> rot path+ copy-file ] 2curry each ; + +: home ( -- dir ) + { + { [ winnt? ] [ "USERPROFILE" os-env ] } + { [ wince? ] [ "" resource-path ] } + { [ unix? ] [ "HOME" os-env ] } + } cond ; + +TUPLE: pathname string ; + +C: pathname + +M: pathname <=> [ pathname-string ] compare ; diff --git a/extra/io/unix/files/files.factor b/extra/io/unix/files/files.factor old mode 100644 new mode 100755 index 9c0ef54195..f9d642d661 --- a/extra/io/unix/files/files.factor +++ b/extra/io/unix/files/files.factor @@ -4,9 +4,6 @@ USING: io.backend io.nonblocking io.unix.backend io.files io unix kernel math continuations ; IN: io.unix.files -M: unix-io root-directory? ( path -- ? ) - "/" = ; - : open-read ( path -- fd ) O_RDONLY file-mode open dup io-error ; diff --git a/extra/io/windows/nt/backend/backend.factor b/extra/io/windows/nt/backend/backend.factor index 16e01b6103..c3a6bfd78b 100755 --- a/extra/io/windows/nt/backend/backend.factor +++ b/extra/io/windows/nt/backend/backend.factor @@ -8,6 +8,14 @@ IN: io.windows.nt.backend : unicode-prefix ( -- seq ) "\\\\?\\" ; inline +M: windows-nt-io root-directory? ( path -- ? ) + dup length 2 = [ + dup first Letter? + swap second CHAR: : = and + ] [ + drop f + ] if ; + M: windows-nt-io normalize-pathname ( string -- string ) dup string? [ "pathname must be a string" throw ] unless "/" split "\\" join diff --git a/extra/io/windows/windows-tests.factor b/extra/io/windows/nt/nt-tests.factor similarity index 69% rename from extra/io/windows/windows-tests.factor rename to extra/io/windows/nt/nt-tests.factor index 4c090590df..9dfef6796d 100755 --- a/extra/io/windows/windows-tests.factor +++ b/extra/io/windows/nt/nt-tests.factor @@ -5,12 +5,12 @@ IN: temporary [ "c:\\" ] [ "c:\\foo\\" parent-directory ] unit-test [ "c:\\" ] [ "c:\\foo" parent-directory ] unit-test ! { "c:" "c:\\" "c:/" } [ directory ] each -- all do the same thing -[ "c:\\" ] [ "c:\\" parent-directory ] unit-test -[ "Z:\\" ] [ "Z:\\" parent-directory ] unit-test +[ "c:" ] [ "c:\\" parent-directory ] unit-test +[ "Z:" ] [ "Z:\\" parent-directory ] unit-test [ "c:" ] [ "c:" parent-directory ] unit-test [ "Z:" ] [ "Z:" parent-directory ] unit-test -[ t ] [ "c:\\" root-directory? ] unit-test -[ t ] [ "Z:\\" root-directory? ] unit-test +[ t ] [ "c:\\" trim-path-separators root-directory? ] unit-test +[ t ] [ "Z:\\" trim-path-separators root-directory? ] unit-test [ f ] [ "c:\\foo" root-directory? ] unit-test [ f ] [ "." root-directory? ] unit-test [ f ] [ ".." root-directory? ] unit-test diff --git a/extra/io/windows/windows.factor b/extra/io/windows/windows.factor index ff9cd22d23..2bf0570b09 100755 --- a/extra/io/windows/windows.factor +++ b/extra/io/windows/windows.factor @@ -15,15 +15,6 @@ M: windows-io (handle-destructor) ( obj -- ) M: windows-io (socket-destructor) ( obj -- ) destructor-obj closesocket drop ; -M: windows-io root-directory? ( path -- ? ) - [ path-separator? ] right-trim - dup length 2 = [ - dup first Letter? - swap second CHAR: : = and - ] [ - drop f - ] if ; - TUPLE: win32-file handle ptr overlapped ; : ( handle ptr -- obj )