diff --git a/extra/ftp/client/authors.txt b/extra/ftp/client/authors.txt new file mode 100644 index 0000000000..7c1b2f2279 --- /dev/null +++ b/extra/ftp/client/authors.txt @@ -0,0 +1 @@ +Doug Coleman diff --git a/extra/ftp/client/client.factor b/extra/ftp/client/client.factor new file mode 100644 index 0000000000..3ae3b27f2f --- /dev/null +++ b/extra/ftp/client/client.factor @@ -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 new + V{ } clone >>strings ; + +: ( 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 ) + + 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 ascii + >>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 ascii + over ftp-list 150 ftp-assert + lines swap >>strings + >r ftp-read 226 ftp-assert r> ; + +: ftp-get ( filename ftp-client -- ftp-response ) + dup [ host>> ] [ start-2nd ] bi binary + rot tuck + [ over ftp-retr 150 ftp-assert ] + [ binary 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-download ; diff --git a/extra/lisp/lisp-tests.factor b/extra/lisp/lisp-tests.factor index ec376569f0..f2c1f59678 100644 --- a/extra/lisp/lisp-tests.factor +++ b/extra/lisp/lisp-tests.factor @@ -4,10 +4,6 @@ USING: lisp lisp.parser tools.test sequences math kernel ; IN: lisp.test -{ [ "aoeu" 2 1 T{ lisp-symbol f "foo" } ] } [ - "(foo 1 2 \"aoeu\")" lisp-string>factor -] unit-test - init-env "+" [ first2 + ] lisp-define diff --git a/extra/lisp/lisp.factor b/extra/lisp/lisp.factor index 7d4b9af02a..79071ce619 100644 --- a/extra/lisp/lisp.factor +++ b/extra/lisp/lisp.factor @@ -38,15 +38,18 @@ DEFER: funcall PRIVATE> : 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" swap [ remove ] [ index ] 2bi ; +: rest-lambda ( body vars -- quot ) + "&rest" swap [ remove ] [ index ] 2bi + [ localize-lambda ] dip + [ , cut swap [ % , ] bake , compose ] bake ; + +: normal-lambda ( body vars -- quot ) + localize-lambda [ , compose ] bake ; : convert-lambda ( s-exp -- quot ) - split-lambda dup "&rest" swap member? [ rest-lambda-vars ] [ dup length ] if - [ localize-lambda ] dip - [ , cut [ dup length firstn ] dip dup empty? [ drop ] when , ] bake ; + split-lambda dup "&rest" swap member? [ rest-lambda ] [ normal-lambda ] if ; : convert-quoted ( s-exp -- quot ) second [ , ] bake ; @@ -64,10 +67,9 @@ PRIVATE> [ drop convert-general-form ] if ; : convert-form ( lisp-form -- quot ) - { { [ dup s-exp? ] [ body>> convert-list-form ] } - [ [ , ] [ ] make ] - } cond ; - + dup s-exp? [ body>> convert-list-form ] + [ [ , ] [ ] make ] if ; + : lisp-string>factor ( str -- quot ) lisp-expr parse-result-ast convert-form ;