parent
a80e95ac2d
commit
ae623ff924
|
@ -1,7 +1,7 @@
|
|||
! Copyright (C) 2007, 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: init kernel system namespaces io io.encodings
|
||||
io.encodings.utf8 init assocs ;
|
||||
io.encodings.utf8 init assocs splitting ;
|
||||
IN: io.backend
|
||||
|
||||
SYMBOL: io-backend
|
||||
|
|
|
@ -220,8 +220,6 @@ io.encodings.utf8 ;
|
|||
|
||||
[ "/usr/lib" ] [ "/usr" "lib" append-path ] unit-test
|
||||
[ "/usr/lib" ] [ "/usr/" "lib" append-path ] unit-test
|
||||
[ "/lib" ] [ "/usr/" "/lib" append-path ] unit-test
|
||||
[ "/lib/" ] [ "/usr/" "/lib/" append-path ] unit-test
|
||||
[ "/usr/lib" ] [ "/usr" "./lib" append-path ] unit-test
|
||||
[ "/usr/lib/" ] [ "/usr" "./lib/" append-path ] unit-test
|
||||
[ "/lib" ] [ "/usr" "../lib" append-path ] unit-test
|
||||
|
@ -239,9 +237,6 @@ io.encodings.utf8 ;
|
|||
[ "lib" ] [ "" "lib" append-path ] unit-test
|
||||
[ "lib" ] [ "" "./lib" append-path ] unit-test
|
||||
|
||||
[ "/lib/bux" ] [ "/usr" "/lib/bux" append-path ] unit-test
|
||||
[ "/lib/bux/" ] [ "/usr" "/lib/bux/" append-path ] unit-test
|
||||
|
||||
[ "foo/bar/." parent-directory ] must-fail
|
||||
[ "foo/bar/./" parent-directory ] must-fail
|
||||
[ "foo/bar/baz/.." parent-directory ] must-fail
|
||||
|
@ -263,5 +258,4 @@ io.encodings.utf8 ;
|
|||
[ "bar/foo" ] [ "bar/baz" "./../././././././///foo" append-path ] unit-test
|
||||
|
||||
[ t ] [ "resource:core" absolute-path? ] unit-test
|
||||
[ t ] [ "/foo" absolute-path? ] unit-test
|
||||
[ f ] [ "" absolute-path? ] unit-test
|
||||
|
|
|
@ -102,6 +102,7 @@ PRIVATE>
|
|||
|
||||
: windows-absolute-path? ( path -- path ? )
|
||||
{
|
||||
{ [ dup "\\\\?\\" head? ] [ t ] }
|
||||
{ [ dup length 2 < ] [ f ] }
|
||||
{ [ dup second CHAR: : = ] [ t ] }
|
||||
{ [ t ] [ f ] }
|
||||
|
@ -111,8 +112,8 @@ PRIVATE>
|
|||
{
|
||||
{ [ dup empty? ] [ f ] }
|
||||
{ [ dup "resource:" head? ] [ t ] }
|
||||
{ [ dup first path-separator? ] [ t ] }
|
||||
{ [ windows? ] [ windows-absolute-path? ] }
|
||||
{ [ dup first path-separator? ] [ t ] }
|
||||
{ [ t ] [ f ] }
|
||||
} cond nip ;
|
||||
|
||||
|
@ -126,6 +127,9 @@ PRIVATE>
|
|||
2 tail left-trim-separators
|
||||
>r parent-directory r> append-path
|
||||
] }
|
||||
{ [ over absolute-path? over first path-separator? and ] [
|
||||
>r 2 head r> append
|
||||
] }
|
||||
{ [ t ] [
|
||||
>r right-trim-separators "/" r>
|
||||
left-trim-separators 3append
|
||||
|
@ -296,14 +300,17 @@ DEFER: copy-tree-into
|
|||
: temp-file ( name -- path )
|
||||
temp-directory prepend-path ;
|
||||
|
||||
M: object normalize-pathname ( path -- path' )
|
||||
: (normalize-pathname) ( path -- path' )
|
||||
"resource:" ?head [
|
||||
left-trim-separators resource-path
|
||||
normalize-pathname
|
||||
(normalize-pathname)
|
||||
] [
|
||||
current-directory get prepend-path
|
||||
] if ;
|
||||
|
||||
M: object normalize-pathname ( path -- path' )
|
||||
(normalize-pathname) ;
|
||||
|
||||
! Pathname presentations
|
||||
TUPLE: pathname string ;
|
||||
|
||||
|
|
|
@ -26,7 +26,7 @@ SYMBOL: edit-hook
|
|||
require ;
|
||||
|
||||
: edit-location ( file line -- )
|
||||
>r normalize-pathname "\\\\?\\" ?head drop r>
|
||||
>r (normalize-pathname) "\\\\?\\" ?head drop r>
|
||||
edit-hook get [ call ] [ no-edit-hook edit-location ] if* ;
|
||||
|
||||
: edit ( defspec -- )
|
||||
|
|
|
@ -21,3 +21,9 @@ IN: io.unix.files.tests
|
|||
[ "/lib/" ] [ "/" "../lib/" append-path ] unit-test
|
||||
[ "/lib" ] [ "/" "../../lib" append-path ] unit-test
|
||||
[ "/lib/" ] [ "/" "../../lib/" append-path ] unit-test
|
||||
|
||||
{ [ "/lib" ] [ "/usr/" "/lib" append-path ] }
|
||||
{ [ "/lib/" ] [ "/usr/" "/lib/" append-path ] }
|
||||
{ [ "/lib/bux" ] [ "/usr" "/lib/bux" append-path ] }
|
||||
{ [ "/lib/bux/" ] [ "/usr" "/lib/bux/" append-path ] }
|
||||
{ [ t ] [ "/foo" absolute-path? ] }
|
||||
|
|
|
@ -28,7 +28,7 @@ TUPLE: CreateProcess-args
|
|||
"PROCESS_INFORMATION" <c-object> >>lpProcessInformation
|
||||
TRUE >>bInheritHandles
|
||||
0 >>dwCreateFlags
|
||||
current-directory get normalize-pathname >>lpCurrentDirectory ;
|
||||
current-directory get (normalize-pathname) >>lpCurrentDirectory ;
|
||||
|
||||
: call-CreateProcess ( CreateProcess-args -- )
|
||||
{
|
||||
|
|
|
@ -1,9 +1,9 @@
|
|||
USING: io.files kernel tools.test io.backend
|
||||
io.windows.nt.files splitting ;
|
||||
io.windows.nt.files splitting sequences ;
|
||||
IN: io.windows.nt.files.tests
|
||||
|
||||
[ t ] [ "\\foo" absolute-path? ] unit-test
|
||||
[ t ] [ "\\\\?\\foo" absolute-path? ] unit-test
|
||||
[ f ] [ "\\foo" absolute-path? ] unit-test
|
||||
[ t ] [ "\\\\?\\c:\\foo" absolute-path? ] unit-test
|
||||
[ t ] [ "c:\\foo" absolute-path? ] unit-test
|
||||
[ t ] [ "c:" absolute-path? ] unit-test
|
||||
|
||||
|
@ -45,3 +45,6 @@ IN: io.windows.nt.files.tests
|
|||
"C:\\builds\\factor\\12345\\"
|
||||
"..\\.." append-path normalize-pathname
|
||||
] unit-test
|
||||
|
||||
[ "c:\\blah" ] [ "c:\\foo\\bar" "\\blah" append-path ] unit-test
|
||||
[ t ] [ "" resource-path 2 tail exists? ] unit-test
|
||||
|
|
|
@ -36,28 +36,14 @@ ERROR: not-absolute-path ;
|
|||
} && [ 2 head ] [ not-absolute-path ] if ;
|
||||
|
||||
: prepend-prefix ( string -- string' )
|
||||
unicode-prefix prepend ;
|
||||
dup unicode-prefix head? [
|
||||
unicode-prefix prepend
|
||||
] unless ;
|
||||
|
||||
ERROR: nonstring-pathname ;
|
||||
ERROR: empty-pathname ;
|
||||
|
||||
M: windows-nt-io normalize-pathname ( string -- string )
|
||||
"resource:" ?head [
|
||||
left-trim-separators resource-path
|
||||
normalize-pathname
|
||||
] [
|
||||
dup empty? [ empty-pathname ] when
|
||||
current-directory get prepend-path
|
||||
dup unicode-prefix head? [
|
||||
dup first path-separator? [
|
||||
left-trim-separators
|
||||
current-directory get 2 head
|
||||
prepend-path
|
||||
] when
|
||||
unicode-prefix prepend
|
||||
] unless
|
||||
{ { CHAR: / CHAR: \\ } } substitute ! necessary
|
||||
] if ;
|
||||
M: windows-nt-io normalize-pathname ( string -- string' )
|
||||
(normalize-pathname)
|
||||
{ { CHAR: / CHAR: \\ } } substitute
|
||||
prepend-prefix ;
|
||||
|
||||
M: windows-nt-io CreateFile-flags ( DWORD -- DWORD )
|
||||
FILE_FLAG_OVERLAPPED bitor ;
|
||||
|
|
Loading…
Reference in New Issue