steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Merge branch 'master' of git://factorcode.org/git/factor

db4
Slava Pestov 2008-11-14 04:01:54 -06:00
parent f6010d1672 6f60d897c5
commit e550d052ea
9 changed files with 183 additions and 132 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

17
basis/io/files/listing/listing-docs.factor Normal file
View File

@ -0,0 +1,17 @@
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: help.markup help.syntax io.streams.string strings ;
IN: io.files.listing
HELP: directory.
{ $values
{ "path" "a pathname string" }
}
{ $description "Prints information about all files in a directory to the output stream in a cross-platform way similar to the Unix " { $snippet "ls" } " command." } ;
ARTICLE: "io.files.listing" "Listing files"
"The " { $vocab-link "io.files.listing" } " vocabulary implements directory file listing in a cross-platform way." $nl
"Listing a directory:"
{ $subsection directory. } ;
ABOUT: "io.files.listing"

4
basis/io/files/listing/listing.factor
View File

@ -5,6 +5,8 @@ math.parser sequences system vocabs.loader calendar ;
IN: io.files.listing
<PRIVATE
: ls-time ( timestamp -- string )
[ hour>> ] [ minute>> ] bi
[ number>string 2 CHAR: 0 pad-left ] bi@ ":" swap 3append ;
@ -26,6 +28,8 @@ IN: io.files.listing
HOOK: (directory.) os ( path -- lines )
PRIVATE>
: directory. ( path -- )
[ (directory.) ] with-directory-files [ print ] each ;

7
basis/io/files/listing/unix/unix.factor
View File

@ -2,9 +2,12 @@
! See http://factorcode.org/license.txt for BSD license.
USING: accessors combinators kernel system unicode.case
io.unix.files io.files.listing generalizations strings
arrays sequences io.files math.parser unix.groups unix.users ;
arrays sequences io.files math.parser unix.groups unix.users
io.files.listing.private ;
IN: io.files.listing.unix
<PRIVATE
: unix-execute>string ( str bools -- str' )
swap {
{ { t t } [ >lower ] }
@ -41,3 +44,5 @@ M: unix (directory.) ( path -- lines )
} cleave 4 narray swap suffix " " join
] map
] with-group-cache ] with-user-cache ;
PRIVATE>

6
basis/io/files/listing/windows/windows.factor
View File

@ -2,9 +2,11 @@
! See http://factorcode.org/license.txt for BSD license.
USING: accessors calendar.format combinators io.files
kernel math.parser sequences splitting system io.files.listing
generalizations ;
generalizations io.files.listing.private ;
IN: io.files.listing.windows
<PRIVATE
: directory-or-size ( file-info -- str )
dup directory? [
drop "<DIR>" 20 CHAR: \s pad-right
@ -19,3 +21,5 @@ M: windows (directory.) ( entries -- lines )
[ directory-or-size ]
} cleave 2 narray swap suffix " " join
] map ;
PRIVATE>

162
extra/ftp/client/client.factor
View File

@ -2,8 +2,9 @@
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays classes.singleton combinators
continuations io io.encodings.binary io.encodings.utf8
io.files io.sockets kernel io.streams.duplex math ls
math.parser sequences splitting namespaces strings fry ftp ;
io.files io.sockets kernel io.streams.duplex math
math.parser sequences splitting namespaces strings fry ftp
ftp.client.listing-parser urls ;
IN: ftp.client
: (ftp-response-code) ( str -- n )
@ -24,145 +25,86 @@ IN: ftp.client
[ fourth CHAR: - = ] tri
[ read-response-loop ] when ;
ERROR: ftp-error got expected ;
: ftp-assert ( ftp-response n -- )
2dup [ n>> ] dip = [ 2drop ] [ ftp-error ] if ;
: ftp-command ( string -- ftp-response )
ftp-send read-response ;
: ftp-user ( ftp-client -- ftp-response )
user>> "USER " prepend ftp-command ;
: ftp-user ( url -- ftp-response )
username>> "USER " prepend ftp-command ;
: ftp-password ( ftp-client -- ftp-response )
: ftp-password ( url -- ftp-response )
password>> "PASS " prepend ftp-command ;
: ftp-set-binary ( -- ftp-response )
"TYPE I" ftp-command ;
: ftp-pwd ( -- ftp-response )
"PWD" ftp-command ;
: ftp-list ( -- ftp-response )
"LIST" ftp-command ;
: ftp-quit ( -- ftp-response )
"QUIT" ftp-command ;
: ftp-cwd ( directory -- ftp-response )
"CWD " prepend ftp-command ;
: ftp-retr ( filename -- ftp-response )
"RETR " prepend ftp-command ;
: parse-epsv ( ftp-response -- port )
strings>> first
"|" split 2 tail* first string>number ;
: ftp-set-binary ( -- ftp-response ) "TYPE I" ftp-command ;
TUPLE: remote-file
type permissions links owner group size month day time year
name target ;
: ftp-pwd ( -- ftp-response ) "PWD" ftp-command ;
: <remote-file> ( -- remote-file ) remote-file new ;
: ftp-list ( -- )
"LIST" ftp-command 150 ftp-assert ;
: parse-permissions ( remote-file str -- remote-file )
[ first ch>type >>type ] [ rest >>permissions ] bi ;
: parse-list-11 ( lines -- seq )
[
11 f pad-right
<remote-file> swap {
[ 0 swap nth parse-permissions ]
[ 1 swap nth string>number >>links ]
[ 2 swap nth >>owner ]
[ 3 swap nth >>group ]
[ 4 swap nth string>number >>size ]
[ 5 swap nth >>month ]
[ 6 swap nth >>day ]
[ 7 swap nth >>time ]
[ 8 swap nth >>name ]
[ 10 swap nth >>target ]
} cleave
] map ;
: parse-list-8 ( lines -- seq )
[
<remote-file> swap {
[ 0 swap nth parse-permissions ]
[ 1 swap nth string>number >>links ]
[ 2 swap nth >>owner ]
[ 3 swap nth >>size ]
[ 4 swap nth >>month ]
[ 5 swap nth >>day ]
[ 6 swap nth >>time ]
[ 7 swap nth >>name ]
} cleave
] map ;
: parse-list-3 ( lines -- seq )
[
<remote-file> swap {
[ 0 swap nth parse-permissions ]
[ 1 swap nth string>number >>links ]
[ 2 swap nth >>name ]
} cleave
] map ;
: parse-list ( ftp-response -- ftp-response )
dup strings>>
[ " " split harvest ] map
dup length {
{ 11 [ parse-list-11 ] }
{ 9 [ parse-list-11 ] }
{ 8 [ parse-list-8 ] }
{ 3 [ parse-list-3 ] }
[ drop ]
} case >>parsed ;
: ftp-quit ( -- ftp-response ) "QUIT" ftp-command ;
: ftp-epsv ( -- ftp-response )
"EPSV" ftp-command ;
"EPSV" ftp-command dup 229 ftp-assert ;
ERROR: ftp-error got expected ;
: ftp-assert ( ftp-response n -- )
2dup [ n>> ] dip = [ 2drop ] [ ftp-error ] if ;
: parse-epsv ( ftp-response -- port )
strings>> first "|" split 2 tail* first string>number ;
: ftp-login ( ftp-client -- )
read-response 220 ftp-assert
[ ftp-user 331 ftp-assert ]
[ ftp-password 230 ftp-assert ] bi
ftp-set-binary 200 ftp-assert ;
: open-passive-client ( url protocol -- stream )
[ host>> ftp-epsv parse-epsv <inet> ] dip <client> drop ;
: open-remote-port ( -- port )
ftp-epsv
[ 229 ftp-assert ] [ parse-epsv ] bi ;
: list ( ftp-client -- ftp-response )
host>> open-remote-port <inet> utf8 <client> drop
ftp-list 150 ftp-assert
: list ( url -- ftp-response )
utf8 open-passive-client
ftp-list
lines
<ftp-response> swap >>strings
read-response 226 ftp-assert
parse-list ;
: ftp-get ( filename ftp-client -- ftp-response )
host>> open-remote-port <inet> binary <client> drop
swap
: (ftp-get) ( url path -- )
[ binary open-passive-client ] dip
[ ftp-retr 150 ftp-assert drop ]
[ binary <file-writer> stream-copy ] 2bi
read-response dup 226 ftp-assert ;
read-response 226 ftp-assert ;
: ftp-connect ( ftp-client -- stream )
: ftp-login ( url -- )
read-response 220 ftp-assert
[ ftp-user 331 ftp-assert ]
[ ftp-password 230 ftp-assert ] bi
ftp-set-binary 200 ftp-assert ;
: ftp-connect ( url -- stream )
[ host>> ] [ port>> ] bi <inet> utf8 <client> drop ;
GENERIC: ftp-download ( path obj -- )
: with-ftp-client ( url quot -- )
[ [ ftp-connect ] keep ] dip
'[ _ [ ftp-login ] _ bi ftp-quit drop ] with-stream ; inline
: with-ftp-client ( ftp-client quot -- )
dupd '[
_ [ ftp-login ] [ @ ] bi
ftp-quit drop
] [ ftp-connect ] dip with-stream ; inline
: ensure-login ( url -- url )
dup username>> [
"anonymous" >>username
"ftp-client" >>password
] unless ;
M: ftp-client ftp-download ( path ftp-client -- )
[
[ drop parent-directory ftp-cwd drop ]
[ [ file-name ] dip ftp-get drop ] 2bi
: >ftp-url ( url -- url' ) >url ensure-port ensure-login ;
: ftp-get ( url -- )
>ftp-url [
dup path>>
[ nip parent-directory ftp-cwd drop ]
[ file-name (ftp-get) ] 2bi
] with-ftp-client ;
M: string ftp-download ( path string -- )
<ftp-client> ftp-download ;

1
extra/ftp/client/listing-parser/authors.txt Normal file
View File

@ -0,0 +1 @@
Doug Coleman

89
extra/ftp/client/listing-parser/listing-parser.factor Normal file
View File

@ -0,0 +1,89 @@
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors combinators io.files kernel math.parser
sequences splitting ;
IN: ftp.client.listing-parser
: ch>file-type ( ch -- type )
{
{ CHAR: b [ +block-device+ ] }
{ CHAR: c [ +character-device+ ] }
{ CHAR: d [ +directory+ ] }
{ CHAR: l [ +symbolic-link+ ] }
{ CHAR: s [ +socket+ ] }
{ CHAR: p [ +fifo+ ] }
{ CHAR: - [ +regular-file+ ] }
[ drop +unknown+ ]
} case ;
: file-type>ch ( type -- string )
{
{ +block-device+ [ CHAR: b ] }
{ +character-device+ [ CHAR: c ] }
{ +directory+ [ CHAR: d ] }
{ +symbolic-link+ [ CHAR: l ] }
{ +socket+ [ CHAR: s ] }
{ +fifo+ [ CHAR: p ] }
{ +regular-file+ [ CHAR: - ] }
[ drop CHAR: - ]
} case ;
: parse-permissions ( remote-file str -- remote-file )
[ first ch>file-type >>type ] [ rest >>permissions ] bi ;
TUPLE: remote-file
type permissions links owner group size month day time year
name target ;
: <remote-file> ( -- remote-file ) remote-file new ;
: parse-list-11 ( lines -- seq )
[
11 f pad-right
<remote-file> swap {
[ 0 swap nth parse-permissions ]
[ 1 swap nth string>number >>links ]
[ 2 swap nth >>owner ]
[ 3 swap nth >>group ]
[ 4 swap nth string>number >>size ]
[ 5 swap nth >>month ]
[ 6 swap nth >>day ]
[ 7 swap nth >>time ]
[ 8 swap nth >>name ]
[ 10 swap nth >>target ]
} cleave
] map ;
: parse-list-8 ( lines -- seq )
[
<remote-file> swap {
[ 0 swap nth parse-permissions ]
[ 1 swap nth string>number >>links ]
[ 2 swap nth >>owner ]
[ 3 swap nth >>size ]
[ 4 swap nth >>month ]
[ 5 swap nth >>day ]
[ 6 swap nth >>time ]
[ 7 swap nth >>name ]
} cleave
] map ;
: parse-list-3 ( lines -- seq )
[
<remote-file> swap {
[ 0 swap nth parse-permissions ]
[ 1 swap nth string>number >>links ]
[ 2 swap nth >>name ]
} cleave
] map ;
: parse-list ( ftp-response -- ftp-response )
dup strings>>
[ " " split harvest ] map
dup length {
{ 11 [ parse-list-11 ] }
{ 9 [ parse-list-11 ] }
{ 8 [ parse-list-8 ] }
{ 3 [ parse-list-3 ] }
[ drop ]
} case >>parsed ;

19
extra/ftp/ftp.factor
View File

@ -1,27 +1,12 @@
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays assocs combinators io io.files kernel
math.parser sequences strings ls ;
math.parser sequences strings ;
IN: ftp
SINGLETON: active
SINGLETON: passive
TUPLE: ftp-client host port user password mode state
command-promise ;
: <ftp-client> ( host -- ftp-client )
ftp-client new
swap >>host
21 >>port
"anonymous" >>user
"ftp@my.org" >>password ;
: reset-ftp-client ( ftp-client -- )
f >>user
f >>password
drop ;
TUPLE: ftp-response n strings parsed ;
: <ftp-response> ( -- ftp-response )
@ -34,5 +19,3 @@ TUPLE: ftp-response n strings parsed ;
: ftp-send ( string -- ) write "\r\n" write flush ;
: ftp-ipv4 1 ; inline
: ftp-ipv6 2 ; inline
: directory-list ( -- seq ) "" ls ;

10
extra/ftp/server/server.factor
View File

@ -7,9 +7,15 @@ namespaces make sequences ftp io.unix.launcher.parser
unicode.case splitting assocs classes io.servers.connection
destructors calendar io.timeouts io.streams.duplex threads
continuations math concurrency.promises byte-arrays
io.backend sequences.lib tools.hexdump ;
io.backend sequences.lib tools.hexdump io.files.listing ;
IN: ftp.server
TUPLE: ftp-client url mode state command-promise ;
: <ftp-client> ( url -- ftp-client )
ftp-client new
swap >>url ;
SYMBOL: client
: ftp-server-directory ( -- str )
@ -143,7 +149,7 @@ M: ftp-list service-command ( stream obj -- )
start-directory
[
utf8 encode-output
directory-list [ ftp-send ] each
directory. [ ftp-send ] each
] with-output-stream
finish-directory ;