Merge git://factorcode.org/git/factor
commit
a74bf88d9e
|
@ -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> 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
|
||||
<file-writer> [
|
||||
|
@ -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> pathname
|
||||
|
||||
M: pathname <=> [ pathname-string ] compare ;
|
||||
|
|
|
@ -80,7 +80,8 @@ SYMBOL: log-stream
|
|||
|
||||
: datagram-loop ( quot datagram -- )
|
||||
[
|
||||
[ receive dup log-datagram >r swap call r> ] keep send
|
||||
[ receive dup log-datagram >r swap call r> ] keep
|
||||
pick [ send ] [ 3drop ] keep
|
||||
] 2keep datagram-loop ; inline
|
||||
|
||||
: spawn-datagrams ( quot addrspec -- )
|
||||
|
@ -91,4 +92,4 @@ SYMBOL: log-stream
|
|||
: with-datagrams ( seq service quot -- )
|
||||
[
|
||||
[ swap spawn-datagrams ] curry concurrency:parallel-each
|
||||
] with-logging ; inline
|
||||
] curry with-logging ; inline
|
||||
|
|
|
@ -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 ;
|
||||
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
|
@ -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 ;
|
||||
|
||||
: <win32-file> ( handle ptr -- obj )
|
||||
|
|
Loading…
Reference in New Issue