Fixes, rename sliding-groups to clumps

db4
Slava Pestov 2008-05-05 17:31:46 -05:00
parent ebb0093ab1
commit 9d5d4ec5c4
5 changed files with 56 additions and 75 deletions

View File

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

View File

@ -42,29 +42,31 @@ TUPLE: sliced-groups < groups ;
M: sliced-groups nth group@ <slice> ;
TUPLE: sliding-groups < abstract-groups ;
TUPLE: clumps < abstract-groups ;
: <sliding-groups> ( seq n -- groups )
sliding-groups construct-groups ; inline
: <clumps> ( 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 ;
: <sliced-sliding-groups> ( seq n -- groups )
sliced-sliding-groups construct-groups ; inline
: <sliced-clumps> ( seq n -- groups )
sliced-clumps construct-groups ; inline
M: sliced-sliding-groups nth group@ <slice> ;
M: sliced-clumps nth group@ <slice> ;
: group ( seq n -- array ) <groups> { } like ;
: clump ( seq n -- array ) <clumps> { } like ;
: ?head ( seq begin -- newseq ? )
2dup head? [ length tail t ] [ drop f ] if ;

View File

@ -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 <process-stream> [ readln ] with-stream
{ "git" "show" } utf8 <process-reader> [ readln ] with-input-stream
" " split second ;

View File

@ -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 <client>
[
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 ;
: <get-request> ( url -- request )
<request> request-with-url "GET" >>method ;
<request>
swap request-with-url
"GET" >>method ;
: string-or-contents ( stream/string -- string )
dup string? [ contents ] unless ;
: http-get-stream ( url -- response stream/string )
<get-request> http-request do-chunked-encoding ;
: http-get* ( url -- response data )
<get-request> 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 <file-writer> stream-copy ] with-disposal
] if ;
>r http-get r> latin1 [ write ] with-file-writer ;
: download ( url -- )
dup download-name download-to ;
: <post-request> ( content-type content url -- request )
<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 )
<post-request> http-request do-chunked-encoding string-or-contents ;
: http-post ( content-type content url -- response data )
<post-request> http-request ;

View File

@ -32,7 +32,7 @@ HOOK: (pipe) io-backend ( -- pipe )
: <pipes> ( n -- pipes )
[ (pipe) dup add-always-destructor ] replicate
f f pipe boa [ prefix ] [ suffix ] bi
2 <sliding-groups> ;
2 <clumps> ;
: with-pipe-fds ( seq -- results )
[