Merge branch 'master' of git://factorcode.org/git/jamesnvc
commit
fa5f2b92cd
|
@ -0,0 +1 @@
|
||||||
|
Doug Coleman
|
|
@ -0,0 +1,138 @@
|
||||||
|
! Copyright (C) 2008 Doug Coleman.
|
||||||
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
|
USING: accessors classes.singleton combinators continuations
|
||||||
|
io io.encodings.binary io.encodings.ascii io.files io.sockets
|
||||||
|
kernel math math.parser sequences splitting namespaces strings ;
|
||||||
|
IN: ftp.client
|
||||||
|
|
||||||
|
TUPLE: ftp-client host port stream user password mode ;
|
||||||
|
TUPLE: ftp-response n strings ;
|
||||||
|
|
||||||
|
SINGLETON: active
|
||||||
|
SINGLETON: passive
|
||||||
|
|
||||||
|
: <ftp-response> ( -- ftp-response )
|
||||||
|
ftp-response new
|
||||||
|
V{ } clone >>strings ;
|
||||||
|
|
||||||
|
: <ftp-client> ( host -- ftp-client )
|
||||||
|
ftp-client new
|
||||||
|
swap >>host
|
||||||
|
21 >>port
|
||||||
|
"anonymous" >>user
|
||||||
|
"factor-ftp@factorcode.org" >>password ;
|
||||||
|
|
||||||
|
: add-response-line ( ftp-response string -- ftp-response )
|
||||||
|
over strings>> push ;
|
||||||
|
|
||||||
|
: (ftp-response-code) ( str -- n )
|
||||||
|
3 head string>number ;
|
||||||
|
|
||||||
|
: ftp-response-code ( string -- n/f )
|
||||||
|
dup fourth CHAR: - = [ drop f ] [ (ftp-response-code) ] if ;
|
||||||
|
|
||||||
|
: last-code ( ftp-response -- n )
|
||||||
|
strings>> peek (ftp-response-code) ;
|
||||||
|
|
||||||
|
: read-response-until ( stream ftp-response n -- ftp-response )
|
||||||
|
>r over stream-readln
|
||||||
|
[ add-response-line ] [ ftp-response-code ] bi
|
||||||
|
r> tuck = [ drop nip ] [ read-response-until ] if ;
|
||||||
|
|
||||||
|
: read-response ( stream -- ftp-response )
|
||||||
|
<ftp-response>
|
||||||
|
over stream-readln
|
||||||
|
[ add-response-line ] [ fourth CHAR: - = ] bi
|
||||||
|
[ dup last-code read-response-until ]
|
||||||
|
[ nip ] if dup last-code >>n ;
|
||||||
|
|
||||||
|
: ftp-read ( ftp-client -- ftp-response )
|
||||||
|
stream>> read-response ;
|
||||||
|
|
||||||
|
: ftp-send ( str ftp-client -- )
|
||||||
|
stream>>
|
||||||
|
[ stream-write ]
|
||||||
|
[ "\r\n" swap stream-write ]
|
||||||
|
[ stream-flush ] tri ;
|
||||||
|
|
||||||
|
: ftp-command ( string ftp-client -- ftp-response )
|
||||||
|
[ ftp-send ] [ ftp-read ] bi ;
|
||||||
|
|
||||||
|
: ftp-user ( ftp-client -- ftp-response )
|
||||||
|
[ user>> "USER " prepend ] [ ftp-command ] bi ;
|
||||||
|
|
||||||
|
: ftp-password ( ftp-client -- ftp-response )
|
||||||
|
[ password>> "PASS " prepend ] [ ftp-command ] bi ;
|
||||||
|
|
||||||
|
: ftp-set-binary ( ftp-client -- ftp-response )
|
||||||
|
>r "TYPE I" r> ftp-command ;
|
||||||
|
|
||||||
|
: ftp-pwd ( ftp-client -- ftp-response )
|
||||||
|
>r "PWD" r> ftp-command ;
|
||||||
|
|
||||||
|
: ftp-list ( ftp-client -- ftp-response )
|
||||||
|
>r "LIST" r> ftp-command ;
|
||||||
|
|
||||||
|
: ftp-quit ( ftp-client -- ftp-response )
|
||||||
|
>r "QUIT" r> ftp-command ;
|
||||||
|
|
||||||
|
: ftp-cwd ( directory ftp-client -- ftp-response )
|
||||||
|
>r "CWD " prepend r> ftp-command ;
|
||||||
|
|
||||||
|
: ftp-retr ( filename ftp-client -- ftp-response )
|
||||||
|
>r "RETR " prepend r> ftp-command ;
|
||||||
|
|
||||||
|
: parse-epsv ( ftp-response -- port )
|
||||||
|
strings>> first
|
||||||
|
"|" split 2 tail* first string>number ;
|
||||||
|
|
||||||
|
: ftp-epsv ( ftp-client -- ftp-response )
|
||||||
|
>r "EPSV" r> ftp-command ;
|
||||||
|
|
||||||
|
M: ftp-client dispose ( ftp-client -- )
|
||||||
|
[ ftp-quit drop ] [ stream>> dispose ] bi ;
|
||||||
|
|
||||||
|
ERROR: ftp-error got expected ;
|
||||||
|
: ftp-assert ( ftp-response n -- )
|
||||||
|
2dup >r n>> r> = [ 2drop ] [ ftp-error ] if ;
|
||||||
|
|
||||||
|
: ftp-connect ( ftp-client -- )
|
||||||
|
dup
|
||||||
|
[ host>> ] [ port>> ] bi <inet> ascii <client>
|
||||||
|
>>stream drop ;
|
||||||
|
|
||||||
|
: ftp-login ( ftp-client -- )
|
||||||
|
{
|
||||||
|
[ ftp-connect ]
|
||||||
|
[ ftp-read 220 ftp-assert ]
|
||||||
|
[ ftp-user 331 ftp-assert ]
|
||||||
|
[ ftp-password 230 ftp-assert ]
|
||||||
|
[ ftp-set-binary 200 ftp-assert ]
|
||||||
|
} cleave ;
|
||||||
|
|
||||||
|
: start-2nd ( ftp-client -- port )
|
||||||
|
ftp-epsv [ 229 ftp-assert ] [ parse-epsv ] bi ;
|
||||||
|
|
||||||
|
: list ( ftp-client -- ftp-response )
|
||||||
|
dup [ host>> ] [ start-2nd ] bi <inet> ascii <client>
|
||||||
|
over ftp-list 150 ftp-assert
|
||||||
|
lines <ftp-response> swap >>strings
|
||||||
|
>r ftp-read 226 ftp-assert r> ;
|
||||||
|
|
||||||
|
: ftp-get ( filename ftp-client -- ftp-response )
|
||||||
|
dup [ host>> ] [ start-2nd ] bi <inet> binary <client>
|
||||||
|
rot tuck
|
||||||
|
[ over ftp-retr 150 ftp-assert ]
|
||||||
|
[ binary <file-writer> stream-copy ] 2bi*
|
||||||
|
ftp-read dup 226 ftp-assert ;
|
||||||
|
|
||||||
|
GENERIC: ftp-download ( path obj -- )
|
||||||
|
|
||||||
|
M: ftp-client ftp-download ( path ftp-client -- )
|
||||||
|
dup ftp-login
|
||||||
|
[ >r parent-directory r> ftp-cwd drop ]
|
||||||
|
[ >r file-name r> ftp-get drop ]
|
||||||
|
[ dispose drop ] 2tri ;
|
||||||
|
|
||||||
|
M: string ftp-download ( path string -- )
|
||||||
|
<ftp-client> ftp-download ;
|
|
@ -4,10 +4,6 @@ USING: lisp lisp.parser tools.test sequences math kernel ;
|
||||||
|
|
||||||
IN: lisp.test
|
IN: lisp.test
|
||||||
|
|
||||||
{ [ "aoeu" 2 1 T{ lisp-symbol f "foo" } ] } [
|
|
||||||
"(foo 1 2 \"aoeu\")" lisp-string>factor
|
|
||||||
] unit-test
|
|
||||||
|
|
||||||
init-env
|
init-env
|
||||||
|
|
||||||
"+" [ first2 + ] lisp-define
|
"+" [ first2 + ] lisp-define
|
||||||
|
|
|
@ -38,15 +38,18 @@ DEFER: funcall
|
||||||
PRIVATE>
|
PRIVATE>
|
||||||
|
|
||||||
: split-lambda ( s-exp -- body vars )
|
: split-lambda ( s-exp -- body vars )
|
||||||
first3 -rot nip [ body>> ] bi@ [ name>> ] map ; inline
|
first3 -rot nip [ body>> ] bi@ [ name>> ] map ; inline
|
||||||
|
|
||||||
: rest-lambda-vars ( seq -- n newseq )
|
: rest-lambda ( body vars -- quot )
|
||||||
"&rest" swap [ remove ] [ index ] 2bi ;
|
"&rest" swap [ remove ] [ index ] 2bi
|
||||||
|
[ localize-lambda <lambda> ] dip
|
||||||
|
[ , cut swap [ % , ] bake , compose ] bake ;
|
||||||
|
|
||||||
|
: normal-lambda ( body vars -- quot )
|
||||||
|
localize-lambda <lambda> [ , compose ] bake ;
|
||||||
|
|
||||||
: convert-lambda ( s-exp -- quot )
|
: convert-lambda ( s-exp -- quot )
|
||||||
split-lambda dup "&rest" swap member? [ rest-lambda-vars ] [ dup length ] if
|
split-lambda dup "&rest" swap member? [ rest-lambda ] [ normal-lambda ] if ;
|
||||||
[ localize-lambda <lambda> ] dip
|
|
||||||
[ , cut [ dup length firstn ] dip dup empty? [ drop ] when , ] bake ;
|
|
||||||
|
|
||||||
: convert-quoted ( s-exp -- quot )
|
: convert-quoted ( s-exp -- quot )
|
||||||
second [ , ] bake ;
|
second [ , ] bake ;
|
||||||
|
@ -64,10 +67,9 @@ PRIVATE>
|
||||||
[ drop convert-general-form ] if ;
|
[ drop convert-general-form ] if ;
|
||||||
|
|
||||||
: convert-form ( lisp-form -- quot )
|
: convert-form ( lisp-form -- quot )
|
||||||
{ { [ dup s-exp? ] [ body>> convert-list-form ] }
|
dup s-exp? [ body>> convert-list-form ]
|
||||||
[ [ , ] [ ] make ]
|
[ [ , ] [ ] make ] if ;
|
||||||
} cond ;
|
|
||||||
|
|
||||||
: lisp-string>factor ( str -- quot )
|
: lisp-string>factor ( str -- quot )
|
||||||
lisp-expr parse-result-ast convert-form ;
|
lisp-expr parse-result-ast convert-form ;
|
||||||
|
|
||||||
|
|
Loading…
Reference in New Issue