parent
d3da0eb5ca
commit
2bad7228a7
|
@ -1,4 +1,4 @@
|
||||||
IN: io.backend.tests
|
IN: io.backend.tests
|
||||||
USING: tools.test io.backend kernel ;
|
USING: tools.test io.backend kernel ;
|
||||||
|
|
||||||
[ ] [ "a" normalize-pathname drop ] unit-test
|
[ ] [ "a" normalize-path drop ] unit-test
|
||||||
|
|
|
@ -18,9 +18,9 @@ HOOK: io-multiplex io-backend ( ms -- )
|
||||||
|
|
||||||
HOOK: normalize-directory io-backend ( str -- newstr )
|
HOOK: normalize-directory io-backend ( str -- newstr )
|
||||||
|
|
||||||
HOOK: normalize-pathname io-backend ( str -- newstr )
|
HOOK: normalize-path io-backend ( str -- newstr )
|
||||||
|
|
||||||
M: object normalize-directory normalize-pathname ;
|
M: object normalize-directory normalize-path ;
|
||||||
|
|
||||||
: set-io-backend ( io-backend -- )
|
: set-io-backend ( io-backend -- )
|
||||||
io-backend set-global init-io init-stdio
|
io-backend set-global init-io init-stdio
|
||||||
|
|
|
@ -252,7 +252,7 @@ HELP: normalize-directory
|
||||||
{ $values { "str" "a pathname string" } { "newstr" "a new pathname string" } }
|
{ $values { "str" "a pathname string" } { "newstr" "a new pathname string" } }
|
||||||
{ $description "Called by the " { $link directory } " word to prepare a pathname before passing it to the " { $link (directory) } " primitive." } ;
|
{ $description "Called by the " { $link directory } " word to prepare a pathname before passing it to the " { $link (directory) } " primitive." } ;
|
||||||
|
|
||||||
HELP: normalize-pathname
|
HELP: normalize-path
|
||||||
{ $values { "str" "a pathname string" } { "newstr" "a new pathname string" } }
|
{ $values { "str" "a pathname string" } { "newstr" "a new pathname string" } }
|
||||||
{ $description "Called by words such as " { $link <file-reader> } " and " { $link <file-writer> } " to prepare a pathname before passing it to underlying code." } ;
|
{ $description "Called by words such as " { $link <file-reader> } " and " { $link <file-writer> } " to prepare a pathname before passing it to underlying code." } ;
|
||||||
|
|
||||||
|
|
|
@ -13,13 +13,13 @@ HOOK: (file-writer) io-backend ( path -- stream )
|
||||||
HOOK: (file-appender) io-backend ( path -- stream )
|
HOOK: (file-appender) io-backend ( path -- stream )
|
||||||
|
|
||||||
: <file-reader> ( path encoding -- stream )
|
: <file-reader> ( path encoding -- stream )
|
||||||
swap normalize-pathname (file-reader) swap <decoder> ;
|
swap normalize-path (file-reader) swap <decoder> ;
|
||||||
|
|
||||||
: <file-writer> ( path encoding -- stream )
|
: <file-writer> ( path encoding -- stream )
|
||||||
swap normalize-pathname (file-writer) swap <encoder> ;
|
swap normalize-path (file-writer) swap <encoder> ;
|
||||||
|
|
||||||
: <file-appender> ( path encoding -- stream )
|
: <file-appender> ( path encoding -- stream )
|
||||||
swap normalize-pathname (file-appender) swap <encoder> ;
|
swap normalize-path (file-appender) swap <encoder> ;
|
||||||
|
|
||||||
: file-lines ( path encoding -- seq )
|
: file-lines ( path encoding -- seq )
|
||||||
<file-reader> lines ;
|
<file-reader> lines ;
|
||||||
|
@ -171,7 +171,7 @@ SYMBOL: +unknown+
|
||||||
|
|
||||||
! File metadata
|
! File metadata
|
||||||
: exists? ( path -- ? )
|
: exists? ( path -- ? )
|
||||||
normalize-pathname (exists?) ;
|
normalize-path (exists?) ;
|
||||||
|
|
||||||
: directory? ( path -- ? )
|
: directory? ( path -- ? )
|
||||||
file-info file-info-type +directory+ = ;
|
file-info file-info-type +directory+ = ;
|
||||||
|
@ -187,18 +187,33 @@ M: object cwd ( -- path ) "." ;
|
||||||
|
|
||||||
[ cwd current-directory set-global ] "io.files" add-init-hook
|
[ cwd current-directory set-global ] "io.files" add-init-hook
|
||||||
|
|
||||||
|
: resource-path ( path -- newpath )
|
||||||
|
"resource-path" get [ image parent-directory ] unless*
|
||||||
|
prepend-path ;
|
||||||
|
|
||||||
|
: (normalize-path) ( path -- path' )
|
||||||
|
"resource:" ?head [
|
||||||
|
left-trim-separators resource-path
|
||||||
|
(normalize-path)
|
||||||
|
] [
|
||||||
|
current-directory get prepend-path
|
||||||
|
] if ;
|
||||||
|
|
||||||
|
M: object normalize-path ( path -- path' )
|
||||||
|
(normalize-path) ;
|
||||||
|
|
||||||
: with-directory ( path quot -- )
|
: with-directory ( path quot -- )
|
||||||
>r normalize-pathname r>
|
>r (normalize-path) r>
|
||||||
current-directory swap with-variable ; inline
|
current-directory swap with-variable ; inline
|
||||||
|
|
||||||
: set-current-directory ( path -- )
|
: set-current-directory ( path -- )
|
||||||
normalize-pathname current-directory set ;
|
normalize-path current-directory set ;
|
||||||
|
|
||||||
! Creating directories
|
! Creating directories
|
||||||
HOOK: make-directory io-backend ( path -- )
|
HOOK: make-directory io-backend ( path -- )
|
||||||
|
|
||||||
: make-directories ( path -- )
|
: make-directories ( path -- )
|
||||||
normalize-pathname right-trim-separators {
|
normalize-path right-trim-separators {
|
||||||
{ [ dup "." = ] [ ] }
|
{ [ dup "." = ] [ ] }
|
||||||
{ [ dup root-directory? ] [ ] }
|
{ [ dup root-directory? ] [ ] }
|
||||||
{ [ dup empty? ] [ ] }
|
{ [ dup empty? ] [ ] }
|
||||||
|
@ -271,7 +286,7 @@ M: object copy-file
|
||||||
DEFER: copy-tree-into
|
DEFER: copy-tree-into
|
||||||
|
|
||||||
: copy-tree ( from to -- )
|
: copy-tree ( from to -- )
|
||||||
normalize-pathname
|
normalize-path
|
||||||
over link-info type>>
|
over link-info type>>
|
||||||
{
|
{
|
||||||
{ +symbolic-link+ [ copy-link ] }
|
{ +symbolic-link+ [ copy-link ] }
|
||||||
|
@ -290,9 +305,6 @@ DEFER: copy-tree-into
|
||||||
[ copy-tree-into ] curry each ;
|
[ copy-tree-into ] curry each ;
|
||||||
|
|
||||||
! Special paths
|
! Special paths
|
||||||
: resource-path ( path -- newpath )
|
|
||||||
"resource-path" get [ image parent-directory ] unless*
|
|
||||||
prepend-path ;
|
|
||||||
|
|
||||||
: temp-directory ( -- path )
|
: temp-directory ( -- path )
|
||||||
"temp" resource-path dup make-directories ;
|
"temp" resource-path dup make-directories ;
|
||||||
|
@ -300,17 +312,6 @@ DEFER: copy-tree-into
|
||||||
: temp-file ( name -- path )
|
: temp-file ( name -- path )
|
||||||
temp-directory prepend-path ;
|
temp-directory prepend-path ;
|
||||||
|
|
||||||
: (normalize-pathname) ( path -- path' )
|
|
||||||
"resource:" ?head [
|
|
||||||
left-trim-separators resource-path
|
|
||||||
(normalize-pathname)
|
|
||||||
] [
|
|
||||||
current-directory get prepend-path
|
|
||||||
] if ;
|
|
||||||
|
|
||||||
M: object normalize-pathname ( path -- path' )
|
|
||||||
(normalize-pathname) ;
|
|
||||||
|
|
||||||
! Pathname presentations
|
! Pathname presentations
|
||||||
TUPLE: pathname string ;
|
TUPLE: pathname string ;
|
||||||
|
|
||||||
|
|
|
@ -24,7 +24,7 @@ ERROR: cairo-error string ;
|
||||||
} cond ;
|
} cond ;
|
||||||
|
|
||||||
: <png> ( path -- png )
|
: <png> ( path -- png )
|
||||||
normalize-pathname
|
normalize-path
|
||||||
cairo_image_surface_create_from_png
|
cairo_image_surface_create_from_png
|
||||||
dup cairo_surface_status cairo-png-error
|
dup cairo_surface_status cairo-png-error
|
||||||
dup [ cairo_image_surface_get_width check-zero ]
|
dup [ cairo_image_surface_get_width check-zero ]
|
||||||
|
|
|
@ -26,7 +26,7 @@ SYMBOL: edit-hook
|
||||||
require ;
|
require ;
|
||||||
|
|
||||||
: edit-location ( file line -- )
|
: edit-location ( file line -- )
|
||||||
>r (normalize-pathname) "\\\\?\\" ?head drop r>
|
>r (normalize-path) "\\\\?\\" ?head drop r>
|
||||||
edit-hook get [ call ] [ no-edit-hook edit-location ] if* ;
|
edit-hook get [ call ] [ no-edit-hook edit-location ] if* ;
|
||||||
|
|
||||||
: edit ( defspec -- )
|
: edit ( defspec -- )
|
||||||
|
|
|
@ -7,7 +7,7 @@ IN: io.sockets
|
||||||
TUPLE: local path ;
|
TUPLE: local path ;
|
||||||
|
|
||||||
: <local> ( path -- addrspec )
|
: <local> ( path -- addrspec )
|
||||||
normalize-pathname local construct-boa ;
|
normalize-path local construct-boa ;
|
||||||
|
|
||||||
TUPLE: inet4 host port ;
|
TUPLE: inet4 host port ;
|
||||||
|
|
||||||
|
|
|
@ -43,22 +43,22 @@ M: unix-io (file-appender) ( path -- stream )
|
||||||
{ O_WRONLY O_APPEND O_CREAT O_EXCL } flags ; foldable
|
{ O_WRONLY O_APPEND O_CREAT O_EXCL } flags ; foldable
|
||||||
|
|
||||||
M: unix-io touch-file ( path -- )
|
M: unix-io touch-file ( path -- )
|
||||||
normalize-pathname
|
normalize-path
|
||||||
touch-mode file-mode open
|
touch-mode file-mode open
|
||||||
dup 0 < [ err_no EEXIST = [ err_no io-error ] unless ] when
|
dup 0 < [ err_no EEXIST = [ err_no io-error ] unless ] when
|
||||||
close ;
|
close ;
|
||||||
|
|
||||||
M: unix-io move-file ( from to -- )
|
M: unix-io move-file ( from to -- )
|
||||||
[ normalize-pathname ] bi@ rename io-error ;
|
[ normalize-path ] bi@ rename io-error ;
|
||||||
|
|
||||||
M: unix-io delete-file ( path -- )
|
M: unix-io delete-file ( path -- )
|
||||||
normalize-pathname unlink io-error ;
|
normalize-path unlink io-error ;
|
||||||
|
|
||||||
M: unix-io make-directory ( path -- )
|
M: unix-io make-directory ( path -- )
|
||||||
normalize-pathname OCT: 777 mkdir io-error ;
|
normalize-path OCT: 777 mkdir io-error ;
|
||||||
|
|
||||||
M: unix-io delete-directory ( path -- )
|
M: unix-io delete-directory ( path -- )
|
||||||
normalize-pathname rmdir io-error ;
|
normalize-path rmdir io-error ;
|
||||||
|
|
||||||
: (copy-file) ( from to -- )
|
: (copy-file) ( from to -- )
|
||||||
dup parent-directory make-directories
|
dup parent-directory make-directories
|
||||||
|
@ -69,7 +69,7 @@ M: unix-io delete-directory ( path -- )
|
||||||
] with-disposal ;
|
] with-disposal ;
|
||||||
|
|
||||||
M: unix-io copy-file ( from to -- )
|
M: unix-io copy-file ( from to -- )
|
||||||
[ normalize-pathname ] bi@
|
[ normalize-path ] bi@
|
||||||
[ (copy-file) ]
|
[ (copy-file) ]
|
||||||
[ swap file-info file-info-permissions chmod io-error ]
|
[ swap file-info file-info-permissions chmod io-error ]
|
||||||
2bi ;
|
2bi ;
|
||||||
|
@ -96,15 +96,15 @@ M: unix-io copy-file ( from to -- )
|
||||||
\ file-info construct-boa ;
|
\ file-info construct-boa ;
|
||||||
|
|
||||||
M: unix-io file-info ( path -- info )
|
M: unix-io file-info ( path -- info )
|
||||||
normalize-pathname stat* stat>file-info ;
|
normalize-path stat* stat>file-info ;
|
||||||
|
|
||||||
M: unix-io link-info ( path -- info )
|
M: unix-io link-info ( path -- info )
|
||||||
normalize-pathname lstat* stat>file-info ;
|
normalize-path lstat* stat>file-info ;
|
||||||
|
|
||||||
M: unix-io make-link ( path1 path2 -- )
|
M: unix-io make-link ( path1 path2 -- )
|
||||||
normalize-pathname symlink io-error ;
|
normalize-path symlink io-error ;
|
||||||
|
|
||||||
M: unix-io read-link ( path -- path' )
|
M: unix-io read-link ( path -- path' )
|
||||||
normalize-pathname
|
normalize-path
|
||||||
PATH_MAX [ <byte-array> tuck ] [ ] bi readlink
|
PATH_MAX [ <byte-array> tuck ] [ ] bi readlink
|
||||||
dup io-error head-slice >string ;
|
dup io-error head-slice >string ;
|
||||||
|
|
|
@ -37,7 +37,7 @@ USE: unix
|
||||||
2nip reset-fd ;
|
2nip reset-fd ;
|
||||||
|
|
||||||
: redirect-file ( obj mode fd -- )
|
: redirect-file ( obj mode fd -- )
|
||||||
>r >r normalize-pathname r> file-mode
|
>r >r normalize-path r> file-mode
|
||||||
open dup io-error r> redirect-fd ;
|
open dup io-error r> redirect-fd ;
|
||||||
|
|
||||||
: redirect-closed ( obj mode fd -- )
|
: redirect-closed ( obj mode fd -- )
|
||||||
|
|
|
@ -4,7 +4,7 @@ prettyprint sequences strings threads threads.private
|
||||||
windows windows.kernel32 io.windows.ce.backend ;
|
windows windows.kernel32 io.windows.ce.backend ;
|
||||||
IN: windows.ce.files
|
IN: windows.ce.files
|
||||||
|
|
||||||
! M: windows-ce-io normalize-pathname ( string -- string )
|
! M: windows-ce-io normalize-path ( string -- string )
|
||||||
! dup 1 tail* CHAR: \\ = [ "*" append ] [ "\\*" append ] if ;
|
! dup 1 tail* CHAR: \\ = [ "*" append ] [ "\\*" append ] if ;
|
||||||
|
|
||||||
M: windows-ce-io CreateFile-flags ( DWORD -- DWORD )
|
M: windows-ce-io CreateFile-flags ( DWORD -- DWORD )
|
||||||
|
|
|
@ -89,14 +89,14 @@ SYMBOLS: +read-only+ +hidden+ +system+
|
||||||
] if ;
|
] if ;
|
||||||
|
|
||||||
M: windows-nt-io file-info ( path -- info )
|
M: windows-nt-io file-info ( path -- info )
|
||||||
normalize-pathname get-file-information-stat ;
|
normalize-path get-file-information-stat ;
|
||||||
|
|
||||||
M: windows-nt-io link-info ( path -- info )
|
M: windows-nt-io link-info ( path -- info )
|
||||||
file-info ;
|
file-info ;
|
||||||
|
|
||||||
: file-times ( path -- timestamp timestamp timestamp )
|
: file-times ( path -- timestamp timestamp timestamp )
|
||||||
[
|
[
|
||||||
normalize-pathname open-existing dup close-always
|
normalize-path open-existing dup close-always
|
||||||
"FILETIME" <c-object>
|
"FILETIME" <c-object>
|
||||||
"FILETIME" <c-object>
|
"FILETIME" <c-object>
|
||||||
"FILETIME" <c-object>
|
"FILETIME" <c-object>
|
||||||
|
@ -112,7 +112,7 @@ M: windows-nt-io link-info ( path -- info )
|
||||||
#! timestamp order: creation access write
|
#! timestamp order: creation access write
|
||||||
[
|
[
|
||||||
>r >r >r
|
>r >r >r
|
||||||
normalize-pathname open-existing dup close-always
|
normalize-path open-existing dup close-always
|
||||||
r> r> r> (set-file-times)
|
r> r> r> (set-file-times)
|
||||||
] with-destructors ;
|
] with-destructors ;
|
||||||
|
|
||||||
|
@ -127,7 +127,7 @@ M: windows-nt-io link-info ( path -- info )
|
||||||
|
|
||||||
M: windows-nt-io touch-file ( path -- )
|
M: windows-nt-io touch-file ( path -- )
|
||||||
[
|
[
|
||||||
normalize-pathname
|
normalize-path
|
||||||
maybe-create-file over close-always
|
maybe-create-file over close-always
|
||||||
[ drop ] [ f now dup (set-file-times) ] if
|
[ drop ] [ f now dup (set-file-times) ] if
|
||||||
] with-destructors ;
|
] with-destructors ;
|
||||||
|
|
|
@ -28,7 +28,7 @@ TUPLE: CreateProcess-args
|
||||||
"PROCESS_INFORMATION" <c-object> >>lpProcessInformation
|
"PROCESS_INFORMATION" <c-object> >>lpProcessInformation
|
||||||
TRUE >>bInheritHandles
|
TRUE >>bInheritHandles
|
||||||
0 >>dwCreateFlags
|
0 >>dwCreateFlags
|
||||||
current-directory get (normalize-pathname) >>lpCurrentDirectory ;
|
current-directory get (normalize-path) >>lpCurrentDirectory ;
|
||||||
|
|
||||||
: call-CreateProcess ( CreateProcess-args -- )
|
: call-CreateProcess ( CreateProcess-args -- )
|
||||||
{
|
{
|
||||||
|
|
|
@ -29,21 +29,21 @@ IN: io.windows.nt.files.tests
|
||||||
|
|
||||||
[ ] [ "" resource-path cd ] unit-test
|
[ ] [ "" resource-path cd ] unit-test
|
||||||
|
|
||||||
[ "\\foo\\bar" ] [ "/foo/bar" normalize-pathname ":" split1 nip ] unit-test
|
[ "\\foo\\bar" ] [ "/foo/bar" normalize-path ":" split1 nip ] unit-test
|
||||||
|
|
||||||
[ "\\\\?\\C:\\builds\\factor\\log.txt" ] [
|
[ "\\\\?\\C:\\builds\\factor\\log.txt" ] [
|
||||||
"C:\\builds\\factor\\12345\\"
|
"C:\\builds\\factor\\12345\\"
|
||||||
"..\\log.txt" append-path normalize-pathname
|
"..\\log.txt" append-path normalize-path
|
||||||
] unit-test
|
] unit-test
|
||||||
|
|
||||||
[ "\\\\?\\C:\\builds\\" ] [
|
[ "\\\\?\\C:\\builds\\" ] [
|
||||||
"C:\\builds\\factor\\12345\\"
|
"C:\\builds\\factor\\12345\\"
|
||||||
"..\\.." append-path normalize-pathname
|
"..\\.." append-path normalize-path
|
||||||
] unit-test
|
] unit-test
|
||||||
|
|
||||||
[ "\\\\?\\C:\\builds\\" ] [
|
[ "\\\\?\\C:\\builds\\" ] [
|
||||||
"C:\\builds\\factor\\12345\\"
|
"C:\\builds\\factor\\12345\\"
|
||||||
"..\\.." append-path normalize-pathname
|
"..\\.." append-path normalize-path
|
||||||
] unit-test
|
] unit-test
|
||||||
|
|
||||||
[ "c:\\blah" ] [ "c:\\foo\\bar" "\\blah" append-path ] unit-test
|
[ "c:\\blah" ] [ "c:\\foo\\bar" "\\blah" append-path ] unit-test
|
||||||
|
|
|
@ -40,8 +40,8 @@ ERROR: not-absolute-path ;
|
||||||
unicode-prefix prepend
|
unicode-prefix prepend
|
||||||
] unless ;
|
] unless ;
|
||||||
|
|
||||||
M: windows-nt-io normalize-pathname ( string -- string' )
|
M: windows-nt-io normalize-path ( string -- string' )
|
||||||
(normalize-pathname)
|
(normalize-path)
|
||||||
{ { CHAR: / CHAR: \\ } } substitute
|
{ { CHAR: / CHAR: \\ } } substitute
|
||||||
prepend-prefix ;
|
prepend-prefix ;
|
||||||
|
|
||||||
|
|
|
@ -32,7 +32,7 @@ IN: io.windows.nt.launcher
|
||||||
drop 2nip null-pipe ;
|
drop 2nip null-pipe ;
|
||||||
|
|
||||||
:: redirect-file ( default path access-mode create-mode -- handle )
|
:: redirect-file ( default path access-mode create-mode -- handle )
|
||||||
path normalize-pathname
|
path normalize-path
|
||||||
access-mode
|
access-mode
|
||||||
share-mode
|
share-mode
|
||||||
security-attributes-inherit
|
security-attributes-inherit
|
||||||
|
|
|
@ -25,7 +25,7 @@ HOOK: FileArgs-overlapped io-backend ( port -- overlapped/f )
|
||||||
HOOK: add-completion io-backend ( port -- )
|
HOOK: add-completion io-backend ( port -- )
|
||||||
|
|
||||||
M: windows-io normalize-directory ( string -- string )
|
M: windows-io normalize-directory ( string -- string )
|
||||||
normalize-pathname "\\" ?tail drop "\\*" append ;
|
normalize-path "\\" ?tail drop "\\*" append ;
|
||||||
|
|
||||||
: share-mode ( -- fixnum )
|
: share-mode ( -- fixnum )
|
||||||
{
|
{
|
||||||
|
@ -135,21 +135,21 @@ M: windows-io (file-appender) ( path -- stream )
|
||||||
open-append <win32-file> <writer> ;
|
open-append <win32-file> <writer> ;
|
||||||
|
|
||||||
M: windows-io move-file ( from to -- )
|
M: windows-io move-file ( from to -- )
|
||||||
[ normalize-pathname ] bi@ MoveFile win32-error=0/f ;
|
[ normalize-path ] bi@ MoveFile win32-error=0/f ;
|
||||||
|
|
||||||
M: windows-io delete-file ( path -- )
|
M: windows-io delete-file ( path -- )
|
||||||
normalize-pathname DeleteFile win32-error=0/f ;
|
normalize-path DeleteFile win32-error=0/f ;
|
||||||
|
|
||||||
M: windows-io copy-file ( from to -- )
|
M: windows-io copy-file ( from to -- )
|
||||||
dup parent-directory make-directories
|
dup parent-directory make-directories
|
||||||
[ normalize-pathname ] bi@ 0 CopyFile win32-error=0/f ;
|
[ normalize-path ] bi@ 0 CopyFile win32-error=0/f ;
|
||||||
|
|
||||||
M: windows-io make-directory ( path -- )
|
M: windows-io make-directory ( path -- )
|
||||||
normalize-pathname
|
normalize-path
|
||||||
f CreateDirectory win32-error=0/f ;
|
f CreateDirectory win32-error=0/f ;
|
||||||
|
|
||||||
M: windows-io delete-directory ( path -- )
|
M: windows-io delete-directory ( path -- )
|
||||||
normalize-pathname
|
normalize-path
|
||||||
RemoveDirectory win32-error=0/f ;
|
RemoveDirectory win32-error=0/f ;
|
||||||
|
|
||||||
HOOK: WSASocket-flags io-backend ( -- DWORD )
|
HOOK: WSASocket-flags io-backend ( -- DWORD )
|
||||||
|
|
Loading…
Reference in New Issue