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