Merge git://factorcode.org/git/factor

release
Slava Pestov 2007-11-12 01:45:50 -05:00
commit a74bf88d9e
6 changed files with 48 additions and 49 deletions

View File

@ -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 ;

5
extra/io/server/server.factor Normal file → Executable file
View File

@ -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

3
extra/io/unix/files/files.factor Normal file → Executable file
View File

@ -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 ;

View File

@ -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

View File

@ -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

View File

@ -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 )