From 9d5d4ec5c4685fb744ca3766975a7226dc06cfcf Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 5 May 2008 17:31:46 -0500 Subject: [PATCH] Fixes, rename sliding-groups to clumps --- core/io/io.factor | 6 +- core/splitting/splitting.factor | 22 ++++---- extra/builder/util/util.factor | 4 +- extra/http/client/client.factor | 97 +++++++++++++-------------------- extra/io/pipes/pipes.factor | 2 +- 5 files changed, 56 insertions(+), 75 deletions(-) diff --git a/core/io/io.factor b/core/io/io.factor index 9c62c13309..e28fd28fb3 100755 --- a/core/io/io.factor +++ b/core/io/io.factor @@ -60,10 +60,12 @@ SYMBOL: error-stream [ with-output-stream* ] curry with-disposal ; inline : with-streams* ( input output quot -- ) - [ with-input-stream* ] curry with-output-stream* ; inline + [ output-stream set input-stream set ] prepose with-scope ; inline : with-streams ( input output quot -- ) - [ with-input-stream ] curry with-output-stream ; inline + [ [ with-streams* ] 3curry ] + [ [ drop dispose dispose ] 3curry ] 3bi + [ ] cleanup ; inline : tabular-output ( style quot -- ) swap >r { } make r> output-stream get stream-write-table ; inline diff --git a/core/splitting/splitting.factor b/core/splitting/splitting.factor index c224828a43..62c5121e50 100755 --- a/core/splitting/splitting.factor +++ b/core/splitting/splitting.factor @@ -42,29 +42,31 @@ TUPLE: sliced-groups < groups ; M: sliced-groups nth group@ ; -TUPLE: sliding-groups < abstract-groups ; +TUPLE: clumps < abstract-groups ; -: ( seq n -- groups ) - sliding-groups construct-groups ; inline +: ( seq n -- groups ) + clumps construct-groups ; inline -M: sliding-groups length +M: clumps length [ seq>> length ] [ n>> ] bi - 1+ ; -M: sliding-groups set-length +M: clumps set-length [ n>> + 1- ] [ seq>> ] bi set-length ; -M: sliding-groups group@ +M: clumps group@ [ n>> over + ] [ seq>> ] bi ; -TUPLE: sliced-sliding-groups < groups ; +TUPLE: sliced-clumps < groups ; -: ( seq n -- groups ) - sliced-sliding-groups construct-groups ; inline +: ( seq n -- groups ) + sliced-clumps construct-groups ; inline -M: sliced-sliding-groups nth group@ ; +M: sliced-clumps nth group@ ; : group ( seq n -- array ) { } like ; +: clump ( seq n -- array ) { } like ; + : ?head ( seq begin -- newseq ? ) 2dup head? [ length tail t ] [ drop f ] if ; diff --git a/extra/builder/util/util.factor b/extra/builder/util/util.factor index 3b0834b190..c40efaaa04 100644 --- a/extra/builder/util/util.factor +++ b/extra/builder/util/util.factor @@ -16,7 +16,7 @@ IN: builder.util : minutes>ms ( min -- ms ) 60 * 1000 * ; -: file>string ( file -- string ) utf8 [ stdio get contents ] with-file-reader ; +: file>string ( file -- string ) utf8 file-contents ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -107,5 +107,5 @@ USE: prettyprint ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! : git-id ( -- id ) - { "git" "show" } utf8 [ readln ] with-stream + { "git" "show" } utf8 [ readln ] with-input-stream " " split second ; diff --git a/extra/http/client/client.factor b/extra/http/client/client.factor index 7f8241a818..17882277a3 100755 --- a/extra/http/client/client.factor +++ b/extra/http/client/client.factor @@ -27,74 +27,56 @@ DEFER: http-request : store-path ( request path -- request ) "?" split1 >r >>path r> dup [ query>assoc ] when >>query ; -: request-with-url ( url request -- request ) - swap parse-url >r >r store-path r> >>host r> >>port ; - -! This is all pretty complex because it needs to handle -! HTTP redirects, which might be absolute or relative -: absolute-redirect ( url -- request ) - request get request-with-url ; - -: relative-redirect ( path -- request ) - request get swap store-path ; +: request-with-url ( request url -- request ) + parse-url >r >r store-path r> >>host r> >>port ; SYMBOL: redirects : absolute-url? ( url -- ? ) [ "http://" head? ] [ "https://" head? ] bi or ; -: do-redirect ( response -- response stream ) - dup response-code 300 399 between? [ - output-stream get dispose +: do-redirect ( response data -- response data ) + over code>> 300 399 between? [ + drop redirects inc redirects get max-redirects < [ - header>> "location" swap at - dup absolute-url? [ - absolute-redirect - ] [ - relative-redirect - ] if "GET" >>method http-request + request get + swap "location" header dup absolute-url? + [ request-with-url ] [ store-path ] if + "GET" >>method http-request ] [ too-many-redirects ] if - ] [ - output-stream get - ] if ; - -: close-on-error ( stream quot -- ) - '[ , with-stream* ] [ ] pick '[ , dispose ] cleanup ; inline + ] when ; PRIVATE> -: http-request ( request -- response stream ) - dup request [ - dup request-addr latin1 - [ - 1 minutes timeouts - write-request - input-stream get dispose - read-response - do-redirect - ] close-on-error - ] with-variable ; - : read-chunks ( -- ) read-crlf ";" split1 drop hex> dup { f 0 } member? [ drop ] [ read % read-crlf "" assert= read-chunks ] if ; -: do-chunked-encoding ( response stream -- response stream/string ) - over "transfer-encoding" header "chunked" = [ - [ [ read-chunks ] "" make ] with-input-stream - ] when ; +: read-response-body ( response -- response data ) + dup "transfer-encoding" header "chunked" = + [ [ read-chunks ] "" make ] [ input-stream get contents ] if ; + +: http-request ( request -- response data ) + dup request [ + dup request-addr latin1 [ + 1 minutes timeouts + write-request + read-response + read-response-body + ] with-client + do-redirect + ] with-variable ; : ( url -- request ) - request-with-url "GET" >>method ; + + swap request-with-url + "GET" >>method ; -: string-or-contents ( stream/string -- string ) - dup string? [ contents ] unless ; - -: http-get-stream ( url -- response stream/string ) - http-request do-chunked-encoding ; +: http-get* ( url -- response data ) + http-request ; : success? ( code -- ? ) 200 = ; @@ -114,29 +96,24 @@ M: download-failed error. over code>> success? [ nip ] [ download-failed ] if ; : http-get ( url -- string ) - http-get-stream string-or-contents check-response ; + http-get* check-response ; : download-name ( url -- name ) file-name "?" split1 drop "/" ?tail drop ; : download-to ( url file -- ) #! Downloads the contents of a URL to a file. - swap http-get-stream check-response - dup string? [ - latin1 [ write ] with-file-writer - ] [ - [ swap latin1 stream-copy ] with-disposal - ] if ; + >r http-get r> latin1 [ write ] with-file-writer ; : download ( url -- ) dup download-name download-to ; : ( content-type content url -- request ) - request-with-url - "POST" >>method - swap >>post-data - swap >>post-data-type ; + "POST" >>method + swap request-with-url + swap >>post-data + swap >>post-data-type ; -: http-post ( content-type content url -- response string ) - http-request do-chunked-encoding string-or-contents ; +: http-post ( content-type content url -- response data ) + http-request ; diff --git a/extra/io/pipes/pipes.factor b/extra/io/pipes/pipes.factor index 304aca9812..8317f9af36 100644 --- a/extra/io/pipes/pipes.factor +++ b/extra/io/pipes/pipes.factor @@ -32,7 +32,7 @@ HOOK: (pipe) io-backend ( -- pipe ) : ( n -- pipes ) [ (pipe) dup add-always-destructor ] replicate f f pipe boa [ prefix ] [ suffix ] bi - 2 ; + 2 ; : with-pipe-fds ( seq -- results ) [