├── .github └── workflows │ └── linux.yml ├── .gitignore ├── .gitmodules ├── Build.PL ├── Changes ├── LICENSE ├── META.json ├── README.md ├── TODO ├── author ├── benchmark │ ├── byown.pl │ ├── note.mkdn │ ├── profile.pl │ └── simple.pl └── mk-chunked-response.pl ├── cpanfile ├── example └── get.pl ├── lib ├── Furl.pm └── Furl │ ├── ConnectionCache.pm │ ├── HTTP.pm │ ├── Headers.pm │ ├── Request.pm │ ├── Response.pm │ └── ZlibStream.pm ├── t ├── 00_compile.t ├── 01_version.t ├── 100_low │ ├── 01_simple.t │ ├── 03_redirect.t │ ├── 04_chunked.t │ ├── 05_slowloris.t │ ├── 06_errors.t │ ├── 07_timeout.t │ ├── 08_proxy.t │ ├── 09_body.t │ ├── 11_write_file.t │ ├── 12_write_code.t │ ├── 13_deflate.t │ ├── 15_multiline_header.t │ ├── 16_read_callback.t │ ├── 17_keep_alive.t │ ├── 18_no_proxy.t │ ├── 19_special_headers.t │ ├── 20_header_format_none.t │ ├── 21_keep_alive_timedout.t │ ├── 22_keep_alive.t │ ├── 22_keep_alive_http10.t │ ├── 23_redirect_relative.t │ ├── 24_no_content.t │ ├── 25_signal.t │ ├── 26_headers_only.t │ ├── 27_close_on_eof.t │ ├── 28_idn.t │ ├── 29_completion_slash.t │ ├── 30_user_agent.t │ ├── 31_chunked_unexpected_eof.t │ ├── 32_proxy_auth.t │ ├── 33_basic_auth.t │ ├── 34_keep_request.t │ ├── 35_get_address.t │ ├── 36_inactivity_timeout.t │ ├── 37_bad_content_length.t │ ├── 38_continue.t │ └── 39_httpoxy.t ├── 300_high │ ├── 01_simple.t │ ├── 02_agent.t │ ├── 04_http_request.t │ ├── 05_suppress_dup_host_header.t │ ├── 06_keep_request.t │ ├── 07_cookie.t │ └── 99_error.t ├── 400_components │ ├── 001_response-coding │ │ ├── 01-file.t │ │ ├── t-euc-jp.html │ │ ├── t-iso-2022-jp.html │ │ ├── t-null.html │ │ ├── t-shiftjis.html │ │ └── t-utf-8.html │ ├── 01_headers.t │ ├── 02_response.t │ └── 03_request.t ├── 800_regression │ └── 01_capture_request.t ├── 999_intrenal │ └── parse_url.t ├── HTTPServer.pm ├── Slowloris.pm └── Util.pm └── xt ├── 02_perlcritic.t ├── 04_leaktrace.t ├── 05_valgrind.t ├── 200_online ├── 01_idn.t ├── 02_google.t ├── 03_yahoo_com.t ├── 04_ssl.t ├── 05_connect_error.t ├── 06_net-dns-lite.t └── 07_ssl_shutdown.t └── perlcriticrc /.github/workflows/linux.yml: -------------------------------------------------------------------------------- 1 | name: linux 2 | 3 | on: 4 | - push 5 | - pull_request 6 | 7 | jobs: 8 | perl: 9 | runs-on: ubuntu-latest 10 | strategy: 11 | matrix: 12 | perl-version: 13 | - '5.14' 14 | - '5.34' 15 | - '5.36' 16 | - '5.38' 17 | container: 18 | image: perl:${{ matrix.perl-version }} 19 | steps: 20 | - uses: actions/checkout@v2 21 | - name: Install Dependencies 22 | run: | 23 | curl -sL https://cpanmin.us/ | perl - -n --with-develop --with-recommends --with-suggests --installdeps . 24 | - name: Run Tests 25 | run: prove -lr t 26 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | Makefile 2 | inc/ 3 | .c 4 | ppport.h 5 | .*.sw[pon] 6 | *.bak 7 | *.old 8 | Build 9 | _build/ 10 | xshelper.h 11 | META.yml 12 | MYMETA.yml 13 | .online 14 | blib/ 15 | pm_to_blib 16 | Furl.bs 17 | xs/Furl.o 18 | xs/Furl.c 19 | nytprof* 20 | core 21 | perltidy.ERR 22 | MYMETA.json 23 | /Furl-* 24 | /.build 25 | /_build_params 26 | /Build 27 | !Build/ 28 | !META.json 29 | /Build.bat 30 | !LICENSE 31 | -------------------------------------------------------------------------------- /.gitmodules: -------------------------------------------------------------------------------- 1 | [submodule "picohttpparser"] 2 | path = picohttpparser 3 | url = http://github.com/kazuho/picohttpparser.git 4 | -------------------------------------------------------------------------------- /Build.PL: -------------------------------------------------------------------------------- 1 | # ========================================================================= 2 | # THIS FILE IS AUTOMATICALLY GENERATED BY MINILLA. 3 | # DO NOT EDIT DIRECTLY. 4 | # ========================================================================= 5 | 6 | use 5.008_001; 7 | use strict; 8 | 9 | use Module::Build::Tiny 0.035; 10 | 11 | Build_PL(); 12 | 13 | -------------------------------------------------------------------------------- /META.json: -------------------------------------------------------------------------------- 1 | { 2 | "abstract" : "Lightning-fast URL fetcher", 3 | "author" : [ 4 | "Tokuhiro Matsuno " 5 | ], 6 | "dynamic_config" : 0, 7 | "generated_by" : "Minilla/v3.1.15, CPAN::Meta::Converter version 2.150010", 8 | "license" : [ 9 | "perl_5" 10 | ], 11 | "meta-spec" : { 12 | "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", 13 | "version" : 2 14 | }, 15 | "name" : "Furl", 16 | "no_index" : { 17 | "directory" : [ 18 | "t", 19 | "xt", 20 | "inc", 21 | "share", 22 | "eg", 23 | "examples", 24 | "author", 25 | "builder" 26 | ] 27 | }, 28 | "prereqs" : { 29 | "configure" : { 30 | "requires" : { 31 | "Module::Build::Tiny" : "0.035" 32 | } 33 | }, 34 | "develop" : { 35 | "requires" : { 36 | "Test::CPAN::Meta" : "0", 37 | "Test::MinimumVersion::Fast" : "0.04", 38 | "Test::PAUSE::Permissions" : "0.07", 39 | "Test::Pod" : "1.41", 40 | "Test::Spellunker" : "v0.2.7" 41 | }, 42 | "suggests" : { 43 | "Child" : "0", 44 | "Getopt::Long" : "0", 45 | "HTTP::Lite" : "0", 46 | "IO::Callback" : "0", 47 | "LWP::UserAgent" : "0", 48 | "Net::DNS::Lite" : "0", 49 | "Net::IDN::Encode" : "0", 50 | "Plack::Loader" : "0", 51 | "Starman" : "0", 52 | "Test::LeakTrace" : "0", 53 | "Test::More" : "0", 54 | "Test::Requires" : "0", 55 | "Test::TCP" : "0", 56 | "URI" : "0", 57 | "WWW::Curl::Easy" : "4.14", 58 | "autodie" : "0", 59 | "parent" : "0" 60 | } 61 | }, 62 | "runtime" : { 63 | "recommends" : { 64 | "Compress::Raw::Zlib" : "0", 65 | "HTTP::CookieJar" : "0", 66 | "IO::Socket::SSL" : "0", 67 | "Net::IDN::Encode" : "0" 68 | }, 69 | "requires" : { 70 | "Class::Accessor::Lite" : "0", 71 | "Encode" : "0", 72 | "HTTP::Parser::XS" : "0.11", 73 | "MIME::Base64" : "0", 74 | "Mozilla::CA" : "0", 75 | "Scalar::Util" : "0", 76 | "Socket" : "0", 77 | "Time::HiRes" : "0", 78 | "perl" : "5.008001" 79 | }, 80 | "suggests" : { 81 | "HTTP::Headers" : "0", 82 | "HTTP::Request" : "0", 83 | "HTTP::Response" : "0" 84 | } 85 | }, 86 | "test" : { 87 | "requires" : { 88 | "File::Temp" : "0", 89 | "Test::More" : "0.96", 90 | "Test::Requires" : "0", 91 | "Test::TCP" : "2.11" 92 | }, 93 | "suggests" : { 94 | "HTTP::Body" : "0", 95 | "HTTP::CookieJar" : "0", 96 | "HTTP::Proxy" : "0", 97 | "HTTP::Server::PSGI" : "0", 98 | "Plack" : "0", 99 | "Plack::Loader" : "0", 100 | "Plack::Request" : "0", 101 | "Starlet::Server" : "0", 102 | "Test::Fake::HTTPD" : "0", 103 | "Test::SharedFork" : "0", 104 | "Test::Valgrind" : "0", 105 | "URI" : "0", 106 | "parent" : "0" 107 | } 108 | } 109 | }, 110 | "release_status" : "unstable", 111 | "resources" : { 112 | "bugtracker" : { 113 | "web" : "https://github.com/tokuhirom/Furl/issues" 114 | }, 115 | "homepage" : "https://github.com/tokuhirom/Furl", 116 | "repository" : { 117 | "type" : "git", 118 | "url" : "https://github.com/tokuhirom/Furl.git", 119 | "web" : "https://github.com/tokuhirom/Furl" 120 | } 121 | }, 122 | "version" : "3.14", 123 | "x_contributors" : [ 124 | "Audrey Tang ", 125 | "Breno G. de Oliveira ", 126 | "Debabrata Deka <60925700+ddeka2910@users.noreply.github.com>", 127 | "Fuji Goro ", 128 | "Fuji, Goro ", 129 | "Fuji, Goro ", 130 | "Graham Ollis ", 131 | "HIROSE Masaaki ", 132 | "Jari Salmela ", 133 | "Jiro Nishiguchi ", 134 | "Kazuho Oku ", 135 | "Keiji, Yoshimi ", 136 | "Masahiro Nagano ", 137 | "Neil Bowers ", 138 | "Shohei YOSHIDA ", 139 | "Shoichi Kaji ", 140 | "Toshio Ito ", 141 | "Yasuhiro Matsumoto ", 142 | "bayashi ", 143 | "ikasam_a ", 144 | "itchyny ", 145 | "kimoto ", 146 | "ktat ", 147 | "lestrrat ", 148 | "s-aska ", 149 | "tarao ", 150 | "xaicron " 151 | ], 152 | "x_serialization_backend" : "JSON::PP version 4.07", 153 | "x_static_install" : 1 154 | } 155 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # NAME 2 | 3 | Furl - Lightning-fast URL fetcher 4 | 5 | # SYNOPSIS 6 | 7 | use Furl; 8 | 9 | my $furl = Furl->new( 10 | agent => 'MyGreatUA/2.0', 11 | timeout => 10, 12 | ); 13 | 14 | my $res = $furl->get('http://example.com/'); 15 | die $res->status_line unless $res->is_success; 16 | print $res->content; 17 | 18 | my $res = $furl->post( 19 | 'http://example.com/', # URL 20 | [...], # headers 21 | [ foo => 'bar' ], # form data (HashRef/FileHandle are also okay) 22 | ); 23 | 24 | # Accept-Encoding is supported but optional 25 | $furl = Furl->new( 26 | headers => [ 'Accept-Encoding' => 'gzip' ], 27 | ); 28 | my $body = $furl->get('http://example.com/some/compressed'); 29 | 30 | # DESCRIPTION 31 | 32 | Furl is yet another HTTP client library. LWP is the de facto standard HTTP 33 | client for Perl 5, but it is too slow for some critical jobs, and too complex 34 | for weekend hacking. Furl resolves these issues. Enjoy it! 35 | 36 | # INTERFACE 37 | 38 | ## Class Methods 39 | 40 | ### `Furl->new(%args | \%args) :Furl` 41 | 42 | Creates and returns a new Furl client with _%args_. Dies on errors. 43 | 44 | _%args_ might be: 45 | 46 | - agent :Str = "Furl/$VERSION" 47 | - timeout :Int = 10 48 | - max\_redirects :Int = 7 49 | - capture\_request :Bool = false 50 | 51 | If this parameter is true, [Furl::HTTP](https://metacpan.org/pod/Furl%3A%3AHTTP) captures raw request string. 52 | You can get it by `$res->captured_req_headers` and `$res->captured_req_content`. 53 | 54 | - proxy :Str 55 | - no\_proxy :Str 56 | - headers :ArrayRef 57 | - cookie\_jar :Object 58 | 59 | (EXPERIMENTAL) 60 | 61 | An instance of HTTP::CookieJar or equivalent class that supports the add and cookie\_header methods 62 | 63 | ## Instance Methods 64 | 65 | ### `$furl->request([$request,] %args) :Furl::Response` 66 | 67 | Sends an HTTP request to a specified URL and returns a instance of [Furl::Response](https://metacpan.org/pod/Furl%3A%3AResponse). 68 | 69 | _%args_ might be: 70 | 71 | - scheme :Str = "http" 72 | 73 | Protocol scheme. May be `http` or `https`. 74 | 75 | - host :Str 76 | 77 | Server host to connect. 78 | 79 | You must specify at least `host` or `url`. 80 | 81 | - port :Int = 80 82 | 83 | Server port to connect. The default is 80 on `scheme => 'http'`, 84 | or 443 on `scheme => 'https'`. 85 | 86 | - path\_query :Str = "/" 87 | 88 | Path and query to request. 89 | 90 | - url :Str 91 | 92 | URL to request. 93 | 94 | You can use `url` instead of `scheme`, `host`, `port` and `path_query`. 95 | 96 | - headers :ArrayRef 97 | 98 | HTTP request headers. e.g. `headers => [ 'Accept-Encoding' => 'gzip' ]`. 99 | 100 | - content : Str | ArrayRef\[Str\] | HashRef\[Str\] | FileHandle 101 | 102 | Content to request. 103 | 104 | If the number of arguments is an odd number, this method assumes that the 105 | first argument is an instance of `HTTP::Request`. Remaining arguments 106 | can be any of the previously describe values (but currently there's no 107 | way to really utilize them, so don't use it) 108 | 109 | my $req = HTTP::Request->new(...); 110 | my $res = $furl->request($req); 111 | 112 | You can also specify an object other than HTTP::Request (e.g. Furl::Request), 113 | but the object must implement the following methods: 114 | 115 | - uri 116 | - method 117 | - content 118 | - headers 119 | 120 | These must return the same type of values as their counterparts in 121 | `HTTP::Request`. 122 | 123 | You must encode all the queries or this method will die, saying 124 | `Wide character in ...`. 125 | 126 | ### `$furl->get($url :Str, $headers :ArrayRef[Str] )` 127 | 128 | This is an easy-to-use alias to `request()`, sending the `GET` method. 129 | 130 | ### `$furl->head($url :Str, $headers :ArrayRef[Str] )` 131 | 132 | This is an easy-to-use alias to `request()`, sending the `HEAD` method. 133 | 134 | ### `$furl->post($url :Str, $headers :ArrayRef[Str], $content :Any)` 135 | 136 | This is an easy-to-use alias to `request()`, sending the `POST` method. 137 | 138 | ### `$furl->put($url :Str, $headers :ArrayRef[Str], $content :Any)` 139 | 140 | This is an easy-to-use alias to `request()`, sending the `PUT` method. 141 | 142 | ### `$furl->delete($url :Str, $headers :ArrayRef[Str] )` 143 | 144 | This is an easy-to-use alias to `request()`, sending the `DELETE` method. 145 | 146 | ### `$furl->env_proxy()` 147 | 148 | Loads proxy settings from `$ENV{HTTP_PROXY}` and `$ENV{NO_PROXY}`. 149 | 150 | # TIPS 151 | 152 | - [IO::Socket::SSL](https://metacpan.org/pod/IO%3A%3ASocket%3A%3ASSL) preloading 153 | 154 | Furl interprets the `timeout` argument as the maximum time the module is permitted to spend before returning an error. 155 | 156 | The module also lazy-loads [IO::Socket::SSL](https://metacpan.org/pod/IO%3A%3ASocket%3A%3ASSL) when an HTTPS request is being issued for the first time. Loading the module usually takes ~0.1 seconds. 157 | 158 | The time spent for loading the SSL module may become an issue in case you want to impose a very small timeout value for connection establishment. In such case, users are advised to preload the SSL module explicitly. 159 | 160 | # FAQ 161 | 162 | - Does Furl depends on XS modules? 163 | 164 | No. Although some optional features require XS modules, basic features are 165 | available without XS modules. 166 | 167 | Note that Furl requires HTTP::Parser::XS, which seems an XS module 168 | but includes a pure Perl backend, HTTP::Parser::XS::PP. 169 | 170 | - I need more speed. 171 | 172 | See [Furl::HTTP](https://metacpan.org/pod/Furl%3A%3AHTTP), which provides the low level interface of [Furl](https://metacpan.org/pod/Furl). 173 | It is faster than `Furl.pm` since [Furl::HTTP](https://metacpan.org/pod/Furl%3A%3AHTTP) does not create response objects. 174 | 175 | - How do you use cookie\_jar? 176 | 177 | Furl does not directly support the cookie\_jar option available in LWP. You can use [HTTP::Cookies](https://metacpan.org/pod/HTTP%3A%3ACookies), [HTTP::Request](https://metacpan.org/pod/HTTP%3A%3ARequest), [HTTP::Response](https://metacpan.org/pod/HTTP%3A%3AResponse) like following. 178 | 179 | my $f = Furl->new(); 180 | my $cookies = HTTP::Cookies->new(); 181 | my $req = HTTP::Request->new(...); 182 | $cookies->add_cookie_header($req); 183 | my $res = $f->request($req)->as_http_response; 184 | $res->request($req); 185 | $cookies->extract_cookies($res); 186 | # and use $res. 187 | 188 | - How do you limit the response content length? 189 | 190 | You can limit the content length by callback function. 191 | 192 | my $f = Furl->new(); 193 | my $content = ''; 194 | my $limit = 1_000_000; 195 | my %special_headers = ('content-length' => undef); 196 | my $res = $f->request( 197 | method => 'GET', 198 | url => $url, 199 | special_headers => \%special_headers, 200 | write_code => sub { 201 | my ( $status, $msg, $headers, $buf ) = @_; 202 | if (($special_headers{'content-length'}||0) > $limit || length($content) > $limit) { 203 | die "over limit: $limit"; 204 | } 205 | $content .= $buf; 206 | } 207 | ); 208 | 209 | - How do you display the progress bar? 210 | 211 | my $bar = Term::ProgressBar->new({count => 1024, ETA => 'linear'}); 212 | $bar->minor(0); 213 | $bar->max_update_rate(1); 214 | 215 | my $f = Furl->new(); 216 | my $content = ''; 217 | my %special_headers = ('content-length' => undef);; 218 | my $did_set_target = 0; 219 | my $received_size = 0; 220 | my $next_update = 0; 221 | $f->request( 222 | method => 'GET', 223 | url => $url, 224 | special_headers => \%special_headers, 225 | write_code => sub { 226 | my ( $status, $msg, $headers, $buf ) = @_; 227 | unless ($did_set_target) { 228 | if ( my $cl = $special_headers{'content-length'} ) { 229 | $bar->target($cl); 230 | $did_set_target++; 231 | } 232 | else { 233 | $bar->target( $received_size + 2 * length($buf) ); 234 | } 235 | } 236 | $received_size += length($buf); 237 | $content .= $buf; 238 | $next_update = $bar->update($received_size) 239 | if $received_size >= $next_update; 240 | } 241 | ); 242 | 243 | - HTTPS requests claims warnings! 244 | 245 | When you make https requests, IO::Socket::SSL may complain about it like: 246 | 247 | ******************************************************************* 248 | Using the default of SSL_verify_mode of SSL_VERIFY_NONE for client 249 | is depreciated! Please set SSL_verify_mode to SSL_VERIFY_PEER 250 | together with SSL_ca_file|SSL_ca_path for verification. 251 | If you really don't want to verify the certificate and keep the 252 | connection open to Man-In-The-Middle attacks please set 253 | SSL_verify_mode explicitly to SSL_VERIFY_NONE in your application. 254 | ******************************************************************* 255 | 256 | You should set `SSL_verify_mode` explicitly with Furl's `ssl_opts`. 257 | 258 | use IO::Socket::SSL; 259 | 260 | my $ua = Furl->new( 261 | ssl_opts => { 262 | SSL_verify_mode => SSL_VERIFY_PEER(), 263 | }, 264 | ); 265 | 266 | See [IO::Socket::SSL](https://metacpan.org/pod/IO%3A%3ASocket%3A%3ASSL) for details. 267 | 268 | # AUTHOR 269 | 270 | Tokuhiro Matsuno 271 | 272 | Fuji, Goro (gfx) 273 | 274 | # THANKS TO 275 | 276 | Kazuho Oku 277 | 278 | mala 279 | 280 | mattn 281 | 282 | lestrrat 283 | 284 | walf443 285 | 286 | lestrrat 287 | 288 | audreyt 289 | 290 | # SEE ALSO 291 | 292 | [LWP](https://metacpan.org/pod/LWP) 293 | 294 | [IO::Socket::SSL](https://metacpan.org/pod/IO%3A%3ASocket%3A%3ASSL) 295 | 296 | [Furl::HTTP](https://metacpan.org/pod/Furl%3A%3AHTTP) 297 | 298 | [Furl::Response](https://metacpan.org/pod/Furl%3A%3AResponse) 299 | 300 | # LICENSE 301 | 302 | Copyright (C) Tokuhiro Matsuno. 303 | 304 | This library is free software; you can redistribute it and/or modify 305 | it under the same terms as Perl itself. 306 | -------------------------------------------------------------------------------- /TODO: -------------------------------------------------------------------------------- 1 | - max_redirects 2 | - redirect support 3 | - win32 support 4 | - ssl support 5 | - 多言語ドメイン support 6 | -------------------------------------------------------------------------------- /author/benchmark/byown.pl: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | use autodie; 4 | use Benchmark ':all'; 5 | use Starman; 6 | use LWP::UserAgent; 7 | use WWW::Curl::Easy 4.14; 8 | use Furl::HTTP; 9 | use Child; 10 | use Test::TCP qw/empty_port/; 11 | use Plack::Loader; 12 | use Config; 13 | use HTTP::Lite; 14 | 15 | printf "Perl/%vd on %s\n", $^V, $Config{archname}; 16 | printf "Furl/$Furl::VERSION, LWP/$LWP::VERSION, WWW::Curl/$WWW::Curl::VERSION, HTTP::Lite/$HTTP::Lite::VERSION, libcurl[@{[ WWW::Curl::Easy::version() ]}]\n"; 17 | 18 | my $port = empty_port(); 19 | 20 | my $ua = LWP::UserAgent->new(parse_head => 0, keep_alive => 1); 21 | my $curl = WWW::Curl::Easy->new(); 22 | my $furl = Furl::HTTP->new(parse_header => 0); 23 | my $url = "http://127.0.0.1:$port/foo/bar"; 24 | 25 | my $child = Child->new( 26 | sub { 27 | Plack::Loader->load( 'Starman', port => $port ) 28 | ->run( 29 | sub { [ 200, ['Content-Length' => length('Hi')], ['Hi'] ] } ); 30 | } 31 | ); 32 | my $proc = $child->start(); 33 | 34 | cmpthese( 35 | -1, { 36 | lwp => sub { 37 | my $res = $ua->get($url); 38 | }, 39 | curl => sub { 40 | my @headers; 41 | $curl->setopt(CURLOPT_URL, $url); 42 | $curl->setopt(CURLOPT_HTTPGET, 1); 43 | $curl->setopt(CURLOPT_HEADER, 0); 44 | $curl->setopt(CURLOPT_NOPROGRESS, 1); 45 | $curl->setopt(CURLOPT_HEADERFUNCTION, sub { 46 | push @headers, @_; 47 | length($_[0]); 48 | }); 49 | my $content = ''; 50 | $curl->setopt(CURLOPT_WRITEDATA, \$content); 51 | $curl->perform(); 52 | my $code = $curl->getinfo(CURLINFO_HTTP_CODE); 53 | }, 54 | furl => sub { 55 | $furl->request(method => 'GET', url => $url); 56 | }, 57 | }, 58 | ); 59 | 60 | $proc->kill('TERM'); 61 | 62 | -------------------------------------------------------------------------------- /author/benchmark/note.mkdn: -------------------------------------------------------------------------------- 1 | ### On tokuhirom's SC440 2 | 3 | 0.01 3534c7b341136a18bd52449af6e28570ca87a36f 4 | 5 | Rate lwp furl curl 6 | lwp 792/s -- -88% -90% 7 | furl 6461/s 715% -- -15% 8 | curl 7587/s 857% 17% -- 9 | 10 | 0.02 fbb922531d3236b2da84acd0c22f554e61060446 11 | 12 | Rate lwp http_lite furl curl 13 | lwp 823/s -- -8% -74% -89% 14 | http_lite 896/s 9% -- -72% -88% 15 | furl 3170/s 285% 254% -- -59% 16 | curl 7657/s 831% 754% 142% -- 17 | 18 | 25998b62ae12445ae0a8bdd5329ffe8f9bd71dd2 19 | 20 | Rate lwp http_lite furl curl 21 | lwp 792/s -- -25% -76% -91% 22 | http_lite 1056/s 33% -- -68% -88% 23 | furl 3326/s 320% 215% -- -62% 24 | curl 8783/s 1010% 732% 164% -- 25 | 26 | 496a941ca1fd8cfcc8925c91fab501d516fdfa8e 27 | 28 | fixed bug. 29 | 30 | Rate lwp http_lite furl curl 31 | lwp 767/s -- -27% -88% -91% 32 | http_lite 1046/s 36% -- -84% -88% 33 | furl 6461/s 742% 518% -- -26% 34 | curl 8783/s 1045% 740% 36% -- 35 | 36 | #### micro optimization 37 | 38 | commit c8f4c4655966ecb1b2fef98769a72e437dd467fe 39 | Perl/5.12.1 on x86_64-linux 40 | Furl/0.02, LWP/5.837, WWW::Curl/4.14, HTTP::Lite/2.2 41 | Server: nginx/0.8.48 42 | -- 43 | 44 | Rate lwp http_lite furl curl 45 | lwp 800/s -- -23% -88% -91% 46 | http_lite 1036/s 30% -- -84% -88% 47 | furl 6587/s 723% 536% -- -24% 48 | curl 8650/s 981% 735% 31% -- 49 | 50 | #### 0.04 51 | 52 | 0065f2144c7636fc79ae1b30ae01c8e5f25de178 53 | Perl/5.12.1 on x86_64-linux 54 | Furl/0.04, LWP/5.837, WWW::Curl/4.14, HTTP::Lite/2.2 55 | Server: nginx/0.8.48 56 | -- 57 | 58 | Rate lwp http_lite furl curl 59 | lwp 807/s -- -23% -88% -91% 60 | http_lite 1046/s 30% -- -84% -88% 61 | furl 6698/s 730% 540% -- -22% 62 | curl 8615/s 968% 724% 29% -- 63 | 64 | #### http-parser-xs 65 | 66 | 9cf2a06ee9aed52232effdeb432f5a6668f42636 67 | Perl/5.12.1 on x86_64-linux 68 | Furl/0.04, LWP/5.837, WWW::Curl/4.14, HTTP::Lite/2.2, libcurl[libcurl/7.21.0 OpenSSL/0.9.8o zlib/1.2.3.4 libidn/1.18] 69 | Server: nginx/0.8.48 70 | Content-Length: 2947 71 | -- 72 | 73 | Rate lwp http_lite furl curl 74 | lwp 800/s -- -24% -88% -91% 75 | http_lite 1047/s 31% -- -84% -88% 76 | furl 6575/s 722% 528% -- -25% 77 | curl 8727/s 991% 734% 33% -- 78 | 79 | ##### same revision, but access to real server 80 | 81 | 9cf2a06ee9aed52232effdeb432f5a6668f42636 82 | Perl/5.12.1 on x86_64-linux 83 | Furl/0.04, LWP/5.837, WWW::Curl/4.14, HTTP::Lite/2.2, libcurl[libcurl/7.21.0 OpenSSL/0.9.8o zlib/1.2.3.4 libidn/1.18] 84 | Server: Apache 85 | -- 86 | 87 | Rate lwp http_lite furl curl 88 | lwp 111/s -- -61% -62% -81% 89 | http_lite 288/s 159% -- -3% -50% 90 | furl 296/s 166% 3% -- -49% 91 | curl 581/s 422% 102% 96% -- 92 | 93 | ##### 1MB response 94 | 95 | 7389e930aa93b20a56eb2e7a9408c4b2ff056c8d 96 | Perl/5.12.1 on x86_64-linux 97 | Furl/0.04, LWP/5.837, WWW::Curl/4.14, HTTP::Lite/2.2, libcurl[libcurl/7.21.0 OpenSSL/0.9.8o zlib/1.2.3.4 libidn/1.18] 98 | 99 | Date: Fri, 29 Oct 2010 11:43:37 GMT 100 | Server: KyotoTycoon/0.8.1 101 | Content-Length: 1000000 102 | Client-Date: Fri, 29 Oct 2010 11:43:37 GMT 103 | Client-Peer: 127.0.0.1:1978 104 | Client-Response-Num: 1 105 | -- 106 | 107 | Rate lwp http_lite furl curl 108 | lwp 74.1/s -- -62% -72% -90% 109 | http_lite 196/s 165% -- -26% -74% 110 | furl 265/s 258% 35% -- -65% 111 | curl 760/s 926% 287% 187% -- 112 | 113 | ### useragent branch. 114 | 115 | fbe216421eaa343ed86a8a3636a9ac3925018f61 116 | Perl/5.12.1 on x86_64-linux 117 | Furl/0.04, LWP/5.837, WWW::Curl/4.14, HTTP::Lite/2.2, libcurl[libcurl/7.21.0 OpenSSL/0.9.8o zlib/1.2.3.4 libidn/1.18] 118 | -- 119 | Connection: keep-alive 120 | Date: Mon, 01 Nov 2010 03:16:02 GMT 121 | Accept-Ranges: bytes 122 | Server: nginx/0.8.48 123 | Content-Length: 2947 124 | Content-Type: text/html 125 | Last-Modified: Sat, 05 Jun 2010 23:53:36 GMT 126 | Client-Date: Mon, 01 Nov 2010 03:16:02 GMT 127 | Client-Peer: 192.168.1.3:80 128 | Client-Response-Num: 1 129 | -- 130 | bufsize: 10240 131 | -- 132 | 133 | Rate lwp http_lite furl_high furl_low curl 134 | lwp 799/s -- -24% -83% -88% -91% 135 | http_lite 1057/s 32% -- -78% -84% -88% 136 | furl_high 4699/s 488% 345% -- -31% -46% 137 | furl_low 6762/s 746% 540% 44% -- -22% 138 | curl 8650/s 982% 719% 84% 28% -- 139 | 140 | ### 0.07 141 | 142 | 143 | 58868db2dbe06394ac6b8344fbbf47acf334daf1 144 | Perl/5.12.1 on x86_64-linux 145 | Furl/0.07, LWP/5.837, WWW::Curl/4.14, HTTP::Lite/2.2, libcurl[libcurl/7.21.0 OpenSSL/0.9.8o zlib/1.2.3.4 libidn/1.18] 146 | -- 147 | Connection: keep-alive 148 | Date: Tue, 02 Nov 2010 00:24:44 GMT 149 | Accept-Ranges: bytes 150 | Server: nginx/0.8.48 151 | Content-Length: 2947 152 | Content-Type: text/html 153 | Last-Modified: Sat, 05 Jun 2010 23:53:36 GMT 154 | Client-Date: Tue, 02 Nov 2010 00:24:44 GMT 155 | Client-Peer: 192.168.1.3:80 156 | Client-Response-Num: 1 157 | -- 158 | bufsize: 10240 159 | -- 160 | 161 | Rate lwp http_lite furl_high furl_low curl 162 | lwp 792/s -- -24% -83% -88% -91% 163 | http_lite 1046/s 32% -- -78% -84% -88% 164 | furl_high 4757/s 501% 355% -- -25% -45% 165 | furl_low 6342/s 701% 506% 33% -- -27% 166 | curl 8650/s 993% 727% 82% 36% -- 167 | 168 | ### kazuho 169 | 170 | perl -Ilib benchmperl -Ilib benchmark/simple.pl [~/dev/Furl] 水 17 19:05 171 | 65d1df9882c8f5330f9cc93a03722887867e303c 172 | Perl/5.12.1 on x86_64-linux 173 | Furl/0.13, LWP/5.837, WWW::Curl/4.14, HTTP::Lite/2.2, libcurl[libcurl/7.21.0 OpenSSL/0.9.8o zlib/1.2.3.4 libidn/1.18] 174 | -- 175 | Connection: keep-alive 176 | Date: Wed, 17 Nov 2010 10:05:52 GMT 177 | Accept-Ranges: bytes 178 | Server: nginx/0.8.48 179 | Content-Length: 2947 180 | Content-Type: text/html 181 | Last-Modified: Sat, 05 Jun 2010 23:53:36 GMT 182 | Client-Date: Wed, 17 Nov 2010 10:05:52 GMT 183 | Client-Peer: 192.168.1.3:80 184 | Client-Response-Num: 1 185 | -- 186 | bufsize: 10240 187 | -- 188 | 189 | Rate lwp http_lite furl_high furl_low curl 190 | lwp 800/s -- -24% -79% -84% -91% 191 | http_lite 1056/s 32% -- -72% -79% -88% 192 | furl_high 3759/s 370% 256% -- -24% -57% 193 | furl_low 4978/s 522% 372% 32% -- -43% 194 | curl 8698/s 987% 724% 131% 75% -- 195 | 196 | -------------------------------------------------------------------------------- /author/benchmark/profile.pl: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | use Furl::HTTP qw/HEADERS_NONE HEADERS_AS_ARRAYREF/; 4 | use URI; 5 | 6 | my $url = shift @ARGV || 'http://127.0.0.1:80/'; 7 | my $uri = URI->new($url); 8 | my $host = $uri->host; 9 | my $port = $uri->port; 10 | my $path_query = $uri->path_query; 11 | 12 | my $furl = Furl::HTTP->new(header_format => HEADERS_NONE, bufsize => 10_000_000); 13 | for (1..1000) { 14 | my ( $version, $code, $msg, $headers, $content ) = $furl->request( 15 | method => 'GET', 16 | host => $host, 17 | port => $port, 18 | path_query => $path_query, 19 | ); 20 | $code == 200 or die "oops : $code, $content"; 21 | } 22 | 23 | -------------------------------------------------------------------------------- /author/benchmark/simple.pl: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | use Benchmark ':all'; 4 | use LWP::UserAgent; 5 | use WWW::Curl::Easy 4.14; 6 | use HTTP::Lite; 7 | use Furl::HTTP qw/HEADERS_NONE HEADERS_AS_ARRAYREF/; 8 | use Furl; 9 | use Config; 10 | use Getopt::Long; 11 | 12 | GetOptions( 13 | 'busize=i' => \my $bufsize, 14 | ); 15 | 16 | printf `git rev-parse HEAD`; 17 | printf "Perl/%vd on %s\n", $^V, $Config{archname}; 18 | printf "Furl/$Furl::VERSION, LWP/$LWP::VERSION, WWW::Curl/$WWW::Curl::VERSION, HTTP::Lite/$HTTP::Lite::VERSION, libcurl[@{[ WWW::Curl::Easy::version() ]}]\n"; 19 | 20 | my $url = shift @ARGV || 'http://192.168.1.3:80/'; 21 | 22 | my $ua = LWP::UserAgent->new(parse_head => 0, keep_alive => 1); 23 | my $curl = WWW::Curl::Easy->new(); 24 | my $furl_low = Furl::HTTP->new(header_format => HEADERS_NONE); 25 | my $furl_high = Furl->new(); 26 | $furl_high->{bufsize} = $bufsize if defined $bufsize; 27 | $furl_low->{bufsize} = $bufsize if defined $bufsize; 28 | my $uri = URI->new($url); 29 | my $host = $uri->host; 30 | my $scheme = $uri->scheme; 31 | my $port = $uri->port; 32 | my $path_query = $uri->path_query; 33 | my $lite = HTTP::Lite->new(); 34 | $lite->http11_mode(1); 35 | 36 | my $res = $ua->get($url); 37 | print "--\n"; 38 | print $res->headers_as_string; 39 | print "--\n"; 40 | printf "bufsize: %d\n", $furl_low->{bufsize}; 41 | print "--\n\n"; 42 | my $body_content_length = length($res->content); 43 | $body_content_length == $res->content_length or die; 44 | 45 | cmpthese( 46 | -1, { 47 | http_lite => sub { 48 | my $req = $lite->request($url) 49 | or die; 50 | $lite->status == 200 or die; 51 | length($lite->body) == $body_content_length or die "Lite failed: @{[ length($lite->body) ]} != $body_content_length"; 52 | $lite->reset(); # This is *required* for re-use instance. 53 | }, 54 | lwp => sub { 55 | my $res = $ua->get($url); 56 | $res->code == 200 or die; 57 | length($res->content) == $body_content_length or die; 58 | }, 59 | curl => sub { 60 | my @headers; 61 | $curl->setopt(CURLOPT_HEADER, 0); 62 | $curl->setopt(CURLOPT_NOPROGRESS, 1); 63 | $curl->setopt(CURLOPT_URL, $url); 64 | $curl->setopt(CURLOPT_HTTPGET, 1); 65 | $curl->setopt(CURLOPT_HEADERFUNCTION, sub { 66 | push @headers, @_; 67 | length($_[0]); 68 | }); 69 | my $content = ''; 70 | $curl->setopt(CURLOPT_WRITEDATA, \$content); 71 | my $ret = $curl->perform(); 72 | $ret == 0 or die "$ret : " . $curl->strerror($ret); 73 | my $code = $curl->getinfo(CURLINFO_HTTP_CODE); 74 | $code == 200 or die "oops: $code"; 75 | length($content) == $body_content_length or die; 76 | }, 77 | furl_high => sub { 78 | my $res = $furl_high->request( 79 | method => 'GET', 80 | host => $host, 81 | port => $port, 82 | scheme => $scheme, 83 | path_query => $path_query, 84 | headers => [ 'Content-Length' => 0 ] 85 | ); 86 | $res->code == 200 or die "oops"; 87 | length($res->content) == $body_content_length or die; 88 | }, 89 | furl_low => sub { 90 | my ( $version, $code, $msg, $headers, $content ) = $furl_low->request( 91 | method => 'GET', 92 | host => $host, 93 | port => $port, 94 | scheme => $scheme, 95 | path_query => $path_query, 96 | headers => [ 'Content-Length' => 0 ] 97 | ); 98 | $code == 200 or die "oops: $code, $content"; 99 | length($content) == $body_content_length or die; 100 | }, 101 | }, 102 | ); 103 | -------------------------------------------------------------------------------- /author/mk-chunked-response.pl: -------------------------------------------------------------------------------- 1 | #!perl -w 2 | use strict; 3 | use Furl; 4 | use Plack::Loader; 5 | use Child; 6 | 7 | { 8 | package Furl::Verbose; 9 | use parent qw(Furl); 10 | sub read_timeout { 11 | my $self = shift; 12 | my $ret = $self->SUPER::read_timeout(@_); 13 | print ${$_[1]}; 14 | return $ret; 15 | } 16 | } 17 | 18 | my $content = "The quick brown fox jumps over the lazy dog.\n" x 100; 19 | 20 | my $child = Child->new( 21 | sub { 22 | Plack::Loader->load('Starman', host => '127.0.0.1', port => 1234 ) 23 | ->run( 24 | sub { [ 200, ['Transfer-Encoding' => 'chunked' ], [$content] ] } ); 25 | } 26 | ); 27 | my $proc = $child->start(); 28 | sleep 1; 29 | Furl::Verbose->new->get('http://127.0.0.1:1234/'); 30 | $proc->kill('TERM'); 31 | 32 | -------------------------------------------------------------------------------- /cpanfile: -------------------------------------------------------------------------------- 1 | requires 'perl', 5.008_001; 2 | 3 | requires 'HTTP::Parser::XS' => 0.11; 4 | requires 'Mozilla::CA'; 5 | requires 'MIME::Base64'; 6 | requires 'Class::Accessor::Lite'; 7 | requires 'Encode'; 8 | requires 'Scalar::Util'; 9 | requires 'Socket'; 10 | requires 'Time::HiRes'; 11 | 12 | suggests 'HTTP::Headers'; # Furl::Headers 13 | suggests 'HTTP::Request'; # Furl::Request 14 | suggests 'HTTP::Response'; # Furl::Response 15 | 16 | recommends 'Net::IDN::Encode'; # for International Domain Name 17 | recommends 'IO::Socket::SSL'; # for SSL 18 | recommends 'Compress::Raw::Zlib'; # for Content-Encoding 19 | recommends 'HTTP::CookieJar'; 20 | 21 | on test => sub { 22 | requires 'Test::More' => 0.96; # done_testing, subtest 23 | requires 'Test::TCP' => '2.11'; 24 | requires 'Test::Requires'; 25 | requires 'File::Temp'; 26 | suggests 'Test::Fake::HTTPD'; 27 | suggests 'HTTP::Proxy'; 28 | suggests 'HTTP::Server::PSGI'; 29 | suggests 'Plack::Loader'; 30 | suggests 'Plack::Request'; 31 | suggests 'Starlet::Server'; 32 | suggests 'Test::SharedFork'; 33 | suggests 'URI'; 34 | suggests 'parent'; 35 | suggests 'Plack'; 36 | suggests 'Test::Valgrind'; 37 | suggests 'HTTP::CookieJar'; 38 | suggests 'HTTP::Body'; 39 | }; 40 | 41 | on develop => sub { 42 | suggests 'Child'; 43 | suggests 'Getopt::Long'; 44 | suggests 'HTTP::Lite'; 45 | suggests 'LWP::UserAgent'; 46 | suggests 'Plack::Loader'; 47 | suggests 'Starman'; 48 | suggests 'Test::More'; 49 | suggests 'Test::Requires'; 50 | suggests 'Test::TCP'; 51 | suggests 'URI'; 52 | suggests 'WWW::Curl::Easy', '4.14'; 53 | suggests 'IO::Callback'; 54 | suggests 'autodie'; 55 | suggests 'parent'; 56 | suggests 'Net::IDN::Encode'; 57 | suggests 'Test::LeakTrace'; 58 | suggests 'Net::DNS::Lite'; 59 | }; 60 | 61 | -------------------------------------------------------------------------------- /example/get.pl: -------------------------------------------------------------------------------- 1 | #!perl -w 2 | use strict; 3 | use Furl; 4 | use HTTP::Response; 5 | 6 | my $uri = shift(@ARGV) or die "Usage: $0 URI\n"; 7 | 8 | my $furl = Furl->new(headers => ['Accept-Encoding' => 'gzip']); 9 | $furl->env_proxy; 10 | print $furl->get($uri)->as_http_response->as_string; 11 | -------------------------------------------------------------------------------- /lib/Furl.pm: -------------------------------------------------------------------------------- 1 | package Furl; 2 | use strict; 3 | use warnings; 4 | use utf8; 5 | use Furl::HTTP; 6 | use Furl::Request; 7 | use Furl::Response; 8 | use Carp (); 9 | our $VERSION = '3.14'; 10 | 11 | use 5.008001; 12 | 13 | $Carp::Internal{+__PACKAGE__} = 1; 14 | 15 | sub new { 16 | my $class = shift; 17 | bless \(Furl::HTTP->new(header_format => Furl::HTTP::HEADERS_AS_HASHREF(), @_)), $class; 18 | } 19 | 20 | sub get { 21 | my ( $self, $url, $headers ) = @_; 22 | $self->request( 23 | method => 'GET', 24 | url => $url, 25 | headers => $headers 26 | ); 27 | } 28 | 29 | sub head { 30 | my ( $self, $url, $headers ) = @_; 31 | $self->request( 32 | method => 'HEAD', 33 | url => $url, 34 | headers => $headers 35 | ); 36 | } 37 | 38 | sub post { 39 | my ( $self, $url, $headers, $content ) = @_; 40 | $self->request( 41 | method => 'POST', 42 | url => $url, 43 | headers => $headers, 44 | content => $content 45 | ); 46 | } 47 | 48 | sub put { 49 | my ( $self, $url, $headers, $content ) = @_; 50 | $self->request( 51 | method => 'PUT', 52 | url => $url, 53 | headers => $headers, 54 | content => $content 55 | ); 56 | } 57 | 58 | sub delete { 59 | my ( $self, $url, $headers, $content ) = @_; 60 | $self->request( 61 | method => 'DELETE', 62 | url => $url, 63 | headers => $headers, 64 | content => $content 65 | ); 66 | } 67 | 68 | 69 | sub agent { 70 | @_ == 2 ? ${$_[0]}->agent($_[1]) : ${$_[0]}->agent; 71 | } 72 | 73 | sub env_proxy { 74 | my $self = shift; 75 | $$self->env_proxy; 76 | } 77 | 78 | sub request { 79 | my $self = shift; 80 | 81 | my %args; 82 | if (@_ % 2 == 0) { 83 | %args = @_; 84 | } else { 85 | # convert HTTP::Request to hash for Furl::HTTP. 86 | 87 | my $req = shift; 88 | %args = @_; 89 | my $req_headers= $req->headers; 90 | $req_headers->remove_header('Host'); # suppress duplicate Host header 91 | my $headers = +[ 92 | map { 93 | my $k = $_; 94 | map { ( $k => $_ ) } $req_headers->header($_); 95 | } $req_headers->header_field_names 96 | ]; 97 | 98 | $args{url} = $req->uri; 99 | $args{method} = $req->method; 100 | $args{content} = $req->content; 101 | $args{headers} = $headers; 102 | } 103 | 104 | my ( 105 | $res_minor_version, 106 | $res_status, 107 | $res_msg, 108 | $res_headers, 109 | $res_content, 110 | $captured_req_headers, 111 | $captured_req_content, 112 | $captured_res_headers, 113 | $captured_res_content, 114 | $request_info, 115 | ) = ${$self}->request(%args); 116 | 117 | my $res = Furl::Response->new($res_minor_version, $res_status, $res_msg, $res_headers, $res_content); 118 | $res->set_request_info(\%args, $captured_req_headers, $captured_req_content); 119 | 120 | return $res; 121 | } 122 | 123 | 1; 124 | __END__ 125 | 126 | =encoding utf8 127 | 128 | =head1 NAME 129 | 130 | Furl - Lightning-fast URL fetcher 131 | 132 | =head1 SYNOPSIS 133 | 134 | use Furl; 135 | 136 | my $furl = Furl->new( 137 | agent => 'MyGreatUA/2.0', 138 | timeout => 10, 139 | ); 140 | 141 | my $res = $furl->get('http://example.com/'); 142 | die $res->status_line unless $res->is_success; 143 | print $res->content; 144 | 145 | my $res = $furl->post( 146 | 'http://example.com/', # URL 147 | [...], # headers 148 | [ foo => 'bar' ], # form data (HashRef/FileHandle are also okay) 149 | ); 150 | 151 | # Accept-Encoding is supported but optional 152 | $furl = Furl->new( 153 | headers => [ 'Accept-Encoding' => 'gzip' ], 154 | ); 155 | my $body = $furl->get('http://example.com/some/compressed'); 156 | 157 | =head1 DESCRIPTION 158 | 159 | Furl is yet another HTTP client library. LWP is the de facto standard HTTP 160 | client for Perl 5, but it is too slow for some critical jobs, and too complex 161 | for weekend hacking. Furl resolves these issues. Enjoy it! 162 | 163 | =head1 INTERFACE 164 | 165 | =head2 Class Methods 166 | 167 | =head3 C<< Furl->new(%args | \%args) :Furl >> 168 | 169 | Creates and returns a new Furl client with I<%args>. Dies on errors. 170 | 171 | I<%args> might be: 172 | 173 | =over 174 | 175 | =item agent :Str = "Furl/$VERSION" 176 | 177 | =item timeout :Int = 10 178 | 179 | =item max_redirects :Int = 7 180 | 181 | =item capture_request :Bool = false 182 | 183 | If this parameter is true, L captures raw request string. 184 | You can get it by C<< $res->captured_req_headers >> and C<< $res->captured_req_content >>. 185 | 186 | =item proxy :Str 187 | 188 | =item no_proxy :Str 189 | 190 | =item headers :ArrayRef 191 | 192 | =item cookie_jar :Object 193 | 194 | (EXPERIMENTAL) 195 | 196 | An instance of HTTP::CookieJar or equivalent class that supports the add and cookie_header methods 197 | 198 | =back 199 | 200 | =head2 Instance Methods 201 | 202 | =head3 C<< $furl->request([$request,] %args) :Furl::Response >> 203 | 204 | Sends an HTTP request to a specified URL and returns a instance of L. 205 | 206 | I<%args> might be: 207 | 208 | =over 209 | 210 | =item scheme :Str = "http" 211 | 212 | Protocol scheme. May be C or C. 213 | 214 | =item host :Str 215 | 216 | Server host to connect. 217 | 218 | You must specify at least C or C. 219 | 220 | =item port :Int = 80 221 | 222 | Server port to connect. The default is 80 on C<< scheme => 'http' >>, 223 | or 443 on C<< scheme => 'https' >>. 224 | 225 | =item path_query :Str = "/" 226 | 227 | Path and query to request. 228 | 229 | =item url :Str 230 | 231 | URL to request. 232 | 233 | You can use C instead of C, C, C and C. 234 | 235 | =item headers :ArrayRef 236 | 237 | HTTP request headers. e.g. C<< headers => [ 'Accept-Encoding' => 'gzip' ] >>. 238 | 239 | =item content : Str | ArrayRef[Str] | HashRef[Str] | FileHandle 240 | 241 | Content to request. 242 | 243 | =back 244 | 245 | If the number of arguments is an odd number, this method assumes that the 246 | first argument is an instance of C. Remaining arguments 247 | can be any of the previously describe values (but currently there's no 248 | way to really utilize them, so don't use it) 249 | 250 | my $req = HTTP::Request->new(...); 251 | my $res = $furl->request($req); 252 | 253 | You can also specify an object other than HTTP::Request (e.g. Furl::Request), 254 | but the object must implement the following methods: 255 | 256 | =over 4 257 | 258 | =item uri 259 | 260 | =item method 261 | 262 | =item content 263 | 264 | =item headers 265 | 266 | =back 267 | 268 | These must return the same type of values as their counterparts in 269 | C. 270 | 271 | You must encode all the queries or this method will die, saying 272 | C. 273 | 274 | =head3 C<< $furl->get($url :Str, $headers :ArrayRef[Str] ) >> 275 | 276 | This is an easy-to-use alias to C, sending the C method. 277 | 278 | =head3 C<< $furl->head($url :Str, $headers :ArrayRef[Str] ) >> 279 | 280 | This is an easy-to-use alias to C, sending the C method. 281 | 282 | =head3 C<< $furl->post($url :Str, $headers :ArrayRef[Str], $content :Any) >> 283 | 284 | This is an easy-to-use alias to C, sending the C method. 285 | 286 | =head3 C<< $furl->put($url :Str, $headers :ArrayRef[Str], $content :Any) >> 287 | 288 | This is an easy-to-use alias to C, sending the C method. 289 | 290 | =head3 C<< $furl->delete($url :Str, $headers :ArrayRef[Str] ) >> 291 | 292 | This is an easy-to-use alias to C, sending the C method. 293 | 294 | =head3 C<< $furl->env_proxy() >> 295 | 296 | Loads proxy settings from C<< $ENV{HTTP_PROXY} >> and C<< $ENV{NO_PROXY} >>. 297 | 298 | =head1 TIPS 299 | 300 | =over 4 301 | 302 | =item L preloading 303 | 304 | Furl interprets the C argument as the maximum time the module is permitted to spend before returning an error. 305 | 306 | The module also lazy-loads L when an HTTPS request is being issued for the first time. Loading the module usually takes ~0.1 seconds. 307 | 308 | The time spent for loading the SSL module may become an issue in case you want to impose a very small timeout value for connection establishment. In such case, users are advised to preload the SSL module explicitly. 309 | 310 | =back 311 | 312 | =head1 FAQ 313 | 314 | =over 4 315 | 316 | =item Does Furl depends on XS modules? 317 | 318 | No. Although some optional features require XS modules, basic features are 319 | available without XS modules. 320 | 321 | Note that Furl requires HTTP::Parser::XS, which seems an XS module 322 | but includes a pure Perl backend, HTTP::Parser::XS::PP. 323 | 324 | =item I need more speed. 325 | 326 | See L, which provides the low level interface of L. 327 | It is faster than C since L does not create response objects. 328 | 329 | =item How do you use cookie_jar? 330 | 331 | Furl does not directly support the cookie_jar option available in LWP. You can use L, L, L like following. 332 | 333 | my $f = Furl->new(); 334 | my $cookies = HTTP::Cookies->new(); 335 | my $req = HTTP::Request->new(...); 336 | $cookies->add_cookie_header($req); 337 | my $res = $f->request($req)->as_http_response; 338 | $res->request($req); 339 | $cookies->extract_cookies($res); 340 | # and use $res. 341 | 342 | =item How do you limit the response content length? 343 | 344 | You can limit the content length by callback function. 345 | 346 | my $f = Furl->new(); 347 | my $content = ''; 348 | my $limit = 1_000_000; 349 | my %special_headers = ('content-length' => undef); 350 | my $res = $f->request( 351 | method => 'GET', 352 | url => $url, 353 | special_headers => \%special_headers, 354 | write_code => sub { 355 | my ( $status, $msg, $headers, $buf ) = @_; 356 | if (($special_headers{'content-length'}||0) > $limit || length($content) > $limit) { 357 | die "over limit: $limit"; 358 | } 359 | $content .= $buf; 360 | } 361 | ); 362 | 363 | =item How do you display the progress bar? 364 | 365 | my $bar = Term::ProgressBar->new({count => 1024, ETA => 'linear'}); 366 | $bar->minor(0); 367 | $bar->max_update_rate(1); 368 | 369 | my $f = Furl->new(); 370 | my $content = ''; 371 | my %special_headers = ('content-length' => undef);; 372 | my $did_set_target = 0; 373 | my $received_size = 0; 374 | my $next_update = 0; 375 | $f->request( 376 | method => 'GET', 377 | url => $url, 378 | special_headers => \%special_headers, 379 | write_code => sub { 380 | my ( $status, $msg, $headers, $buf ) = @_; 381 | unless ($did_set_target) { 382 | if ( my $cl = $special_headers{'content-length'} ) { 383 | $bar->target($cl); 384 | $did_set_target++; 385 | } 386 | else { 387 | $bar->target( $received_size + 2 * length($buf) ); 388 | } 389 | } 390 | $received_size += length($buf); 391 | $content .= $buf; 392 | $next_update = $bar->update($received_size) 393 | if $received_size >= $next_update; 394 | } 395 | ); 396 | 397 | =item HTTPS requests claims warnings! 398 | 399 | When you make https requests, IO::Socket::SSL may complain about it like: 400 | 401 | ******************************************************************* 402 | Using the default of SSL_verify_mode of SSL_VERIFY_NONE for client 403 | is depreciated! Please set SSL_verify_mode to SSL_VERIFY_PEER 404 | together with SSL_ca_file|SSL_ca_path for verification. 405 | If you really don't want to verify the certificate and keep the 406 | connection open to Man-In-The-Middle attacks please set 407 | SSL_verify_mode explicitly to SSL_VERIFY_NONE in your application. 408 | ******************************************************************* 409 | 410 | You should set C explicitly with Furl's C. 411 | 412 | use IO::Socket::SSL; 413 | 414 | my $ua = Furl->new( 415 | ssl_opts => { 416 | SSL_verify_mode => SSL_VERIFY_PEER(), 417 | }, 418 | ); 419 | 420 | See L for details. 421 | 422 | =back 423 | 424 | =head1 AUTHOR 425 | 426 | Tokuhiro Matsuno Etokuhirom@gmail.comE 427 | 428 | Fuji, Goro (gfx) 429 | 430 | =head1 THANKS TO 431 | 432 | Kazuho Oku 433 | 434 | mala 435 | 436 | mattn 437 | 438 | lestrrat 439 | 440 | walf443 441 | 442 | lestrrat 443 | 444 | audreyt 445 | 446 | =head1 SEE ALSO 447 | 448 | L 449 | 450 | L 451 | 452 | L 453 | 454 | L 455 | 456 | =head1 LICENSE 457 | 458 | Copyright (C) Tokuhiro Matsuno. 459 | 460 | This library is free software; you can redistribute it and/or modify 461 | it under the same terms as Perl itself. 462 | 463 | =cut 464 | -------------------------------------------------------------------------------- /lib/Furl/ConnectionCache.pm: -------------------------------------------------------------------------------- 1 | package Furl::ConnectionCache; 2 | use strict; 3 | use warnings; 4 | use utf8; 5 | 6 | sub new { bless [''], shift } 7 | 8 | sub steal { 9 | my ($self, $host, $port) = @_; 10 | if ($self->[0] eq "$host:$port") { 11 | my $sock = $self->[1]; 12 | @{$self} = (''); 13 | return $sock; 14 | } else { 15 | return undef; 16 | } 17 | } 18 | 19 | sub push { 20 | my ($self, $host, $port, $sock) = @_; 21 | $self->[0] = "$host:$port"; 22 | $self->[1] = $sock; 23 | } 24 | 25 | 1; 26 | 27 | -------------------------------------------------------------------------------- /lib/Furl/Headers.pm: -------------------------------------------------------------------------------- 1 | package Furl::Headers; 2 | use strict; 3 | use warnings; 4 | use utf8; 5 | use Carp (); 6 | 7 | sub new { 8 | my ($class, $headers) = @_; # $headers is HashRef or ArrayRef 9 | my $self = {}; 10 | if (ref $headers eq 'ARRAY') { 11 | my @h = @$headers; # copy 12 | while (my ($k, $v) = splice @h, 0, 2) { 13 | push @{$self->{lc $k}}, $v; 14 | } 15 | } 16 | elsif(ref $headers eq 'HASH') { 17 | while (my ($k, $v) = each %$headers) { 18 | push @{$self->{$k}}, ref($v) eq 'ARRAY' ? @$v : $v; 19 | } 20 | } 21 | else { 22 | Carp::confess($class . ': $headers must be an ARRAY or HASH reference'); 23 | } 24 | 25 | bless $self, $class; 26 | } 27 | 28 | sub header { 29 | my ($self, $key, $new) = @_; 30 | if ($new) { # setter 31 | $new = [$new] unless ref $new; 32 | $self->{lc $key} = $new; 33 | return; 34 | } else { 35 | my $val = $self->{lc $key}; 36 | return unless $val; 37 | return wantarray ? @$val : join(", ", @$val); 38 | } 39 | } 40 | 41 | sub remove_header { 42 | my ($self, $key) = @_; 43 | delete $self->{lc $key}; 44 | } 45 | 46 | sub flatten { 47 | my $self = shift; 48 | my @ret; 49 | while (my ($k, $v) = each %$self) { 50 | for my $e (@$v) { 51 | push @ret, $k, $e; 52 | } 53 | } 54 | return @ret; 55 | } 56 | 57 | sub keys :method { 58 | my $self = shift; 59 | keys %$self; 60 | } 61 | sub header_field_names { shift->keys } 62 | 63 | sub as_string { 64 | my $self = shift; 65 | my $ret = ''; 66 | for my $k (sort keys %$self) { 67 | for my $e (@{$self->{$k}}) { 68 | $ret .= "$k: $e\015\012"; 69 | } 70 | } 71 | return $ret; 72 | } 73 | 74 | sub as_http_headers { 75 | my ($self, $key) = @_; 76 | require HTTP::Headers; 77 | return HTTP::Headers->new($self->flatten); 78 | } 79 | 80 | # shortcut for popular headers. 81 | sub referer { [ shift->header( 'Referer' => @_ ) ]->[0] } 82 | sub expires { [ shift->header( 'Expires' => @_ ) ]->[0] } 83 | sub last_modified { [ shift->header( 'Last-Modified' => @_ ) ]->[0] } 84 | sub if_modified_since { [ shift->header( 'If-Modified-Since' => @_ ) ]->[0] } 85 | sub content_type { [ shift->header( 'Content-Type' => @_ ) ]->[0] } 86 | sub content_length { [ shift->header( 'Content-Length' => @_ ) ]->[0] } 87 | sub content_encoding { [ shift->header( 'Content-Encoding' => @_ ) ]->[0] } 88 | 89 | sub clone { 90 | require Storable; 91 | Storable::dclone($_[0]); 92 | } 93 | 94 | 1; 95 | __END__ 96 | 97 | =head1 NAME 98 | 99 | Furl::Headers - HTTP Headers object 100 | 101 | =head1 SYNOPSIS 102 | 103 | =head1 CONSTRUCTOR 104 | 105 | =over 4 106 | 107 | =item my $headers = Furl::Headers->new(\%headers); 108 | 109 | The constructor takes one argument. It is a hashref. 110 | Every key of hashref must be lower-cased. 111 | 112 | The format of the argument is like following: 113 | 114 | +{ 115 | 'content-length' => [30], 116 | 'set-cookies' => ['auth_token=; path=/; expires=Thu, 01 Jan 1970 00:00:00 GMT', '_twitter_sess=JKLJBNBLKSFJBLKSJBLKSJLKJFLSDJFjkDKFUFIOSDUFSDVjOTUzNzUwNTE2%250AZWFiMWRiNDZhMDcwOWEwMWQ5IgpmbGFzaElDOidBY3Rpb25Db250cm9sbGVy%250AOjpGbGFzaDo6Rmxhc2hIYXNoewAGOgpAdXNlZHsA--d9ce07496a22525bc178jlkhafklsdjflajfl411; domain=.twitter.com; path=/'], 117 | } 118 | 119 | =back 120 | 121 | =head1 INSTANCE METHODS 122 | 123 | =over 4 124 | 125 | =item my @values = $headers->header($key); 126 | 127 | Get the header value in array. 128 | 129 | =item my $values_joined = $headers->header($key); 130 | 131 | Get the header value in scalar. This is not a first value of header. This is same as: 132 | 133 | my $values = join(", ", $headers->header($key)) 134 | 135 | =item $headers->header($key, $val); 136 | 137 | =item $headers->header($key, \@val); 138 | 139 | Set the new value of headers. 140 | 141 | =item $headers->remove_header($key); 142 | 143 | Delete key from headers. 144 | 145 | =item my @h = $headers->flatten(); 146 | 147 | Gets pairs of keys and values. 148 | 149 | =item my @keys = $headers->keys(); 150 | 151 | =item my @keys = $headers->header_field_names(); 152 | 153 | Returns keys of headers in array. The return value do not contains duplicated value. 154 | 155 | =item my $str = $headers->as_string(); 156 | 157 | Return the header fields as a formatted MIME header. 158 | 159 | =item my $val = $headers->referer() 160 | 161 | =item my $val = $headers->expires() 162 | 163 | =item my $val = $headers->last_modified() 164 | 165 | =item my $val = $headers->if_modified_since() 166 | 167 | =item my $val = $headers->content_type() 168 | 169 | =item my $val = $headers->content_length() 170 | 171 | =item my $val = $headers->content_encoding() 172 | 173 | These methods are shortcut for popular headers. 174 | 175 | =item $headers->clone(); 176 | 177 | Returns a copy of this "Furl::Headers" object. 178 | 179 | =back 180 | 181 | =head1 SEE ALSO 182 | 183 | L 184 | 185 | =cut 186 | -------------------------------------------------------------------------------- /lib/Furl/Request.pm: -------------------------------------------------------------------------------- 1 | package Furl::Request; 2 | 3 | use strict; 4 | use warnings; 5 | use utf8; 6 | use Class::Accessor::Lite; 7 | use Furl::Headers; 8 | use Furl::HTTP; 9 | 10 | Class::Accessor::Lite->mk_accessors(qw/ method uri protocol headers content /); 11 | 12 | sub new { 13 | my $class = shift; 14 | my ($method, $uri, $headers, $content) = @_; 15 | 16 | unless (defined $headers) { 17 | $headers = +{}; 18 | } 19 | 20 | unless (defined $content) { 21 | $content = ''; 22 | } 23 | 24 | bless +{ 25 | method => $method, 26 | uri => $uri, 27 | headers => Furl::Headers->new($headers), 28 | content => $content, 29 | }, $class; 30 | } 31 | 32 | sub parse { 33 | my $class = shift; 34 | my $raw_request = shift; 35 | 36 | # I didn't use HTTP::Parser::XS for following reasons: 37 | # 1. parse_http_request() function omits request content, but need to deal it. 38 | # 2. this function parses header to PSGI env, but env/header mapping is troublesome. 39 | 40 | return unless $raw_request =~ s!^(.+) (.+) (HTTP/1.\d+)\s*!!; 41 | my ($method, $uri, $protocol) = ($1, $2, $3); 42 | 43 | my ($header_str, $content) = split /\015?\012\015?\012/, $raw_request, 2; 44 | 45 | my $headers = +{}; 46 | for (split /\015?\012/, $header_str) { 47 | tr/\015\012//d; 48 | my ($k, $v) = split /\s*:\s*/, $_, 2; 49 | $headers->{lc $k} = $v; 50 | 51 | # complete host_port 52 | if (lc $k eq 'host') { 53 | $uri = $v . $uri; 54 | } 55 | } 56 | 57 | unless ($uri =~ /^http/) { 58 | $uri = "http://$uri"; 59 | } 60 | 61 | my $req = $class->new($method, $uri, $headers, $content); 62 | $req->protocol($protocol); 63 | return $req; 64 | } 65 | 66 | # alias 67 | *body = \&content; 68 | 69 | # shorthand 70 | sub content_length { shift->headers->content_length } 71 | sub content_type { shift->headers->content_type } 72 | sub header { shift->headers->header(@_) } 73 | 74 | sub request_line { 75 | my $self = shift; 76 | 77 | my $path_query = $self->uri . ''; # for URI.pm 78 | $path_query =~ s!^https?://[^/]+!!; 79 | 80 | my $method = $self->method || ''; 81 | my $protocol = $self->protocol || ''; 82 | 83 | return "$method $path_query $protocol"; 84 | } 85 | 86 | sub as_http_request { 87 | my $self = shift; 88 | 89 | require HTTP::Request; 90 | my $req = HTTP::Request->new( 91 | $self->method, 92 | $self->uri, 93 | [ $self->headers->flatten ], 94 | $self->content, 95 | ); 96 | 97 | $req->protocol($self->protocol); 98 | return $req; 99 | } 100 | 101 | sub as_hashref { 102 | my $self = shift; 103 | 104 | return +{ 105 | method => $self->method, 106 | uri => $self->uri, 107 | protocol => $self->protocol, 108 | headers => [ $self->headers->flatten ], 109 | content => $self->content, 110 | }; 111 | } 112 | 113 | sub as_string { 114 | my $self = shift; 115 | 116 | join("\015\012", 117 | $self->method . ' ' . $self->uri . (defined($self->protocol) ? ' ' . $self->protocol : ''), 118 | $self->headers->as_string, 119 | ref($self->content) =~ qr{\A(?:ARRAY|HASH)\z} ? Furl::HTTP->make_x_www_form_urlencoded($self->content) : $self->content, 120 | ); 121 | } 122 | 123 | 1; 124 | __END__ 125 | 126 | =head1 NAME 127 | 128 | Furl::Request - Request object for Furl 129 | 130 | =head1 SYNOPSIS 131 | 132 | my $f = Furl->new; 133 | my $req = Furl::Request->new($method, $uri, $headers, $content); 134 | my $res = $f->request($req); 135 | 136 | print $req->request_line, "\n"; 137 | my $http_req = $req->as_http_request; 138 | my $req_hash = $req->as_hashref; 139 | 140 | =head1 DESCRIPTION 141 | 142 | This is a HTTP request object in Furl. 143 | 144 | =head1 CONSTRUCTOR 145 | 146 | my $req = Furl::Request->new($method, $uri); 147 | # or 148 | my $req = Furl::Request->new($method, $uri, \%headers); 149 | # or 150 | my $req = Furl::Request->new($method, $uri, \%headers, $content); 151 | 152 | # and 153 | 154 | my $req = Furl::Request->parse($http_request_raw_string); 155 | 156 | =head1 INSTANCE METHODS 157 | 158 | =over 4 159 | 160 | =item $req->method($method) 161 | 162 | Gets/Sets HTTP request method 163 | 164 | =item $req->uri($uri) 165 | 166 | Gets/Sets request URI 167 | 168 | =item $req->headers($headers) 169 | 170 | Gets/Sets instance of L 171 | 172 | =item $req->content($content) 173 | 174 | =item $req->body($content) 175 | 176 | Gets/Sets request body in scalar. 177 | 178 | =item $req->protocol($protocol) 179 | 180 | $req->protocol('HTTP/1.1'); 181 | print $req->protocol; #=> "HTTP/1.1" 182 | 183 | Gets/Sets HTTP protocol in string. 184 | 185 | =item $req->content_length 186 | 187 | =item $req->content_type 188 | 189 | =item $req->header 190 | 191 | Shorthand to access L. 192 | 193 | =item $req->as_http_request 194 | 195 | Make instance of L from L. 196 | 197 | =item $req->as_hashref 198 | 199 | Convert request object to HashRef. 200 | 201 | Format is following: 202 | 203 | method: Str 204 | uri: Str 205 | protocol: Str 206 | headers: ArrayRef[Str] 207 | content: Str 208 | 209 | =item $req->request_line 210 | 211 | print $req->request_line; #=> "GET / HTTP/1.1" 212 | 213 | Returns HTTP request line. 214 | 215 | =back 216 | -------------------------------------------------------------------------------- /lib/Furl/Response.pm: -------------------------------------------------------------------------------- 1 | package Furl::Response; 2 | use strict; 3 | use warnings; 4 | use utf8; 5 | use Furl::Headers; 6 | 7 | sub new { 8 | my ($class, $minor_version, $code, $message, $headers, $content) = @_; 9 | bless { 10 | minor_version => $minor_version, 11 | code => $code, 12 | message => $message, 13 | headers => Furl::Headers->new($headers), 14 | content => $content, 15 | }, $class; 16 | } 17 | 18 | # DO NOT CALL this method DIRECTLY. 19 | sub set_request_info { 20 | my ($self, $request_src, $captured_req_headers, $captured_req_content) = @_; 21 | $self->{request_src} = $request_src; 22 | if (defined $captured_req_headers) { 23 | $self->{captured_req_headers} = $captured_req_headers; 24 | $self->{captured_req_content} = $captured_req_content; 25 | } else { 26 | $self->{captured_req_headers} = undef; 27 | $self->{captured_req_content} = undef; 28 | } 29 | return; 30 | } 31 | 32 | sub captured_req_headers { 33 | my $self = shift; 34 | unless (exists $self->{captured_req_headers}) { 35 | Carp::croak("You can't call cpatured_req_headers method without 'capture_request' options for Furl#new"); 36 | } 37 | return $self->{captured_req_headers}; 38 | } 39 | 40 | sub captured_req_content { 41 | my $self = shift; 42 | unless (exists $self->{captured_req_content}) { 43 | Carp::croak("You can't call cpatured_req_content method without 'capture_request' options for Furl#new"); 44 | } 45 | return $self->{captured_req_content}; 46 | } 47 | 48 | # accessors 49 | sub code { shift->{code} } 50 | sub message { shift->{message} } 51 | sub headers { shift->{headers} } 52 | sub content { shift->{content} } 53 | sub request { 54 | my $self = shift; 55 | if (!exists $self->{request}) { 56 | if (!exists $self->{request_src}) { 57 | Carp::croak("This request object does not have a request information"); 58 | } 59 | 60 | # my ($method, $uri, $headers, $content) = @_; 61 | $self->{request} = Furl::Request->new( 62 | $self->{request_src}->{method}, 63 | $self->{request_src}->{url}, 64 | $self->{request_src}->{headers}, 65 | $self->{request_src}->{content}, 66 | ); 67 | } 68 | return $self->{request}; 69 | } 70 | 71 | # alias 72 | sub status { shift->code() } 73 | sub body { shift->content() } 74 | 75 | # shorthand 76 | sub content_length { shift->headers->content_length() } 77 | sub content_type { shift->headers->content_type() } 78 | sub content_encoding { shift->headers->content_encoding() } 79 | sub header { shift->headers->header(@_) } 80 | 81 | sub protocol { "HTTP/1." . $_[0]->{minor_version} } 82 | 83 | sub decoded_content { 84 | my $self = shift; 85 | my $cloned = $self->headers->clone; 86 | 87 | # 'HTTP::Message::decoded_content' tries to decompress content 88 | # if response header contains 'Content-Encoding' field. 89 | # However 'Furl' decompresses content by itself, 'Content-Encoding' field 90 | # whose value is supported encoding type should be removed from response header. 91 | my @removed = grep { ! m{\b(?:gzip|x-gzip|deflate)\b} } $cloned->header('content-encoding'); 92 | $cloned->header('content-encoding', \@removed); 93 | 94 | $self->_as_http_response_internal([ $cloned->flatten ])->decoded_content(@_); 95 | } 96 | 97 | sub as_http_response { 98 | my ($self) = @_; 99 | return $self->_as_http_response_internal([ $self->headers->flatten ]) 100 | } 101 | 102 | sub _as_http_response_internal { 103 | my ($self, $flatten_headers) = @_; 104 | 105 | require HTTP::Response; 106 | my $res = HTTP::Response->new( $self->code, $self->message, 107 | $flatten_headers, 108 | $self->content ); 109 | $res->protocol($self->protocol); 110 | 111 | if ($self->{request_src} || $self->{request}) { 112 | if (my $req = $self->request) { 113 | $res->request($req->as_http_request); 114 | } 115 | } 116 | 117 | return $res; 118 | } 119 | 120 | sub to_psgi { 121 | my ($self) = @_; 122 | return [ 123 | $self->code, 124 | [$self->headers->flatten], 125 | [$self->content] 126 | ]; 127 | } 128 | 129 | sub as_string { 130 | my ($self) = @_; 131 | return join("", 132 | $self->status_line . "\015\012", 133 | $self->headers->as_string, 134 | "\015\012", 135 | $self->content, 136 | ); 137 | } 138 | 139 | sub as_hashref { 140 | my $self = shift; 141 | 142 | return +{ 143 | code => $self->code, 144 | message => $self->message, 145 | protocol => $self->protocol, 146 | headers => [$self->headers->flatten], 147 | content => $self->content, 148 | }; 149 | } 150 | 151 | sub is_success { substr( $_[0]->code, 0, 1 ) eq '2' } 152 | sub status_line { $_[0]->code . ' ' . $_[0]->message } 153 | 154 | sub charset { 155 | my $self = shift; 156 | 157 | return $self->{__charset} if exists $self->{__charset}; 158 | if ($self->can('content_charset')){ 159 | # To suppress: 160 | # Parsing of undecoded UTF-8 will give garbage when decoding entities 161 | local $SIG{__WARN__} = sub {}; 162 | my $charset = $self->content_charset; 163 | $self->{__charset} = $charset; 164 | return $charset; 165 | } 166 | 167 | my $content_type = $self->headers->header('Content-Type'); 168 | return unless $content_type; 169 | $content_type =~ /charset=([A-Za-z0-9_\-]+)/io; 170 | $self->{__charset} = $1 || undef; 171 | 172 | # Detect charset from HTML 173 | unless (defined($self->{__charset}) && $self->content_type =~ m{text/html}) { 174 | # I guess, this is not so perfect regexp. patches welcome. 175 | # 176 | # 177 | $self->content =~ m!/]+)['"]\s*/?>!smi; 178 | $self->{__charset} = $1; 179 | } 180 | 181 | $self->{__charset}; 182 | } 183 | 184 | sub encoder { 185 | require Encode; 186 | my $self = shift; 187 | return $self->{__encoder} if exists $self->{__encoder}; 188 | my $charset = $self->charset or return; 189 | my $enc = Encode::find_encoding($charset); 190 | $self->{__encoder} = $enc; 191 | } 192 | 193 | sub encoding { 194 | my $enc = shift->encoder or return; 195 | $enc->name; 196 | } 197 | 198 | 1; 199 | __END__ 200 | 201 | =encoding utf-8 202 | 203 | =for stopwords charsets 204 | 205 | =head1 NAME 206 | 207 | Furl::Response - Response object for Furl 208 | 209 | =head1 SYNOPSIS 210 | 211 | my $res = Furl::Response->new($minor_version, $code, $message, $headers, $content); 212 | print $res->status, "\n"; 213 | 214 | =head1 DESCRIPTION 215 | 216 | This is a HTTP response object in Furl. 217 | 218 | =head1 CONSTRUCTOR 219 | 220 | my $res = Furl::Response->new($minor_version, $code, $msg, \%headers, $content); 221 | 222 | =head1 INSTANCE METHODS 223 | 224 | =over 4 225 | 226 | =item $res->code 227 | 228 | =item $res->status 229 | 230 | Returns HTTP status code. 231 | 232 | =item $res->message 233 | 234 | Returns HTTP status message. 235 | 236 | =item $res->headers 237 | 238 | Returns instance of L 239 | 240 | =item $res->content 241 | 242 | =item $res->body 243 | 244 | Returns response body in scalar. 245 | 246 | =item $res->decoded_content 247 | 248 | This will return the content after any C<< Content-Encoding >> and charsets have been decoded. See L<< HTTP::Message >> for details 249 | 250 | =item $res->request 251 | 252 | Returns instance of L related this response. 253 | 254 | =item $res->content_length 255 | 256 | =item $res->content_type 257 | 258 | =item $res->content_encoding 259 | 260 | =item $res->header 261 | 262 | Shorthand to access L. 263 | 264 | =item $res->protocol 265 | 266 | $res->protocol(); # => "HTTP/1.1" 267 | 268 | Returns HTTP protocol in string. 269 | 270 | =item $res->as_http_response 271 | 272 | Make instance of L from L. 273 | 274 | =item $res->to_psgi() 275 | 276 | Convert object to L response. It's very useful to make proxy. 277 | 278 | =item $res->as_hashref() 279 | 280 | Convert response object to HashRef. 281 | 282 | Format is following: 283 | 284 | code: Int 285 | message: Str 286 | protocol: Str 287 | headers: ArrayRef[Str] 288 | content: Str 289 | 290 | =item $res->is_success 291 | 292 | Returns true if status code is 2xx. 293 | 294 | =item $res->status_line 295 | 296 | $res->status_line() # => "200 OK" 297 | 298 | Returns status line. 299 | 300 | =item my $headers = $res->captured_req_headers() : Str 301 | 302 | Captured request headers in raw string. 303 | 304 | This method is only for debugging. 305 | 306 | You can use this method if you are using C<< capture_request >> parameter is true. 307 | 308 | =item my $content = $res->captured_req_content() : Str 309 | 310 | Captured request content in raw string. 311 | 312 | This method is only for debugging. 313 | 314 | You can use this method if you are using C<< capture_request >> parameter is true. 315 | 316 | =back 317 | -------------------------------------------------------------------------------- /lib/Furl/ZlibStream.pm: -------------------------------------------------------------------------------- 1 | package Furl::ZlibStream; 2 | # internal class. 3 | use strict; 4 | use warnings; 5 | use overload '.=' => 'append', fallback => 1; 6 | use Carp (); 7 | use Compress::Raw::Zlib qw(Z_OK Z_STREAM_END); 8 | 9 | sub new { 10 | my ( $class, $buffer ) = @_; 11 | 12 | my ( $zlib, $status ) = Compress::Raw::Zlib::Inflate->new( 13 | -WindowBits => Compress::Raw::Zlib::WANT_GZIP_OR_ZLIB(), ); 14 | $status == Z_OK 15 | or Carp::croak("Cannot initialize zlib: $status"); 16 | 17 | bless { buffer => $buffer, zlib => $zlib }, $class; 18 | } 19 | 20 | sub append { 21 | my ( $self, $partial ) = @_; 22 | 23 | my $status = $self->{zlib}->inflate( $partial, \my $deflated ); 24 | ($status == Z_OK or $status == Z_STREAM_END) 25 | or Carp::croak("Uncompress error: $status"); 26 | $self->{buffer} .= $deflated; 27 | 28 | return $self; 29 | } 30 | 31 | sub get_response_string { ref $_[0]->{buffer} ? undef : $_[0]->{buffer} } 32 | 33 | 1; 34 | -------------------------------------------------------------------------------- /t/00_compile.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use Test::More tests => 1; 3 | 4 | BEGIN { use_ok 'Furl' } 5 | diag "Perl/$^V"; 6 | diag "Furl/$Furl::VERSION"; 7 | 8 | for my $optional(qw( Net::IDN::Encode IO::Socket::SSL Compress::Raw::Zlib )) { 9 | eval qq{ require $optional }; 10 | diag $optional . '/' . ($optional->VERSION || '(not installed)'); 11 | } 12 | -------------------------------------------------------------------------------- /t/01_version.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | use utf8; 4 | use Test::More; 5 | use Furl::HTTP; 6 | use Furl; 7 | 8 | is($Furl::VERSION, $Furl::HTTP::VERSION); 9 | 10 | done_testing; 11 | 12 | -------------------------------------------------------------------------------- /t/100_low/01_simple.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | use Furl::HTTP; 4 | use Test::TCP; 5 | use Test::More; 6 | use FindBin; 7 | use lib "$FindBin::Bin/../.."; 8 | use t::HTTPServer; 9 | 10 | my $n = shift(@ARGV) || 3; 11 | test_tcp( 12 | client => sub { 13 | my $port = shift; 14 | my $furl = Furl::HTTP->new(bufsize => 10, timeout => 3); 15 | for (1 .. $n) { 16 | my ( undef, $code, $msg, $headers, $content ) = 17 | $furl->request( 18 | port => $port, 19 | path_query => '/foo', 20 | host => '127.0.0.1', 21 | headers => [ "X-Foo" => "ppp" ] 22 | ); 23 | is $code, 200, "request()/$_"; 24 | is $msg, "OK"; 25 | is Furl::HTTP::_header_get($headers, 'Content-Length'), 4, 'header' 26 | or diag(explain($headers)); 27 | is $content, '/foo' 28 | or do{ require Devel::Peek; Devel::Peek::Dump($content) }; 29 | } 30 | 31 | for (1..3) { 32 | my $path_query = '/foo/bar?a=b;c=d&e=f'; 33 | my ( undef, $code, $msg, $headers, $content ) = 34 | $furl->request(url => "http://127.0.0.1:$port$path_query", method => 'GET'); 35 | is $code, 200, "get()/$_"; 36 | is $msg, "OK"; 37 | is Furl::HTTP::_header_get($headers, 'Content-Length'), 38 | length($path_query), 'header'; 39 | is $content, $path_query; 40 | } 41 | done_testing; 42 | }, 43 | server => sub { 44 | my $port = shift; 45 | t::HTTPServer->new(port => $port)->run(sub {; 46 | my $env = shift; 47 | is $env->{HTTP_X_FOO}, "ppp" if $env->{REQUEST_URI} eq '/foo'; 48 | like $env->{'HTTP_USER_AGENT'}, qr/\A Furl::HTTP /xms; 49 | return [ 200, 50 | [ 'Content-Length' => length($env->{REQUEST_URI}) ], 51 | [$env->{REQUEST_URI}] 52 | ]; 53 | }); 54 | } 55 | ); 56 | 57 | -------------------------------------------------------------------------------- /t/100_low/03_redirect.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | use Furl::HTTP; 4 | use Test::TCP; 5 | use Test::More; 6 | use Test::Requires qw(Plack::Request HTTP::Body), 'Plack::Loader', 'Plack::Request'; 7 | 8 | use Plack::Loader; 9 | use Plack::Request; 10 | 11 | $ENV{LANG} = 'C'; 12 | 13 | test_tcp( 14 | client => sub { 15 | my $port = shift; 16 | 17 | subtest 'redirect' => sub { 18 | my $furl = Furl::HTTP->new(); 19 | my ( undef, $code, $msg, $headers, $content ) = 20 | $furl->request( url => "http://127.0.0.1:$port/1", ); 21 | is $code, 200; 22 | is $msg, "OK"; 23 | is Furl::HTTP::_header_get($headers, 'Content-Length'), 2; 24 | is $content, 'OK'; 25 | }; 26 | 27 | subtest 'not enough redirect' => sub { 28 | my $furl = Furl::HTTP->new(max_redirects => 0); 29 | my ( undef, $code, $msg, $headers, $content ) = 30 | $furl->request( url => "http://127.0.0.1:$port/1", ); 31 | is $code, 302; 32 | is $msg, 'Found'; 33 | is Furl::HTTP::_header_get($headers, 'Content-Length'), 0; 34 | is Furl::HTTP::_header_get($headers, 'Location'), "http://127.0.0.1:$port/2"; 35 | is $content, ''; 36 | }; 37 | 38 | subtest 'over max redirect' => sub { 39 | my $max_redirects = 7; 40 | my $furl = Furl::HTTP->new(max_redirects => $max_redirects); 41 | my $start_num = 4; 42 | my ( undef, $code, $msg, $headers, $content ) = 43 | $furl->request( url => "http://127.0.0.1:$port/$start_num"); 44 | is $code, 302, 'code ok'; 45 | is $msg, 'Found', 'msg ok'; 46 | is Furl::HTTP::_header_get($headers, 'Content-Length'), 0, 'content length ok'; 47 | is Furl::HTTP::_header_get($headers, 'Location'), "http://127.0.0.1:$port/" . ( $max_redirects + $start_num + 1 ), 'url ok'; 48 | is $content, '', 'content ok'; 49 | }; 50 | 51 | subtest 'POST redirects' => sub { 52 | my $furl = Furl::HTTP->new(); 53 | 54 | my ( undef, undef, undef, undef, $content ) = 55 | $furl->post("http://127.0.0.1:$port/301", [], ""); 56 | is $content, 'POST', 'POST into 301 results in a POST'; 57 | 58 | ( undef, undef, undef, undef, $content ) = 59 | $furl->post("http://127.0.0.1:$port/302", [], ""); 60 | is $content, 'GET', 'POST into 302 is implemented as 303'; 61 | 62 | ( undef, undef, undef, undef, $content ) = 63 | $furl->post("http://127.0.0.1:$port/303", [], ""); 64 | is $content, 'GET', 'POST into 303 results in a GET'; 65 | 66 | ( undef, undef, undef, undef, $content ) = 67 | $furl->post("http://127.0.0.1:$port/307", [], ""); 68 | is $content, 'POST', 'POST into 307 results in a POST'; 69 | 70 | ( undef, undef, undef, undef, $content ) = 71 | $furl->post("http://127.0.0.1:$port/308", [], ""); 72 | is $content, 'POST', 'POST into 308 results in a POST'; 73 | }; 74 | 75 | done_testing; 76 | }, 77 | server => sub { 78 | my $port = shift; 79 | Plack::Loader->auto(port => $port)->run(sub { 80 | my $env = shift; 81 | my $req = Plack::Request->new($env); 82 | $req->path_info =~ m{/(\d+)$} or die; 83 | my $id = $1; 84 | if ($id == 3) { 85 | return [ 200, [ 'Content-Length' => 2 ], ['OK'] ]; 86 | } elsif ($id =~ /^3\d\d$/) { 87 | my $base = $req->base; 88 | $base->path("/200"); # redirect target, see below 89 | return [ $id, [ 'Location' => $base->as_string ] ]; 90 | } elsif ($id == 200) { 91 | # redirect target, see above 92 | my $method = $req->method; 93 | return [ 200, [ 'Content-Length' => length $method ], [$method] ]; 94 | } else { 95 | my $base = $req->base; 96 | $base->path('/' . ($id + 1)); 97 | return [ 302, ['Location' => $base->as_string], []]; 98 | } 99 | }); 100 | } 101 | ); 102 | 103 | -------------------------------------------------------------------------------- /t/100_low/04_chunked.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | use Test::TCP; 4 | use Test::More; 5 | use Furl::HTTP; 6 | use FindBin; 7 | use lib "$FindBin::Bin/../.."; 8 | use t::HTTPServer; 9 | 10 | my $s = q{The quick brown fox jumps over the lazy dog.\n}; 11 | 12 | my $chunk = sprintf qq{%x;foo=bar;baz="qux"\015\012%s\015\012}, 13 | length($s), $s; 14 | 15 | test_tcp( 16 | client => sub { 17 | my $port = shift; 18 | my $furl = Furl::HTTP->new(bufsize => 80); 19 | # some httpd(e.g. ASP.NET) returns 00000000 as chunked end. 20 | for my $chunk_end (qw(0 00000000)) { 21 | for my $i(1, 3, 1024) { 22 | note "-- TEST (packets: $i)"; 23 | my ( undef, $code, $msg, $headers, $content ) = $furl->request( 24 | port => $port, 25 | path => '/', 26 | host => '127.0.0.1', 27 | headers => ['X-Packet-Size', $i, 'X-Chunk-End' => $chunk_end], 28 | ); 29 | is $code, 200, 'status'; 30 | is $content, $s x $i, 'content'; 31 | } 32 | } 33 | done_testing; 34 | }, 35 | server => sub { 36 | my $port = shift; 37 | 38 | t::HTTPServer->new( port => $port, enable_chunked => 0 )->run( 39 | sub { 40 | my $env = shift; 41 | my $size = $env->{HTTP_X_PACKET_SIZE} or die '???'; 42 | my $end_mark = $env->{HTTP_X_CHUNK_END}; 43 | return [ 44 | 200, 45 | [ 'Transfer-Encoding' => 'chunked' ], 46 | [ $chunk x $size, $end_mark, "\015\012" x 2 ] 47 | ]; 48 | } 49 | ); 50 | } 51 | ); 52 | 53 | -------------------------------------------------------------------------------- /t/100_low/05_slowloris.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | use Furl::HTTP; 4 | use Test::TCP; 5 | use Test::More; 6 | use Test::Requires qw(Plack::Request HTTP::Body), 'Plack'; 7 | 8 | use Plack::Request; 9 | 10 | use FindBin; 11 | use lib "$FindBin::Bin/../.."; 12 | use t::Slowloris; 13 | 14 | my $n = shift(@ARGV) || 3; 15 | 16 | test_tcp( 17 | client => sub { 18 | my $port = shift; 19 | my $furl = Furl::HTTP->new(); 20 | for (1..$n) { 21 | my ( undef, $code, $msg, $headers, $content ) = 22 | $furl->request( 23 | port => $port, 24 | path_query => '/foo', 25 | host => '127.0.0.1', 26 | headers => [ "X-Foo" => "ppp" ] 27 | ); 28 | is $code, 200, "request()/$_"; 29 | is $msg, "OK"; 30 | is Furl::HTTP::_header_get($headers, 'Content-Length'), 4; 31 | is $content, '/foo'; 32 | } 33 | for (1..3) { 34 | my $path_query = '/bar?a=b;c=d&e=f'; 35 | my ( undef, $code, $msg, $headers, $content ) = 36 | $furl->request(url => "http://127.0.0.1:$port$path_query", method => 'GET'); 37 | is $code, 200, "get()/$_"; 38 | is $msg, "OK"; 39 | is Furl::HTTP::_header_get($headers, 'Content-Length'), 40 | length($path_query); 41 | is $content, $path_query; 42 | } 43 | done_testing; 44 | }, 45 | server => sub { 46 | my $port = shift; 47 | Slowloris::Server->new(port => $port)->run(sub { 48 | my $env = shift; 49 | is $env->{'HTTP_X_FOO'}, "ppp" if $env->{REQUEST_URI} eq '/foo'; 50 | return [ 200, 51 | [ 'Content-Length' => length($env->{REQUEST_URI}) ], 52 | [$env->{REQUEST_URI}] 53 | ]; 54 | }); 55 | } 56 | ); 57 | 58 | -------------------------------------------------------------------------------- /t/100_low/06_errors.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | use Furl::HTTP; 4 | use Test::TCP; 5 | use Test::More; 6 | use Test::Requires qw(Plack::Request HTTP::Body), 'Plack'; 7 | 8 | use Plack::Request; 9 | use Errno (); 10 | 11 | { 12 | my $furl = Furl::HTTP->new(); 13 | eval { 14 | $furl->request(); 15 | }; 16 | like $@, qr/missing host name/i, 'misuse'; 17 | 18 | eval { 19 | $furl->request(url => 'ftp://ftp.example.com/', method => 'GET'); 20 | }; 21 | like $@, qr/unsupported scheme/i, 'misuse'; 22 | 23 | foreach my $bad_url(qw( 24 | hogehoge 25 | http://example.com:80foobar 26 | http://example.com: 27 | )) { 28 | eval { 29 | $furl->request(url => $bad_url, method => 'GET'); 30 | }; 31 | like $@, qr/malformed URL/, "malformed URL: $bad_url"; 32 | } 33 | } 34 | 35 | my $n = shift(@ARGV) || 3; 36 | 37 | my $fail_on_syswrite = 1; 38 | { 39 | package Erroneous::Socket; 40 | use parent qw(IO::Socket::INET); 41 | sub syswrite { 42 | my($sock, $buff, $len, $off) = @_; 43 | if($fail_on_syswrite) { 44 | $sock->SUPER::syswrite($buff, $len - 1, $off); 45 | close $sock; 46 | $! = Errno::EPIPE; 47 | return undef; 48 | } 49 | return $sock->SUPER::syswrite($buff, $len, $off); 50 | } 51 | package Erroneous::Server; 52 | use parent qw(HTTP::Server::PSGI); 53 | sub setup_listener { 54 | my $self = shift; 55 | $self->SUPER::setup_listener(@_); 56 | bless $self->{listen_sock}, 'Erroneous::Socket'; 57 | ::note 'Erroneous::Server listening'; 58 | } 59 | } 60 | 61 | test_tcp( 62 | client => sub { 63 | my $port = shift; 64 | my $furl = Furl::HTTP->new(); 65 | for (1..$n) { 66 | my ( undef, $code, $msg, $headers, $content ) = 67 | $furl->request( 68 | port => $port, 69 | path_query => '/foo', 70 | host => '127.0.0.1', 71 | headers => [ "X-Foo" => "ppp" ] 72 | ); 73 | is $code, 500, "request()/$_"; 74 | like $msg, qr/Internal Response: Unexpected EOF while reading response header/; 75 | is ref($headers), "ARRAY"; 76 | ok $content, 'content: ' . $content; 77 | } 78 | done_testing; 79 | }, 80 | server => sub { 81 | my $port = shift; 82 | Erroneous::Server->new(port => $port)->run(sub { 83 | my $env = shift; 84 | #note explain $env; 85 | my $req = Plack::Request->new($env); 86 | is $req->header('X-Foo'), "ppp" if $env->{REQUEST_URI} eq '/foo'; 87 | return [ 200, 88 | [ 'Content-Length' => length($env->{REQUEST_URI}) ], 89 | [$env->{REQUEST_URI}] 90 | ]; 91 | }); 92 | } 93 | ); 94 | 95 | -------------------------------------------------------------------------------- /t/100_low/07_timeout.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | use Furl::HTTP; 4 | use Test::TCP; 5 | use Test::More; 6 | use Time::HiRes qw(time); 7 | 8 | use Test::Requires qw(Plack::Util Plack::Request HTTP::Body), 'Plack::Request', 'Plack::Loader'; 9 | 10 | use FindBin; 11 | use lib "$FindBin::Bin/../.."; 12 | use t::Slowloris; 13 | 14 | my $n = shift(@ARGV) || 2; 15 | 16 | $Slowloris::SleepBeforeRead = 1; 17 | $Slowloris::SleepBeforeWrite = 3; 18 | 19 | test_tcp( 20 | client => sub { 21 | my $port = shift; 22 | my $furl = Furl::HTTP->new(timeout => 1.5); 23 | 24 | note 'read_timeout'; 25 | for (1 .. $n) { 26 | my $start_at = time; 27 | my ( undef, $code, $msg, $headers, $content ) = 28 | $furl->request( 29 | port => $port, 30 | path_query => '/foo', 31 | host => '127.0.0.1', 32 | ); 33 | my $elapsed = time - $start_at; 34 | is $code, 500, "request()/$_"; 35 | like $msg, qr/Internal Response: Cannot read response header: timeout/; 36 | is ref($headers), "ARRAY"; 37 | ok $content, 'content: ' . $content; 38 | ok 1.3 <= $elapsed && $elapsed <= 2; 39 | } 40 | 41 | $furl = Furl::HTTP->new(timeout => 0.5); 42 | note 'write_timeout'; 43 | my $CONTENT_SIZE_MB_MAX = 256; 44 | WRITE_TIMEOUT_TEST: for (1 .. $n) { 45 | my $content_size_mb = 1; 46 | my ($elapsed, $code, $msg, $headers, $content); 47 | while(1) { 48 | note "Try sending $content_size_mb MiB content."; 49 | my $start_at = time; 50 | ( undef, $code, $msg, $headers, $content ) = 51 | $furl->request( 52 | host => '127.0.0.1', 53 | port => $port, 54 | method => 'POST', 55 | path_query => '/foo', 56 | content => do { 57 | # should be larger than SO_SNDBUF + SO_RCVBUF + TCP_window_size 58 | my $content = "0123456789abcdef" x 64 x 1024 x $content_size_mb; 59 | open my $fh, '<', \$content or die "oops"; 60 | $fh; 61 | }, 62 | ); 63 | $elapsed = time - $start_at; 64 | if($msg !~ qr/Internal Response: Cannot read response header: timeout/) { 65 | ## It's not read timeout. It seems OK. 66 | last; 67 | } 68 | if($content_size_mb >= $CONTENT_SIZE_MB_MAX) { 69 | fail "send $content_size_mb MiB but still write timeout did not occur."; 70 | next WRITE_TIMEOUT_TEST; 71 | } 72 | note "Read timeout. Retry with more POST content"; 73 | $content_size_mb *= 2; 74 | } 75 | is $code, 500, "request()/$_"; 76 | like $msg, qr/Internal Response: Failed to send content: timeout/; 77 | is ref($headers), "ARRAY"; 78 | is Plack::Util::header_get($headers, 'X-Internal-Response'), 1; 79 | ok $content, 'content: ' . $content; 80 | ok 0.4 <= $elapsed && $elapsed <= 1; 81 | } 82 | done_testing; 83 | }, 84 | server => sub { 85 | my $port = shift; 86 | Slowloris::Server->new(port => $port)->run(sub { 87 | my $env = shift; 88 | return [ 200, [], [$env->{REQUEST_URI}] ]; 89 | }); 90 | } 91 | ); 92 | -------------------------------------------------------------------------------- /t/100_low/08_proxy.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | use Furl::HTTP; 4 | use Test::TCP; 5 | use Test::Requires qw(Plack::Request HTTP::Body), 'Plack'; 6 | use Plack::Loader; 7 | use Test::More; 8 | use Plack::Request; 9 | use Test::Requires qw(Plack::Request HTTP::Body), 'HTTP::Proxy'; 10 | use Socket qw(AF_INET); 11 | 12 | plan tests => (10*2 + 8)*3; 13 | 14 | my $verbose = 1; 15 | { 16 | package Test::HTTP::Proxy; 17 | use parent qw(HTTP::Proxy); 18 | use HTTP::Daemon; 19 | 20 | sub new { 21 | my $self = shift; 22 | my %args = @_; 23 | my %daemon_args = ( 24 | LocalAddr => '127.0.0.1', 25 | LocalPort => $args{port}, 26 | ReuseAddr => 1, 27 | Family => Socket::AF_INET, 28 | ); 29 | my $daemon = HTTP::Daemon->new(%daemon_args); 30 | $self->SUPER::new(@_, daemon => $daemon); 31 | } 32 | sub log { 33 | my($self, $level, $prefix, $msg) = @_; 34 | ::note "$prefix: $msg" if $verbose; 35 | } 36 | } 37 | 38 | { 39 | package Test::UserAgent; 40 | use parent qw(LWP::UserAgent); 41 | use Test::More; 42 | 43 | sub real_httpd_port { 44 | my ($self, $port) = @_; 45 | $self->{httpd_port} = $port if defined $port; 46 | return $self->{httpd_port}; 47 | } 48 | 49 | sub simple_request { 50 | my ($self, $req, @args) = @_; 51 | my $uri = $req->uri; 52 | my $host = $req->header('Host'); 53 | 54 | if ($self->real_httpd_port) { 55 | # test for URL with a default port 56 | like $uri.q(), qr!^http://[^:]+/!, 57 | 'No port number in the request line'; 58 | unlike $host, qr!:!, 59 | 'No port number in Host header'; 60 | 61 | # replace the port number to correctly connect to the test server 62 | $uri->port($self->real_httpd_port); 63 | } else { 64 | # test for URL with non-default port 65 | 66 | like $uri.q(), qr!^http://[^/]+:[0-9]+/!, 67 | 'A port number in the request line'; 68 | like $host, qr/:[0-9]+$/, 69 | 'A port number in Host header'; 70 | } 71 | 72 | return $self->SUPER::simple_request($req, @args); 73 | } 74 | } 75 | 76 | my $via = "VIA!VIA!VIA!"; 77 | 78 | my $httpd = Test::TCP->new(code => sub { 79 | my $httpd_port = shift; 80 | Plack::Loader->auto(port => $httpd_port)->run(sub { 81 | my $env = shift; 82 | 83 | my $req = Plack::Request->new($env); 84 | is $req->path, '/foo'; 85 | is $req->header('X-Foo'), "ppp"; 86 | like $req->header('User-Agent'), qr/\A Furl::HTTP /xms; 87 | my $content = "Hello, foo"; 88 | return [ 200, 89 | [ 'Content-Length' => length($content) ], 90 | [ $content ] 91 | ]; 92 | }); 93 | }); 94 | 95 | sub client (%) { 96 | my (%args) = @_; 97 | for (1..3) { # run some times for testing keep-alive. 98 | my $furl = Furl::HTTP->new(proxy => $args{proxy}); 99 | my ( undef, $code, $msg, $headers, $content ) = 100 | $furl->request( 101 | url => $args{request}, 102 | headers => [ "X-Foo" => "ppp" ] 103 | ); 104 | is $code, 200, "request()"; 105 | is $msg, "OK"; 106 | is Furl::HTTP::_header_get($headers, 'Content-Length'), 10; 107 | is Furl::HTTP::_header_get($headers, 'Via'), $args{via}; 108 | is $content, 'Hello, foo' 109 | or do{ require Devel::Peek; Devel::Peek::Dump($content) }; 110 | } 111 | } 112 | 113 | sub test_agent () { 114 | return Test::UserAgent->new( 115 | env_proxy => 1, 116 | keep_alive => 2, 117 | parse_head => 0, 118 | ); 119 | } 120 | 121 | local $ENV{'HTTP_PROXY'} = ''; 122 | 123 | # Request target with non-default port 124 | 125 | test_tcp( 126 | client => sub { 127 | my $proxy_port = shift; 128 | my $httpd_port = $httpd->port; 129 | client( 130 | proxy => "http://127.0.0.1:$proxy_port", 131 | request => "http://127.0.0.1:$httpd_port/foo", 132 | via => '1.0 VIA!VIA!VIA!', 133 | ); 134 | }, 135 | server => sub { # proxy server 136 | my $proxy_port = shift; 137 | my $proxy = Test::HTTP::Proxy->new(port => $proxy_port, via => $via); 138 | $proxy->agent(test_agent); 139 | $proxy->start(); 140 | }, 141 | ); 142 | 143 | # Request target with default port 144 | 145 | test_tcp( 146 | client => sub { 147 | my $proxy_port = shift; 148 | my $httpd_port = $httpd->port; 149 | client( 150 | proxy => "http://127.0.0.1:$proxy_port", 151 | request => "http://127.0.0.1/foo", # default port 152 | via => '1.0 VIA!VIA!VIA!', 153 | ); 154 | }, 155 | server => sub { # proxy server 156 | my $proxy_port = shift; 157 | my $proxy = Test::HTTP::Proxy->new(port => $proxy_port, via => $via); 158 | $proxy->agent(test_agent); 159 | $proxy->agent->real_httpd_port($httpd->port); 160 | $proxy->start(); 161 | }, 162 | ); 163 | 164 | # SSL over proxy 165 | 166 | test_tcp( 167 | client => sub { 168 | # emulate CONNECT for SSL proxying without a real SSL connection 169 | no warnings 'redefine'; 170 | local *Furl::HTTP::connect_ssl_over_proxy = sub { 171 | my ($self, $proxy_host, $proxy_port, $host, $port, $timeout_at, $proxy_authorization) = @_; 172 | my $sock = $self->connect($proxy_host, $proxy_port, $timeout_at); 173 | my $p = "CONNECT $host:$port HTTP/1.0\015\012Server: $host\015\012"; 174 | $p .= "\015\012"; 175 | $self->write_all($sock, $p, $timeout_at) or fail; 176 | 177 | # read the entire response of CONNECT method 178 | my $buf = ''; 179 | while ($buf !~ qr!(?:\015\012){2}!) { 180 | my $read = $self->read_timeout( 181 | $sock, \$buf, $self->{bufsize}, length($buf), $timeout_at 182 | ); 183 | defined $read or fail; 184 | $read != 0 or fail; 185 | } 186 | 187 | $sock; 188 | }; 189 | 190 | my $proxy_port = shift; 191 | my $httpd_port = $httpd->port; 192 | client( 193 | proxy => "http://127.0.0.1:$proxy_port", 194 | request => "https://127.0.0.1:$httpd_port/foo", 195 | # no via since the request goes directly to the origin server 196 | ); 197 | }, 198 | server => sub { # proxy server 199 | my $proxy_port = shift; 200 | my $proxy = Test::HTTP::Proxy->new(port => $proxy_port, via => $via); 201 | $proxy->start(); 202 | }, 203 | ); 204 | -------------------------------------------------------------------------------- /t/100_low/09_body.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | use Furl::HTTP; 4 | use Test::TCP; 5 | use Test::Requires qw(Plack::Request HTTP::Body), 'Plack'; 6 | use Plack::Loader; 7 | use Test::More; 8 | use Fcntl qw(SEEK_SET); 9 | 10 | use Plack::Request; 11 | 12 | test_tcp( 13 | client => sub { 14 | my $port = shift; 15 | my $furl = Furl::HTTP->new(bufsize => 80); 16 | 17 | for my $x(1, 1000) { 18 | my $req_content = "WOWOW!" x $x; 19 | note 'request content length: ', length $req_content; 20 | open my $req_content_fh, '<', \$req_content or die "oops"; 21 | my ( undef, $code, $msg, $headers, $content ) = 22 | $furl->request( 23 | method => 'POST', 24 | port => $port, 25 | path_query => '/foo', 26 | host => '127.0.0.1', 27 | headers => [ "X-Foo" => "ppp" ], 28 | content => $req_content_fh, 29 | ); 30 | is $code, 200, "request()"; 31 | is $msg, "OK"; 32 | is Furl::HTTP::_header_get($headers, 'Content-Length'), 33 | length($req_content); 34 | is $content, $req_content 35 | or do{ require Devel::Peek; Devel::Peek::Dump($content) }; 36 | } 37 | 38 | { 39 | open my $req_content_fh, '<', $0 or die "oops"; 40 | note 'request $0: ', -s $req_content_fh; 41 | my $req_content = do{ local $/; <$req_content_fh> }; 42 | seek $req_content_fh, 0, SEEK_SET; 43 | my ( undef, $code, $msg, $headers, $content ) = 44 | $furl->request( 45 | method => 'POST', 46 | port => $port, 47 | path_query => '/foo', 48 | host => '127.0.0.1', 49 | headers => [ "X-Foo" => "ppp" ], 50 | content => $req_content_fh, 51 | ); 52 | is $code, 200, "request()"; 53 | is $msg, "OK"; 54 | is Furl::HTTP::_header_get($headers, 'Content-Length'), 55 | length($req_content); 56 | is $content, $req_content 57 | or do{ require Devel::Peek; Devel::Peek::Dump($content) }; 58 | } 59 | 60 | done_testing; 61 | }, 62 | server => sub { 63 | my $port = shift; 64 | Plack::Loader->auto(port => $port)->run(sub { 65 | my $env = shift; 66 | #note explain $env; 67 | my $req = Plack::Request->new($env); 68 | is $req->header('X-Foo'), "ppp" if $env->{REQUEST_URI} eq '/foo'; 69 | like $req->header('User-Agent'), qr/\A Furl::HTTP /xms; 70 | return [ 200, 71 | [ 'Content-Length' => length($req->content) ], 72 | [$req->content] 73 | ]; 74 | }); 75 | } 76 | ); 77 | 78 | -------------------------------------------------------------------------------- /t/100_low/11_write_file.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | use Furl::HTTP; 4 | use Test::TCP; 5 | use Test::Requires qw(Plack::Request HTTP::Body), 'Plack'; 6 | use Plack::Loader; 7 | use Test::More; 8 | 9 | use Plack::Request; 10 | use File::Temp; 11 | use Fcntl qw/:seek/; 12 | 13 | test_tcp( 14 | client => sub { 15 | my $port = shift; 16 | my $furl = Furl::HTTP->new(); 17 | my $tmp = File::Temp->new(UNLINK => 1); 18 | my ( undef, $code, $msg, $headers, ) = 19 | $furl->request( 20 | port => $port, 21 | path_query => '/foo', 22 | host => '127.0.0.1', 23 | write_file => $tmp, 24 | ); 25 | is $code, 200, "request()"; 26 | 27 | seek $tmp, 0, SEEK_SET; 28 | my $content = do { local $/; <$tmp> }; 29 | is $content, "OK!YAY!"; 30 | 31 | done_testing; 32 | }, 33 | server => sub { 34 | my $port = shift; 35 | Plack::Loader->auto(port => $port)->run(sub { 36 | my $env = shift; 37 | my $content = "OK!YAY!"; 38 | return [ 200, 39 | [ 'Content-Length' => length($content) ], 40 | [$content] 41 | ]; 42 | }); 43 | } 44 | ); 45 | 46 | -------------------------------------------------------------------------------- /t/100_low/12_write_code.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | use Furl::HTTP; 4 | use Test::TCP; 5 | use Test::Requires qw(Plack::Request HTTP::Body), 'Plack'; 6 | use Plack::Loader; 7 | use Test::More; 8 | 9 | use Plack::Request; 10 | use File::Temp; 11 | use Fcntl qw/:seek/; 12 | 13 | test_tcp( 14 | client => sub { 15 | my $port = shift; 16 | my $furl = Furl::HTTP->new(); 17 | my $content; 18 | my ( undef, $code, $msg, $headers, ) = 19 | $furl->request( 20 | port => $port, 21 | path_query => '/foo', 22 | host => '127.0.0.1', 23 | write_code => sub { $content .= $_[3] }, 24 | ); 25 | is $code, 200, "request()"; 26 | is $content, "OK!YAY!"; 27 | 28 | done_testing; 29 | }, 30 | server => sub { 31 | my $port = shift; 32 | Plack::Loader->auto(port => $port)->run(sub { 33 | my $env = shift; 34 | my $content = "OK!YAY!"; 35 | return [ 200, 36 | [ 'Content-Length' => length($content) ], 37 | [$content] 38 | ]; 39 | }); 40 | } 41 | ); 42 | 43 | -------------------------------------------------------------------------------- /t/100_low/13_deflate.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | use Test::Requires qw(Plack::Request HTTP::Body), 'Plack'; 4 | use Test::Requires qw(Plack::Request HTTP::Body), 'Plack::Middleware::Deflater', 'Compress::Raw::Zlib'; 5 | use Furl; 6 | use Furl::HTTP; 7 | use Test::TCP; 8 | use Test::More; 9 | 10 | use Plack::Request; 11 | use File::Temp; 12 | 13 | use FindBin; 14 | use lib "$FindBin::Bin/../.."; 15 | use t::Slowloris; 16 | 17 | my $n = 10; 18 | my $CONTENT = 'OK! YAY!' x 100; 19 | test_tcp( 20 | client => sub { 21 | my $port = shift; 22 | for my $encoding (qw/gzip deflate/) { 23 | my $furl = Furl::HTTP->new( 24 | headers => ['Accept-Encoding' => $encoding], 25 | ); 26 | for(1 .. $n) { 27 | note "normal $_ $encoding"; 28 | my ( undef, $code, $msg, $headers, $content ) = 29 | $furl->request( 30 | url => "http://127.0.0.1:$port/", 31 | ); 32 | is $code, 200, "request()"; 33 | is Furl::HTTP::_header_get($headers, 'content-encoding'), $encoding; 34 | is($content, $CONTENT) or do { require Devel::Peek; Devel::Peek::Dump($content) }; 35 | } 36 | 37 | for(1 .. $n) { 38 | note "to filehandle $_ $encoding"; 39 | open my $fh, '>', \my $content; 40 | my ( undef, $code, $msg, $headers ) = 41 | $furl->request( 42 | url => "http://127.0.0.1:$port/", 43 | write_file => $fh, 44 | ); 45 | is $code, 200, "request()"; 46 | is Furl::HTTP::_header_get($headers, 'content-encoding'), $encoding; 47 | is($content, $CONTENT) or do { require Devel::Peek; Devel::Peek::Dump($content) }; 48 | } 49 | 50 | for(1 .. $n){ 51 | note "to callback $_ $encoding"; 52 | my $content = ''; 53 | my ( undef, $code, $msg, $headers ) = 54 | $furl->request( 55 | url => "http://127.0.0.1:$port/", 56 | write_code => sub { $content .= $_[3] }, 57 | ); 58 | is $code, 200, "request()"; 59 | is Furl::HTTP::_header_get($headers, 'content-encoding'), $encoding; 60 | is($content, $CONTENT) or do { require Devel::Peek; Devel::Peek::Dump($content) }; 61 | } 62 | 63 | for(1 .. $n){ 64 | note "decoded_content $_"; 65 | my $res = Furl->new( 66 | headers => ['Accept-Encoding' => $encoding] 67 | )->get("http://127.0.0.1:$port/"); 68 | 69 | ok defined($res->decoded_content); 70 | } 71 | } 72 | 73 | done_testing; 74 | }, 75 | server => sub { 76 | my $port = shift; 77 | Slowloris::Server->new( port => $port )->run( 78 | Plack::Middleware::Deflater->wrap( 79 | sub { 80 | my $env = shift; 81 | like $env->{HTTP_USER_AGENT}, qr/\A Furl::HTTP/xms; 82 | return [ 83 | 200, 84 | [ 'Content-Length' => length($CONTENT) ], 85 | [$CONTENT] 86 | ]; 87 | } 88 | ) 89 | ); 90 | } 91 | ); 92 | -------------------------------------------------------------------------------- /t/100_low/15_multiline_header.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | use Furl::HTTP; 4 | use Test::TCP; 5 | use Test::Requires qw(Plack::Request HTTP::Body), 'Plack'; 6 | use Plack::Loader; 7 | use Test::More; 8 | 9 | use Plack::Request; 10 | use File::Temp; 11 | use Fcntl qw/:seek/; 12 | 13 | test_tcp( 14 | client => sub { 15 | my $port = shift; 16 | my $furl = Furl::HTTP->new(); 17 | 18 | my ( undef, $status, $msg, $headers, $body ) = 19 | $furl->request( url => "http://127.0.0.1:$port/", headers => [ 'X-Foo' => "bar\015\012baz" ], method => 'GET' ); 20 | is $status, 200; 21 | 22 | done_testing; 23 | }, 24 | server => sub { 25 | my $port = shift; 26 | Plack::Loader->auto( port => $port )->run( 27 | sub { 28 | my $req = Plack::Request->new(shift); 29 | is $req->header('X-Foo'), "bar baz"; 30 | return [ 200, [ 'Content-Length' => 2 ], ['OK'] ]; 31 | } 32 | ); 33 | } 34 | ); 35 | -------------------------------------------------------------------------------- /t/100_low/16_read_callback.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | use Furl::HTTP; 4 | use Test::TCP; 5 | use Test::Requires qw(Plack::Request HTTP::Body), 'Plack'; 6 | use Plack::Loader; 7 | use Test::More; 8 | 9 | use Plack::Request; 10 | use Test::Requires qw(Plack::Request HTTP::Body), 'IO::Callback'; 11 | 12 | my @data = qw/foo bar baz/; 13 | 14 | test_tcp( 15 | client => sub { 16 | my $port = shift; 17 | my $furl = Furl::HTTP->new(); 18 | my $fh = 19 | IO::Callback->new( '<', 20 | sub { my $x = shift @data; $x ? "-$x" : undef } ); 21 | my ( undef, $code, $msg, $headers, $content ) = 22 | $furl->request( 23 | method => 'PUT', 24 | url => "http://127.0.0.1:$port/", 25 | headers => ['Content-Length' => length(join('', map { "-$_" } @data)) ], 26 | content => $fh, 27 | ); 28 | is $code, 200, "request()"; 29 | 30 | done_testing; 31 | }, 32 | server => sub { 33 | my $port = shift; 34 | Plack::Loader->auto(port => $port)->run(sub { 35 | my $env = shift; 36 | my $req = Plack::Request->new($env); 37 | is $req->content, "-foo-bar-baz"; 38 | return [ 200, 39 | [ 'Content-Length' => length($req->content) ], 40 | [$req->content] 41 | ]; 42 | }); 43 | } 44 | ); 45 | 46 | -------------------------------------------------------------------------------- /t/100_low/17_keep_alive.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | use Furl::HTTP; 4 | use Test::TCP; 5 | use Test::More; 6 | use FindBin; 7 | use lib "$FindBin::Bin/../.."; 8 | use t::HTTPServer; 9 | 10 | my ($stealed, $pushed) = (0, 0); 11 | { 12 | package MyConnPool; 13 | sub new { bless [], shift } 14 | sub steal { $stealed++; undef } 15 | sub push { $pushed++; undef } 16 | } 17 | 18 | test_tcp( 19 | client => sub { 20 | my $port = shift; 21 | my $furl = Furl::HTTP->new(connection_pool => MyConnPool->new()); 22 | for (1 .. 3) { 23 | note "-- TEST $_"; 24 | my ( undef, $code, $msg, $headers, $content ) = 25 | $furl->request( 26 | port => $port, 27 | path => '/', 28 | host => '127.0.0.1', 29 | ); 30 | is $code, 200; 31 | is $content, 'OK' x 100; 32 | } 33 | is $stealed, 3, 'stealed'; 34 | is $pushed, 3; 35 | 36 | $pushed = 0; 37 | $stealed = 0; 38 | 39 | $furl->request( 40 | method => 'HEAD', 41 | port => $port, 42 | path => '/', 43 | host => '127.0.0.1', 44 | ); 45 | is $pushed, 0, 'HEAD forces to close connections'; 46 | is $stealed, 1; 47 | done_testing; 48 | }, 49 | server => sub { 50 | my $port = shift; 51 | t::HTTPServer->new( port => $port )->run( 52 | sub { 53 | my $env = shift; 54 | return [ 55 | 200, 56 | [ ], 57 | [ 'OK' x 100 ] 58 | ]; 59 | } 60 | ); 61 | } 62 | ); 63 | 64 | -------------------------------------------------------------------------------- /t/100_low/18_no_proxy.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | use Furl::HTTP; 4 | use Test::TCP; 5 | use Test::Requires qw(Plack::Request HTTP::Body), 'Plack'; 6 | use Plack::Loader; 7 | use Test::More; 8 | use Plack::Request; 9 | use Test::Requires qw(Plack::Request HTTP::Body), 'HTTP::Proxy'; 10 | use Socket qw(AF_INET); 11 | 12 | plan tests => 4 + 7*3; 13 | 14 | my $verbose = 1; 15 | { 16 | package Test::HTTP::Proxy; 17 | use parent qw(HTTP::Proxy); 18 | use HTTP::Daemon; 19 | 20 | sub new { 21 | my $self = shift; 22 | my %args = @_; 23 | my %daemon_args = ( 24 | LocalAddr => '127.0.0.1', 25 | LocalPort => $args{port}, 26 | ReuseAddr => 1, 27 | Family => Socket::AF_INET, 28 | ); 29 | my $daemon = HTTP::Daemon->new(%daemon_args); 30 | $self->SUPER::new(@_, daemon => $daemon); 31 | } 32 | 33 | sub log { 34 | my($self, $level, $prefix, $msg) = @_; 35 | ::note "$prefix: $msg" if $verbose; 36 | } 37 | } 38 | 39 | { 40 | my $furl = Furl::HTTP->new; 41 | ok $furl->match_no_proxy(".google.com", "www.google.com"); 42 | ok $furl->match_no_proxy("google.com", "www.google.com"); 43 | ok $furl->match_no_proxy("google.com,.yahoo.com", "mail.yahoo.com"); 44 | ok $furl->match_no_proxy(",twitter.com , facebook.com", "www.twitter.com"); 45 | } 46 | 47 | my $via = "VIA!VIA!VIA!"; 48 | 49 | test_tcp( 50 | client => sub { 51 | my $proxy_port = shift; 52 | test_tcp( 53 | client => sub { # http client 54 | my $httpd_port = shift; 55 | for (1..3) { # run some times for testing keep-alive. 56 | my $furl = Furl::HTTP->new(proxy => "http://127.0.0.1:$proxy_port", no_proxy => "127.0.0.1"); 57 | my ( undef,$code, $msg, $headers, $content ) = 58 | $furl->request( 59 | url => "http://127.0.0.1:$httpd_port/foo", 60 | headers => [ "X-Foo" => "ppp" ] 61 | ); 62 | is $code, 200, "request()"; 63 | is $msg, "OK"; 64 | is Furl::HTTP::_header_get($headers, 'Content-Length'), 10; 65 | isnt Furl::HTTP::_header_get($headers, 'Via'), "1.0 $via", "passing through the proxy"; 66 | is $content, 'Hello, foo' 67 | or do{ require Devel::Peek; Devel::Peek::Dump($content) }; 68 | } 69 | }, 70 | server => sub { # http server 71 | my $httpd_port = shift; 72 | Plack::Loader->auto(port => $httpd_port)->run(sub { 73 | my $env = shift; 74 | 75 | my $req = Plack::Request->new($env); 76 | is $req->header('X-Foo'), "ppp" if $env->{REQUEST_URI} eq '/foo'; 77 | like $req->header('User-Agent'), qr/\A Furl::HTTP /xms; 78 | my $content = "Hello, foo"; 79 | return [ 200, 80 | [ 'Content-Length' => length($content) ], 81 | [ $content ] 82 | ]; 83 | }); 84 | }, 85 | ); 86 | }, 87 | server => sub { # proxy server 88 | my $proxy_port = shift; 89 | my $proxy = Test::HTTP::Proxy->new(port => $proxy_port, via => $via); 90 | $proxy->start(); 91 | }, 92 | ); 93 | -------------------------------------------------------------------------------- /t/100_low/19_special_headers.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | use Furl::HTTP; 4 | use Test::TCP; 5 | use Test::Requires qw(Plack::Request HTTP::Body), 'Plack'; 6 | use Plack::Loader; 7 | use Test::More; 8 | 9 | use Plack::Request; 10 | my $n = shift(@ARGV) || 3; 11 | test_tcp( 12 | client => sub { 13 | my $port = shift; 14 | my $furl = Furl::HTTP->new(bufsize => 10); 15 | for (1 .. $n) { 16 | my %special_headers = ( 17 | 'x-bar' => '', 18 | ); 19 | my ( undef, $code, $msg, $headers, $content ) = 20 | $furl->request( 21 | port => $port, 22 | path_query => '/foo', 23 | host => '127.0.0.1', 24 | headers => [ "X-Foo" => "ppp" ], 25 | special_headers => \%special_headers, 26 | ); 27 | is $code, 200, "request()/$_"; 28 | is $msg, "OK"; 29 | is $special_headers{'content-length'}, 4, 'header' 30 | or diag(explain(\%special_headers)); 31 | is $special_headers{'x-bar'}, 10; 32 | is $content, '/foo' 33 | or do{ require Devel::Peek; Devel::Peek::Dump($content) }; 34 | } 35 | 36 | done_testing; 37 | }, 38 | server => sub { 39 | my $port = shift; 40 | Plack::Loader->auto(port => $port)->run(sub { 41 | my $env = shift; 42 | #note explain $env; 43 | my $req = Plack::Request->new($env); 44 | is $req->header('X-Foo'), "ppp" if $env->{REQUEST_URI} eq '/foo'; 45 | like $req->header('User-Agent'), qr/\A Furl::HTTP /xms; 46 | return [ 200, 47 | [ 'Content-Length' => length($env->{REQUEST_URI}), 'X-Bar' => 10 ], 48 | [$env->{REQUEST_URI}] 49 | ]; 50 | }); 51 | } 52 | ); 53 | 54 | -------------------------------------------------------------------------------- /t/100_low/20_header_format_none.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | use Furl::HTTP qw/HEADERS_NONE/; 4 | use Test::TCP; 5 | use Test::Requires qw(Plack::Request HTTP::Body), 'Plack'; 6 | use Plack::Loader; 7 | use Test::More; 8 | 9 | use Plack::Request; 10 | my $n = shift(@ARGV) || 3; 11 | test_tcp( 12 | client => sub { 13 | my $port = shift; 14 | my $furl = Furl::HTTP->new( 15 | bufsize => 10, 16 | header_format => HEADERS_NONE, 17 | ); 18 | for (1 .. $n) { 19 | my %special_headers = ( 20 | 'x-bar' => '', 21 | ); 22 | my ( undef, $code, $msg, $headers, $content ) = 23 | $furl->request( 24 | port => $port, 25 | path_query => '/foo', 26 | host => '127.0.0.1', 27 | headers => [ "X-Foo" => "ppp" ], 28 | special_headers => \%special_headers, 29 | ); 30 | is $code, 200, "request()/$_"; 31 | is $msg, "OK"; 32 | is $special_headers{'content-length'}, 4, 'header' 33 | or diag(explain(\%special_headers)); 34 | is $special_headers{'x-bar'}, 10; 35 | is $content, '/foo' 36 | or do{ require Devel::Peek; Devel::Peek::Dump($content) }; 37 | is $headers, undef; 38 | } 39 | 40 | done_testing; 41 | }, 42 | server => sub { 43 | my $port = shift; 44 | Plack::Loader->auto(port => $port)->run(sub { 45 | my $env = shift; 46 | #note explain $env; 47 | my $req = Plack::Request->new($env); 48 | is $req->header('X-Foo'), "ppp" if $env->{REQUEST_URI} eq '/foo'; 49 | like $req->header('User-Agent'), qr/\A Furl::HTTP /xms; 50 | return [ 200, 51 | [ 'Content-Length' => length($env->{REQUEST_URI}), 'X-Bar' => 10 ], 52 | [$env->{REQUEST_URI}] 53 | ]; 54 | }); 55 | } 56 | ); 57 | 58 | -------------------------------------------------------------------------------- /t/100_low/21_keep_alive_timedout.t: -------------------------------------------------------------------------------- 1 | #!perl -w 2 | use strict; 3 | use warnings; 4 | use Furl::HTTP; 5 | use Test::TCP; 6 | use Test::More; 7 | use FindBin; 8 | use lib "$FindBin::Bin/../.."; 9 | use t::HTTPServer; 10 | 11 | my $n = shift(@ARGV) || 3; 12 | 13 | test_tcp( 14 | client => sub { 15 | my $port = shift; 16 | my $furl = Furl::HTTP->new(timeout => 1); 17 | for (1 .. $n) { 18 | note "request/$_"; 19 | my ( undef, $code, $msg, $headers, $content ) = 20 | $furl->request( 21 | port => $port, 22 | path_query => '/foo', 23 | host => '127.0.0.1', 24 | ); 25 | is $code, 200, "request()/$_"; 26 | is $msg, "OK"; 27 | is Furl::HTTP::_header_get($headers, 'Content-Length'), 2, 'header' 28 | or diag(explain($headers)); 29 | is Furl::HTTP::_header_get($headers, 'Connection'), 'keep-alive'; 30 | is $content, 'OK' 31 | or do{ require Devel::Peek; Devel::Peek::Dump($content) }; 32 | } 33 | done_testing; 34 | }, 35 | server => sub { 36 | my $port = shift; 37 | t::HTTPServer->new( port => $port )->add_trigger( 38 | "AFTER_HANDLE_REQUEST" => sub { 39 | my ( $s, $csock ) = @_; 40 | $csock->close(); 41 | } 42 | )->run( 43 | sub { 44 | +[ 45 | 200, 46 | [ 'Content-Length' => 2, 'Connection' => 'keep-alive' ], 47 | ['OK'] 48 | ]; 49 | } 50 | ); 51 | } 52 | ); 53 | 54 | -------------------------------------------------------------------------------- /t/100_low/22_keep_alive.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | 4 | use Furl::HTTP; 5 | use Socket (); 6 | use Test::More; 7 | use Test::Requires 'Starlet::Server', 'Plack::Loader'; 8 | use Test::TCP; 9 | 10 | { 11 | no warnings 'redefine'; 12 | my $orig = *Starlet::Server::_get_acceptor{CODE}; 13 | *Starlet::Server::_get_acceptor = sub { 14 | my $acceptor = shift->$orig(@_); 15 | return sub { 16 | my ($conn, $peer, $listen) = $acceptor->(); 17 | if ($conn) { 18 | setsockopt($conn, Socket::SOL_SOCKET, Socket::SO_LINGER, pack('ii', 1, 0)) 19 | or warn "failed to set SO_LINGER: $!"; 20 | return ($conn, $peer, $listen); 21 | } else { 22 | return (); 23 | } 24 | } 25 | }; 26 | } 27 | 28 | test_tcp( 29 | client => sub { 30 | my $port = shift; 31 | my $furl = Furl::HTTP->new(timeout => 1); 32 | my ($code, $msg); 33 | (undef, $code, $msg) = $furl->request(port => $port, host => '127.0.0.1'); 34 | is $code, 200; 35 | is $msg, 'OK'; 36 | sleep 2; 37 | (undef, $code, $msg) = $furl->request(port => $port, host => '127.0.0.1'); 38 | is $code, 200; 39 | is $msg, 'OK'; 40 | }, 41 | server => sub { 42 | my $port = shift; 43 | my %args = ( 44 | port => $port, 45 | keepalive_timeout => 1, 46 | max_keepalive_reqs => 100, 47 | max_reqs_per_child => 100, 48 | max_workers => 1, 49 | ); 50 | my $app = sub { [200, ['Content-Length' => 2], ['ok']] }; 51 | Plack::Loader->load('Starlet', %args)->run($app); 52 | exit; 53 | }, 54 | ); 55 | 56 | done_testing; 57 | -------------------------------------------------------------------------------- /t/100_low/22_keep_alive_http10.t: -------------------------------------------------------------------------------- 1 | #!perl -w 2 | use strict; 3 | use warnings; 4 | use Test::Requires { 5 | 'Plack::Request' => 0, 6 | 'HTTP::Body' => 0, 7 | Starlet => 0.11 8 | }; 9 | use Furl::HTTP; 10 | use Test::TCP; 11 | use Test::More; 12 | 13 | use Starlet::Server; 14 | 15 | my $n = shift(@ARGV) || 3; 16 | 17 | my $host = '127.0.0.1'; 18 | 19 | test_tcp( 20 | client => sub { 21 | my $port = shift; 22 | my $furl = Furl::HTTP->new(); 23 | for (1 .. $n) { 24 | note "request/$_"; 25 | my ( undef, $code, $msg, $headers, $content ) = 26 | $furl->request( 27 | host => $host, 28 | port => $port, 29 | path_query => '/foo', 30 | ); 31 | is $code, 200, "request()/$_"; 32 | is $msg, "OK"; 33 | is Furl::HTTP::_header_get($headers, 'Content-Length'), 4, 'header' 34 | or diag(explain($headers)); 35 | is Furl::HTTP::_header_get($headers, 'Connection'), 'keep-alive' 36 | or diag(explain($headers)); 37 | is $content, '/foo' 38 | or do{ require Devel::Peek; Devel::Peek::Dump($content) }; 39 | 40 | ok defined( $furl->{connection_pool}->steal($host, $port) ), 'in keep-alive'; 41 | } 42 | done_testing; 43 | }, 44 | server => sub { 45 | my $port = shift; 46 | Starlet::Server->new( 47 | host => $host, 48 | port => $port, 49 | max_keepalive_reqs => 10, 50 | )->run(sub { 51 | my $env = shift; 52 | $env->{SERVER_PROTOCOL} = 'HTTP/1.0'; #force response HTTP/1.0 53 | return [ 200, 54 | [ 'Content-Length' => length($env->{REQUEST_URI}) ], 55 | [$env->{REQUEST_URI}] 56 | ]; 57 | }); 58 | } 59 | ); 60 | 61 | -------------------------------------------------------------------------------- /t/100_low/23_redirect_relative.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | use Furl::HTTP; 4 | use Test::TCP; 5 | use Test::Requires qw(Plack::Request HTTP::Body), 'Plack'; 6 | use Plack::Loader; 7 | use Test::More; 8 | use Test::Requires qw(Plack::Request HTTP::Body), 'URI'; 9 | 10 | use Plack::Request; 11 | 12 | test_tcp( 13 | client => sub { 14 | my $port = shift; 15 | 16 | subtest 'redirect' => sub { 17 | my $furl = Furl::HTTP->new(); 18 | my ( undef, $code, $msg, $headers, $content ) = $furl->request( url => "http://127.0.0.1:$port/foo/" ); 19 | is $code, 200; 20 | is $msg, "OK"; 21 | is Furl::HTTP::_header_get($headers, 'Content-Length'), 2; 22 | is $content, 'OK'; 23 | }; 24 | 25 | subtest 'redirect to root' => sub { 26 | my $furl = Furl::HTTP->new(max_redirects => 0); 27 | my ( undef, $code, $msg, $headers, $content ) = $furl->request( url => "http://127.0.0.1:$port/baz/" ); 28 | is $code, 302; 29 | is $msg, "Found"; 30 | is Furl::HTTP::_header_get($headers, 'location'), "/foo/"; 31 | }; 32 | 33 | done_testing; 34 | }, 35 | server => sub { 36 | my $port = shift; 37 | Plack::Loader->auto(port => $port)->run(sub { 38 | my $env = shift; 39 | my $req = Plack::Request->new($env); 40 | if ($env->{PATH_INFO} eq '/foo/bar') { 41 | return [ 200, [ 'Content-Length' => 2 ], ['OK'] ]; 42 | } elsif ($env->{PATH_INFO} eq '/baz/') { 43 | return [ 302, [ 'Location' => '/foo/', 'Content-Length' => 0 ], 44 | [] ]; 45 | } else { 46 | return [ 302, [ 'Location' => './bar', 'Content-Length' => 0 ], 47 | [] ]; 48 | } 49 | }); 50 | } 51 | ); 52 | 53 | -------------------------------------------------------------------------------- /t/100_low/24_no_content.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | use Test::More; 4 | use Furl::HTTP; 5 | use Test::TCP; 6 | use FindBin; 7 | use lib "$FindBin::Bin/../.."; 8 | use t::HTTPServer; 9 | 10 | my $n = shift(@ARGV) || 3; 11 | test_tcp( 12 | client => sub { 13 | my $port = shift; 14 | my $furl = Furl::HTTP->new(bufsize => 10, timeout => 3); 15 | for (1 .. $n) { 16 | my ( undef, $code, $msg, $headers, $content ) = 17 | $furl->request( 18 | port => $port, 19 | path_query => '/foo', 20 | host => '127.0.0.1', 21 | content => '', 22 | ); 23 | is $code, 200, "request()/$_"; 24 | is $msg, "OK"; 25 | } 26 | 27 | done_testing; 28 | }, 29 | server => sub { 30 | my $port = shift; 31 | t::HTTPServer->new(port => $port)->run(sub {; 32 | my $env = shift; 33 | return [ 200, 34 | [ 'Content-Length' => length($env->{REQUEST_URI}) ], 35 | [$env->{REQUEST_URI}] 36 | ]; 37 | }); 38 | } 39 | ); 40 | 41 | 42 | -------------------------------------------------------------------------------- /t/100_low/25_signal.t: -------------------------------------------------------------------------------- 1 | # to test "stop_if" 2 | use strict; 3 | use warnings; 4 | use Furl::HTTP; 5 | use Test::TCP; 6 | use Test::More; 7 | use FindBin; 8 | use lib "$FindBin::Bin/../.."; 9 | use t::HTTPServer; 10 | 11 | plan skip_all => "Win32 is not supported" if Furl::HTTP::WIN32; 12 | 13 | my $n = shift(@ARGV) || 3; 14 | test_tcp( 15 | client => sub { 16 | my $port = shift; 17 | my $stop_if = 0; 18 | my $furl = Furl::HTTP->new( 19 | bufsize => 10, 20 | stop_if => sub { $stop_if }, 21 | ); 22 | local $SIG{ALRM} = sub { 23 | note "caught ALRM"; 24 | }; 25 | for (1 .. $n) { 26 | note "try it $_ with stop_if=false"; 27 | # ignore signal 28 | $stop_if = undef; 29 | alarm(2); 30 | my ($undef, $code, $msg, $headers, $content) = 31 | $furl->request( 32 | port => $port, 33 | path_query => '/', 34 | host => '127.0.0.1', 35 | ); 36 | is $code, 200, "ignore signal ($_)"; 37 | alarm(0); 38 | sleep(4); # wait until the server stops handling the request 39 | # cancel on signal 40 | note "try it $_ with stop_if=true"; 41 | $stop_if = 1; 42 | alarm(2); 43 | ($undef, $code, $msg, $headers, $content) = 44 | $furl->request( 45 | port => $port, 46 | path_query => '/5', 47 | host => '127.0.0.1', 48 | ); 49 | is $code, 500, "cancelled ($_)"; 50 | alarm(0); 51 | sleep(4); # wait until the server stops handling the request 52 | } 53 | done_testing; 54 | }, 55 | server => sub { 56 | my $port = shift; 57 | t::HTTPServer->new(port => $port)->run(sub { 58 | my $env = shift; 59 | sleep(4); 60 | return [ 61 | 200, 62 | [ 63 | 'Content-Type' => 'text/plain', 64 | 'Content-Length' => 5, 65 | ], 66 | [ 'hello' ], 67 | ]; 68 | }); 69 | }, 70 | ); 71 | -------------------------------------------------------------------------------- /t/100_low/26_headers_only.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | use HTTP::Parser::XS qw(parse_http_request); 4 | use IO::Socket::INET; 5 | use Test::More; 6 | use Furl::HTTP; 7 | use Test::TCP; 8 | 9 | my $n = shift(@ARGV) || 3; 10 | test_tcp( 11 | client => sub { 12 | my $port = shift; 13 | my $furl = Furl::HTTP->new( 14 | bufsize => 10, 15 | timeout => 3, 16 | ); 17 | for my $req_code (qw(199 204 304)) { 18 | for (1 .. $n) { 19 | my (undef, $code, $msg, $headers, $content) = $furl->request( 20 | port => $port, 21 | path_query => "/$req_code", 22 | host => '127.0.0.1', 23 | ); 24 | if ($req_code ne 199) { 25 | is $code, $req_code, "$msg"; 26 | is $content, ''; 27 | } else { 28 | is $code, 200, "$msg"; 29 | is $content, 'you will see this message!'; 30 | } 31 | } 32 | } 33 | }, 34 | server => sub { 35 | my $port = shift; 36 | my $listen_sock = IO::Socket::INET->new( 37 | Listen => 5, 38 | LocalHost => '127.0.0.1', 39 | LocalPort => $port, 40 | ReuseAddr => 1, 41 | ) or die $!; 42 | MAIN_LOOP: 43 | while (1) { 44 | my $sock = $listen_sock->accept 45 | or next; 46 | my $buf = ''; 47 | my %env; 48 | PARSE_HTTP_REQUEST: 49 | while (1) { 50 | my $nread = sysread( 51 | $sock, $buf, 1048576, length($buf)); 52 | $buf =~ s!^(\015\012)*!!; 53 | if (! defined $nread) { 54 | die "cannot read HTTP request header: $!"; 55 | } 56 | if ($nread == 0) { 57 | # unexpected EOF while reading HTTP request header 58 | warn "received a broken HTTP request"; 59 | next MAIN_LOOP; 60 | } 61 | my $ret = parse_http_request($buf, \%env); 62 | if ($ret == -2) { # incomplete. 63 | next; 64 | } 65 | elsif ($ret == -1) { # request is broken 66 | die "broken HTTP header"; 67 | } 68 | else { 69 | $buf = substr($buf, $ret); 70 | last PARSE_HTTP_REQUEST; 71 | } 72 | } 73 | my $code = $env{PATH_INFO} =~ m{^/([0-9]+)$} ? $1 : 200; 74 | if ((int $code / 100) ne 1) { 75 | print $sock '', << "EOT"; 76 | HTTP/1.0 $code love\r 77 | Connection: close\r 78 | Content-Length: 100\r 79 | \r 80 | you shall never see this message! 81 | EOT 82 | } else { 83 | print $sock '', << "EOT"; 84 | HTTP/1.0 $code love\r 85 | \r 86 | HTTP/1.0 200 OK\r 87 | Content-Length: 26\r 88 | \r 89 | you will see this message! 90 | EOT 91 | } 92 | close $sock; 93 | } 94 | }, 95 | ); 96 | 97 | done_testing; 98 | -------------------------------------------------------------------------------- /t/100_low/27_close_on_eof.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | 4 | use Furl::HTTP; 5 | use IO::Socket::INET; 6 | use Test::More; 7 | use Test::TCP; 8 | 9 | test_tcp( 10 | client => sub { 11 | my $port = shift; 12 | my (undef, $code, undef, undef, $body) = Furl::HTTP->new->request( 13 | method => 'GET', 14 | host => '127.0.0.1', 15 | port => $port, 16 | path => '/', 17 | ); 18 | is $code, 200, 'code'; 19 | is $body, 'abcde', 'body'; 20 | }, 21 | server => sub { 22 | my $port = shift; 23 | my $listen_sock = IO::Socket::INET->new( 24 | Listen => 5, 25 | LocalHost => '127.0.0.1', 26 | LocalPort => $port, 27 | ReuseAddr => 1, 28 | ) or die $!; 29 | local $SIG{PIPE} = 'IGNORE'; 30 | while (1) { 31 | my $sock = $listen_sock->accept 32 | or next; 33 | sysread($sock, my $buf, 1048576, 0); # read request 34 | syswrite $sock, join( 35 | "\r\n", 36 | "HTTP/1.0 200 OK", 37 | "Content-Type: text/plain", 38 | "", 39 | "abcde", 40 | ); 41 | close $sock; 42 | } 43 | }, 44 | ); 45 | 46 | done_testing; 47 | -------------------------------------------------------------------------------- /t/100_low/28_idn.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | 4 | use Furl::HTTP; 5 | use FindBin; 6 | use lib "$FindBin::Bin/../.."; 7 | use t::HTTPServer; 8 | use Test::TCP; 9 | use Test::More; 10 | use Test::Requires qw(Plack::Request HTTP::Body), 'Net::IDN::Encode'; 11 | 12 | sub test_uses_idn { 13 | my %specs = @_; 14 | my ($host, $expects, $desc) = @specs{qw/host expects desc/}; 15 | 16 | subtest $desc => sub { 17 | test_tcp( 18 | client => sub { 19 | my $port = shift; 20 | my $furl = Furl::HTTP->new(timeout => 0.3); 21 | my $used = 0; 22 | no warnings 'redefine'; 23 | local *Net::IDN::Encode::domain_to_ascii = sub { 24 | $used = 1; 25 | return '127.0.0.1', 26 | }; 27 | my (undef, $code, $msg, $headers, $content) = $furl->request( 28 | port => $port, 29 | path_query => '/', 30 | host => $host, 31 | ); 32 | is $used, $expects, 'result'; 33 | }, 34 | server => sub { 35 | my $port = shift; 36 | t::HTTPServer->new(port => $port)->run(sub { 37 | my $env = shift; 38 | return [200, [], ['OK']]; 39 | }); 40 | }, 41 | ); 42 | }; 43 | } 44 | 45 | test_uses_idn( 46 | host => '127.0.0.1', 47 | expects => 0, 48 | desc => 'local host', 49 | ); 50 | 51 | test_uses_idn( 52 | host => '例え.テスト', 53 | expects => 1, 54 | desc => 'uses idn', 55 | ); 56 | 57 | test_uses_idn( 58 | host => '127.0.0._', 59 | expects => 0, 60 | desc => 'in underscore', 61 | ); 62 | 63 | done_testing; 64 | -------------------------------------------------------------------------------- /t/100_low/29_completion_slash.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | use Furl::HTTP; 4 | use Test::TCP; 5 | use Test::More; 6 | use FindBin; 7 | use lib "$FindBin::Bin/../.."; 8 | use t::HTTPServer; 9 | 10 | my $server = sub { 11 | my $port = shift; 12 | t::HTTPServer->new(port => $port)->run(sub { 13 | my $env = shift; 14 | return [ 15 | 200, 16 | [ 'Content-Length' => length($env->{REQUEST_URI}) ], 17 | [ $env->{REQUEST_URI} ], 18 | ]; 19 | }); 20 | }; 21 | 22 | note '/foo => /foo'; 23 | test_tcp( 24 | server => $server, 25 | client => sub { 26 | my $port = shift; 27 | my $furl = Furl::HTTP->new(bufsize => 10, timeout => 3); 28 | 29 | do { 30 | my (undef, $code, $msg, $headers, $content) = $furl->request( 31 | port => $port, 32 | path_query => '/foo', 33 | host => '127.0.0.1', 34 | ); 35 | is $code, 200, "code"; 36 | is $msg, "OK" , "msg"; 37 | is $content, "/foo", "return path query"; 38 | }; 39 | 40 | do { 41 | my $path_query = '/foo'; 42 | my ( undef, $code, $msg, $headers, $content ) = $furl->request( 43 | url => "http://127.0.0.1:$port$path_query", 44 | method => 'GET', 45 | ); 46 | is $code, 200, 'code'; 47 | is $msg, 'OK', 'msg'; 48 | is $content, '/foo'; 49 | }; 50 | }, 51 | ); 52 | 53 | note 'foo => /foo'; 54 | test_tcp( 55 | server => $server, 56 | client => sub { 57 | my $port = shift; 58 | my $furl = Furl::HTTP->new(bufsize => 10, timeout => 3); 59 | 60 | do { 61 | my (undef, $code, $msg, $headers, $content) = $furl->request( 62 | port => $port, 63 | path_query => 'foo', 64 | host => '127.0.0.1', 65 | ); 66 | is $code, 200, 'code'; 67 | is $msg, 'OK' , 'msg'; 68 | is $content, '/foo', 'return path query'; 69 | }; 70 | }, 71 | ); 72 | 73 | note '/?foo=bar => /?foo=bar'; 74 | test_tcp( 75 | server => $server, 76 | client => sub { 77 | my $port = shift; 78 | my $furl = Furl::HTTP->new(bufsize => 10, timeout => 3); 79 | 80 | do { 81 | my (undef, $code, $msg, $headers, $content) = $furl->request( 82 | port => $port, 83 | path_query => '/?foo=bar', 84 | host => '127.0.0.1', 85 | ); 86 | is $code, 200, 'code'; 87 | is $msg, 'OK' , 'msg'; 88 | is $content, '/?foo=bar', 'return path query'; 89 | }; 90 | 91 | do { 92 | my $path_query = '/?foo=bar'; 93 | my ( undef, $code, $msg, $headers, $content ) = $furl->request( 94 | url => "http://127.0.0.1:$port$path_query", 95 | method => 'GET', 96 | ); 97 | is $code, 200, 'code'; 98 | is $msg, 'OK', 'msg'; 99 | is $content, '/?foo=bar'; 100 | }; 101 | }, 102 | ); 103 | 104 | note '?foo=bar => /?foo=bar'; 105 | test_tcp( 106 | server => $server, 107 | client => sub { 108 | my $port = shift; 109 | my $furl = Furl::HTTP->new(bufsize => 10, timeout => 3); 110 | 111 | do { 112 | my (undef, $code, $msg, $headers, $content) = $furl->request( 113 | port => $port, 114 | path_query => '?foo=bar', 115 | host => '127.0.0.1', 116 | ); 117 | is $code, 200, "code"; 118 | is $msg, "OK" , "msg"; 119 | is $content, "/?foo=bar", "return path query"; 120 | }; 121 | 122 | do { 123 | my $path_query = '?foo=bar'; 124 | my ( undef, $code, $msg, $headers, $content ) = $furl->request( 125 | url => "http://127.0.0.1:$port$path_query", 126 | method => 'GET', 127 | ); 128 | is $code, 200, 'code'; 129 | is $msg, 'OK', 'msg'; 130 | is $content, '/?foo=bar'; 131 | }; 132 | }, 133 | ); 134 | 135 | done_testing; 136 | -------------------------------------------------------------------------------- /t/100_low/30_user_agent.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | use Furl::HTTP; 4 | use Test::TCP; 5 | use Test::More; 6 | use FindBin; 7 | use lib "$FindBin::Bin/../.."; 8 | use t::HTTPServer; 9 | 10 | test_tcp( 11 | client => sub { 12 | my $port = shift; 13 | 14 | subtest 'set agent' => sub { 15 | my $furl = Furl::HTTP->new(); 16 | $furl->agent('foobot'); 17 | my ( undef, $code, $msg, $headers, $content ) = 18 | $furl->request( url => "http://127.0.0.1:$port/1", ); 19 | is $code, 200; 20 | is $content, 'foobot'; 21 | }; 22 | 23 | subtest 'set agent at request' => sub { 24 | my $furl = Furl::HTTP->new(); 25 | my ( undef, $code, $msg, $headers, $content ) = 26 | $furl->request( 27 | url => "http://127.0.0.1:$port/2", 28 | headers => [ "User-Agent" => "foobot" ] 29 | ); 30 | is $code, 200; 31 | like $content, qr/\A Furl::HTTP\/[^,]+,\sfoobot /xms; 32 | }; 33 | 34 | subtest 'set agent and request with agent' => sub { 35 | my $furl = Furl::HTTP->new(); 36 | $furl->agent('foobot'); 37 | my ( undef, $code, $msg, $headers, $content ) = 38 | $furl->request( 39 | url => "http://127.0.0.1:$port/3", 40 | headers => [ "User-Agent" => "barbot" ] 41 | ); 42 | is $code, 200; 43 | is $content, 'foobot, barbot'; 44 | }; 45 | }, 46 | server => sub { 47 | my $port = shift; 48 | t::HTTPServer->new(port => $port)->run(sub { 49 | my $env = shift; 50 | return [ 200, 51 | [ 'Content-Length' => length($env->{'HTTP_USER_AGENT'}) ], 52 | [$env->{'HTTP_USER_AGENT'}] 53 | ]; 54 | }); 55 | } 56 | ); 57 | 58 | done_testing; 59 | 60 | -------------------------------------------------------------------------------- /t/100_low/31_chunked_unexpected_eof.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | 4 | use Furl::HTTP; 5 | use IO::Socket::INET; 6 | use Test::More; 7 | use Test::TCP; 8 | 9 | my $chunk = "x"x1024; 10 | my @res; 11 | for ( 1..20) { 12 | push @res, '400', $chunk; 13 | } 14 | 15 | test_tcp( 16 | client => sub { 17 | my $port = shift; 18 | my (undef, $code, undef, undef, $body) = Furl::HTTP->new->request( 19 | method => 'GET', 20 | host => '127.0.0.1', 21 | port => $port, 22 | path => '/', 23 | ); 24 | is $code, 500, 'code'; 25 | like $body, qr/Unexpected EOF/, 'body'; 26 | }, 27 | server => sub { 28 | my $port = shift; 29 | my $listen_sock = IO::Socket::INET->new( 30 | Listen => 5, 31 | LocalHost => '127.0.0.1', 32 | LocalPort => $port, 33 | ReuseAddr => 1, 34 | ) or die $!; 35 | local $SIG{PIPE} = 'IGNORE'; 36 | while (1) { 37 | my $sock = $listen_sock->accept 38 | or next; 39 | sysread($sock, my $buf, 1048576, 0); # read request 40 | my $n = syswrite $sock, join( 41 | "\r\n", 42 | "HTTP/1.1 200 OK", 43 | "Content-Type: text/plain", 44 | "Transfer-Encoding: chunked", 45 | "Connection: close", 46 | "", 47 | @res, 48 | "5", 49 | ); 50 | close $sock; 51 | } 52 | }, 53 | ); 54 | 55 | 56 | 57 | done_testing; 58 | -------------------------------------------------------------------------------- /t/100_low/32_proxy_auth.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | use Furl::HTTP; 4 | use Test::TCP; 5 | use Test::Requires qw(Plack::Request HTTP::Body MIME::Base64 HTTP::Proxy::HeaderFilter::simple HTTP::Proxy URI::Escape); 6 | use Plack::Loader; 7 | use Test::More; 8 | use Plack::Request; 9 | use MIME::Base64 qw/encode_base64/; 10 | use Socket qw(AF_INET); 11 | 12 | plan tests => 7*6; 13 | 14 | my $verbose = 1; 15 | { 16 | package Test::HTTP::Proxy; 17 | use parent qw(HTTP::Proxy); 18 | use HTTP::Daemon; 19 | 20 | sub new { 21 | my $self = shift; 22 | my %args = @_; 23 | my %daemon_args = ( 24 | LocalAddr => '127.0.0.1', 25 | LocalPort => $args{port}, 26 | ReuseAddr => 1, 27 | Family => Socket::AF_INET, 28 | ); 29 | my $daemon = HTTP::Daemon->new(%daemon_args); 30 | $self->SUPER::new(@_, daemon => $daemon); 31 | } 32 | 33 | sub log { 34 | my($self, $level, $prefix, $msg) = @_; 35 | ::note "$prefix: $msg" if $verbose; 36 | } 37 | } 38 | 39 | my $via = "VIA!VIA!VIA!"; 40 | 41 | local $ENV{'HTTP_PROXY'} = ''; 42 | test_tcp( 43 | client => sub { 44 | my $proxy_port = shift; 45 | test_tcp( 46 | client => sub { # http client 47 | my $httpd_port = shift; 48 | for (1..3) { # run some times for testing keep-alive. 49 | my $furl = Furl::HTTP->new(proxy => "http://dankogai:kogaidan\@127.0.0.1:$proxy_port"); 50 | my ( undef, $code, $msg, $headers, $content ) = 51 | $furl->request( 52 | url => "http://127.0.0.1:$httpd_port/foo", 53 | headers => [ "X-Foo" => "ppp" ] 54 | ); 55 | is $code, 200, "request()"; 56 | is $msg, "OK"; 57 | is Furl::HTTP::_header_get($headers, 'Content-Length'), 10; 58 | is Furl::HTTP::_header_get($headers, 'Via'), "1.0 $via"; 59 | is $content, 'Hello, foo' 60 | or do{ require Devel::Peek; Devel::Peek::Dump($content) }; 61 | } 62 | for (4..6) { # run some times for testing keep-alive. 63 | my $furl = Furl::HTTP->new(proxy => "http://dan%40kogai:kogai%2Fdan\@127.0.0.1:$proxy_port"); 64 | my ( undef, $code, $msg, $headers, $content ) = 65 | $furl->request( 66 | url => "http://127.0.0.1:$httpd_port/escape", 67 | headers => [ "X-Foo" => "qqq" ] 68 | ); 69 | is $code, 200, "request()"; 70 | is $msg, "OK"; 71 | is Furl::HTTP::_header_get($headers, 'Content-Length'), 10; 72 | is Furl::HTTP::_header_get($headers, 'Via'), "1.0 $via"; 73 | is $content, 'Hello, foo' 74 | or do{ require Devel::Peek; Devel::Peek::Dump($content) }; 75 | } 76 | }, 77 | server => sub { # http server 78 | my $httpd_port = shift; 79 | Plack::Loader->auto(port => $httpd_port)->run(sub { 80 | my $env = shift; 81 | 82 | my $req = Plack::Request->new($env); 83 | is $req->header('X-Foo'), "ppp" if $env->{REQUEST_URI} eq '/foo'; 84 | is $req->header('X-Foo'), "qqq" if $env->{REQUEST_URI} eq '/escape'; 85 | like $req->header('User-Agent'), qr/\A Furl::HTTP /xms; 86 | my $content = "Hello, foo"; 87 | return [ 200, 88 | [ 'Content-Length' => length($content) ], 89 | [ $content ] 90 | ]; 91 | }); 92 | }, 93 | ); 94 | }, 95 | server => sub { # proxy server 96 | my $proxy_port = shift; 97 | my $proxy = Test::HTTP::Proxy->new(port => $proxy_port, via => $via); 98 | my $token_simple = "Basic " . encode_base64( "dankogai:kogaidan", "" ); 99 | my $token_escape = "Basic " . encode_base64( 'dan@kogai:kogai/dan', "" ); 100 | $proxy->push_filter( 101 | request => HTTP::Proxy::HeaderFilter::simple->new( 102 | sub { 103 | my ( $self, $headers, $request ) = @_; 104 | my $auth = $self->proxy->hop_headers->header('Proxy-Authorization') || ''; 105 | 106 | my $request_uri = $request->uri->as_string; 107 | my $token = $request_uri =~ m{/escape$} ? $token_escape : $token_simple; 108 | # check the credentials 109 | if ( $auth ne $token ) { 110 | my $response = HTTP::Response->new(407); 111 | $response->header( Proxy_Authenticate => 'Basic realm= 112 | +"HTTP::Proxy"' ); 113 | $self->proxy->response($response); 114 | } 115 | } 116 | ) 117 | ); 118 | $proxy->start(); 119 | }, 120 | ); 121 | -------------------------------------------------------------------------------- /t/100_low/33_basic_auth.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | use Furl::HTTP; 4 | use Test::TCP; 5 | use Test::More; 6 | use Test::Requires 'URI::Escape'; 7 | use FindBin; 8 | use lib "$FindBin::Bin/../.."; 9 | use t::HTTPServer; 10 | 11 | my $n = shift(@ARGV) || 3; 12 | test_tcp( 13 | client => sub { 14 | my $port = shift; 15 | my $furl = Furl::HTTP->new(bufsize => 10, timeout => 3); 16 | for (1 .. $n) { 17 | my ( undef, $code, $msg, $headers, $content ) = 18 | $furl->request( 19 | url => "http://dankogai:kogaidan\@127.0.0.1:${port}/foo", 20 | ); 21 | is $code, 200, "request()/$_"; 22 | is $msg, "OK"; 23 | is Furl::HTTP::_header_get($headers, 'Content-Length'), 4, 'header' 24 | or diag(explain($headers)); 25 | is $content, '/foo' 26 | or do{ require Devel::Peek; Devel::Peek::Dump($content) }; 27 | } 28 | for ($n + 1 .. $n + $n) { 29 | my ( undef, $code, $msg, $headers, $content ) = 30 | $furl->request( 31 | url => "http://dan%40kogai:kogai%2Fdan\@127.0.0.1:${port}/escape", 32 | ); 33 | is $code, 200, "request()/$_"; 34 | is $msg, "OK"; 35 | is Furl::HTTP::_header_get($headers, 'Content-Length'), 7, 'header' 36 | or diag(explain($headers)); 37 | is $content, '/escape' 38 | or do{ require Devel::Peek; Devel::Peek::Dump($content) }; 39 | } 40 | 41 | done_testing; 42 | }, 43 | server => sub { 44 | my $port = shift; 45 | my $basic = 'ZGFua29nYWk6a29nYWlkYW4='; 46 | t::HTTPServer->new(port => $port)->run(sub {; 47 | my $env = shift; 48 | if ($env->{REQUEST_URI} eq '/escape') { 49 | $basic = 'ZGFuQGtvZ2FpOmtvZ2FpL2Rhbg=='; 50 | } 51 | is($env->{HTTP_AUTHORIZATION}, 'Basic ' . $basic); 52 | return [ 200, 53 | [ 'Content-Length' => length($env->{REQUEST_URI}) ], 54 | [$env->{REQUEST_URI}] 55 | ]; 56 | }); 57 | } 58 | ); 59 | 60 | -------------------------------------------------------------------------------- /t/100_low/34_keep_request.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | use Furl::HTTP; 4 | use Furl::Request; 5 | use Test::TCP; 6 | use Test::More; 7 | use FindBin; 8 | use lib "$FindBin::Bin/../.."; 9 | use t::HTTPServer; 10 | 11 | test_tcp( 12 | client => sub { 13 | my $port = shift; 14 | 15 | subtest 'return request info' => sub { 16 | my $furl = Furl::HTTP->new(capture_request => 1); 17 | my @res = $furl->request( url => "http://127.0.0.1:$port/1", ); 18 | 19 | my ( 20 | $res_minor_version, 21 | $res_status, 22 | $res_msg, 23 | $res_headers, 24 | $res_content, 25 | $captured_req_headers, 26 | $captured_req_content, 27 | $captured_res_headers, 28 | $captured_res_content, 29 | $request_info, 30 | ) = @res; 31 | my $req = Furl::Request->parse($captured_req_headers . $captured_req_content); 32 | 33 | is $req->method, 'GET'; 34 | is $req->uri, "http://127.0.0.1:$port/1"; 35 | }; 36 | }, 37 | server => sub { 38 | my $port = shift; 39 | t::HTTPServer->new(port => $port)->run(sub { 40 | my $env = shift; 41 | return [ 200, 42 | [ 'Content-Length' => length('keep request') ], 43 | [ 'keep request' ] 44 | ]; 45 | }); 46 | } 47 | ); 48 | 49 | done_testing; 50 | 51 | -------------------------------------------------------------------------------- /t/100_low/35_get_address.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | use Socket qw(inet_aton pack_sockaddr_in); 4 | use Test::More; 5 | use Test::TCP; 6 | 7 | use Furl::HTTP; 8 | use FindBin; 9 | use lib "$FindBin::Bin/../.."; 10 | use t::HTTPServer; 11 | 12 | test_tcp( 13 | client => sub { 14 | my $serverPort = shift; 15 | my $furl = Furl::HTTP->new( 16 | get_address => sub { 17 | my ($host, $port, $timeout) = @_; 18 | is $host, "nowhere.example.com", "get_address:hostname"; 19 | is $port, 80, "get_address:port"; 20 | return pack_sockaddr_in($serverPort, inet_aton("127.0.0.1")); 21 | }, 22 | ); 23 | my ($minor_version, $code, $msg, $headers, $body) = $furl->request( 24 | method => "GET", 25 | host => "nowhere.example.com", 26 | port => 80, 27 | path_query => "/abc", 28 | ); 29 | is $code, 200, "status code"; 30 | is $body, "hello furl", "content"; 31 | }, 32 | server => sub { 33 | my $port = shift; 34 | ok "yes"; 35 | t::HTTPServer->new(port => $port)->run(sub { 36 | my $env = shift; 37 | return [ 200, 38 | [], 39 | [ "hello furl" ] 40 | ]; 41 | }); 42 | } 43 | ); 44 | 45 | done_testing; 46 | -------------------------------------------------------------------------------- /t/100_low/36_inactivity_timeout.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | use Socket qw(inet_aton pack_sockaddr_in); 4 | use Test::More; 5 | use Test::TCP; 6 | use Test::Requires qw(HTTP::Server::PSGI); 7 | 8 | use Furl::HTTP; 9 | use FindBin; 10 | use lib "$FindBin::Bin/../.."; 11 | use t::Slowloris; 12 | 13 | test_tcp( 14 | server => sub { 15 | my $port = shift; 16 | $Slowloris::SleepBeforeWrite = 1; 17 | Slowloris::Server->new(port => $port)->run(sub { 18 | my $env = shift; 19 | return [ 200, 20 | [], 21 | [ "hello" ] 22 | ]; 23 | }); 24 | }, 25 | client => sub { 26 | my $port = shift; 27 | 28 | # should not timeout 29 | my $furl = Furl::HTTP->new( 30 | timeout => 10, 31 | inactivity_timeout => 10, 32 | ); 33 | my $start = time; 34 | my ($minor_version, $code, $msg, $headers, $body) = $furl->request( 35 | method => "GET", 36 | host => "127.0.0.1", 37 | port => $port, 38 | path_query => "/", 39 | ); 40 | is $code, 200, "status code:inactivity_timeout=10"; 41 | is $body, "hello", "content:inactivity_timeout=10"; 42 | diag "took @{[time - $start]} seconds"; 43 | 44 | # should timeout 45 | $furl = Furl::HTTP->new( 46 | timeout => 10, 47 | inactivity_timeout => 0.5, 48 | ); 49 | $start = time; 50 | ($minor_version, $code, $msg, $headers, $body) = $furl->request( 51 | method => "GET", 52 | host => "127.0.0.1", 53 | port => $port, 54 | path_query => "/", 55 | ); 56 | is $code, 500, "status code:inactivity_timeout=0.5"; 57 | diag "took @{[time - $start]} seconds"; 58 | }, 59 | ); 60 | 61 | done_testing; 62 | -------------------------------------------------------------------------------- /t/100_low/37_bad_content_length.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | use utf8; 4 | use Furl::HTTP; 5 | use Test::TCP; 6 | use Test::More; 7 | use FindBin; 8 | use lib "$FindBin::Bin/../.."; 9 | use t::HTTPServer; 10 | 11 | # Scenario: The server returns bad content-length. 12 | # RFC 2616 says Content-Length header's format is: 13 | # 14 | # Content-Length = "Content-Length" ":" 1*DIGIT 15 | # 16 | # But some server returns invalid format. 17 | # It makes mysterious error message by Perl interpreter. 18 | # 19 | # Then, Furl validates content-length header before processing. 20 | # 21 | # ref. https://www.ietf.org/rfc/rfc2616.txt 22 | 23 | my $n = shift(@ARGV) || 3; 24 | test_tcp( 25 | client => sub { 26 | my $port = shift; 27 | my $furl = Furl::HTTP->new(bufsize => 10, timeout => 3); 28 | my ( undef, $code, $msg, $headers, $content ) = 29 | $furl->request( 30 | port => $port, 31 | path_query => '/foo', 32 | host => '127.0.0.1', 33 | headers => [ "X-Foo" => "ppp" ] 34 | ); 35 | is $code, 500, "request()/$_"; 36 | like $msg, qr/Internal Response/; 37 | like $content, qr/Bad Content-Length: 5963,5963/ 38 | or do{ require Devel::Peek; Devel::Peek::Dump($content) }; 39 | 40 | done_testing; 41 | }, 42 | server => sub { 43 | my $port = shift; 44 | t::HTTPServer->new(port => $port)->run(sub {; 45 | my $env = shift; 46 | return [ 200, 47 | [ 'Content-Length' => '5963,5963' ], 48 | [$env->{REQUEST_URI}] 49 | ]; 50 | }); 51 | } 52 | ); 53 | -------------------------------------------------------------------------------- /t/100_low/38_continue.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | use utf8; 4 | use Furl::HTTP; 5 | use Test::TCP; 6 | use Test::More; 7 | use FindBin; 8 | use lib "$FindBin::Bin/../.."; 9 | use t::HTTPServer; 10 | 11 | test_tcp( 12 | client => sub { 13 | my $port = shift; 14 | my $furl = Furl::HTTP->new(bufsize => 10, timeout => 3); 15 | my ( undef, $code, $msg, $headers, $content ) = 16 | $furl->request( 17 | port => $port, 18 | path_query => '/100', 19 | host => '127.0.0.1', 20 | headers => [] 21 | ); 22 | is $code, 200; 23 | is $msg, 'OK'; 24 | is $content, 'OK'; 25 | 26 | ( undef, $code, $msg, $headers, $content ) = 27 | $furl->request( 28 | port => $port, 29 | path_query => '/101', 30 | host => '127.0.0.1', 31 | headers => [] 32 | ); 33 | is $code, 200; 34 | is $msg, 'OK'; 35 | is $content, 'OK'; 36 | done_testing; 37 | }, 38 | server => sub { 39 | my $port = shift; 40 | my $server = t::HTTPServer->new(port => $port); 41 | $server->add_trigger(BEFORE_CALL_APP => sub { 42 | my ($self, $csock, $env) = @_; 43 | my $code = $env->{PATH_INFO} || '100'; 44 | $code =~ s!/!!g; 45 | my $status = $t::HTTPServer::STATUS_CODE{$code}; 46 | $self->write_all($csock, "HTTP/1.1 $code $status\015\012\015\012"); 47 | }); 48 | $server->run(sub { 49 | my $env = shift; 50 | return [ 200, [], ['OK'] ]; 51 | }); 52 | } 53 | ); 54 | -------------------------------------------------------------------------------- /t/100_low/39_httpoxy.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | use Furl::HTTP; 4 | use Test::More; 5 | 6 | plan tests => 8; 7 | 8 | sub test_proxy { 9 | my $expect = shift; 10 | my $client = Furl::HTTP->new->env_proxy; 11 | $client->{proxy}; 12 | } 13 | 14 | undef $ENV{REQUEST_METHOD}; 15 | undef $ENV{HTTP_PROXY}; 16 | undef $ENV{http_proxy}; 17 | is test_proxy, ''; 18 | 19 | $ENV{REQUEST_METHOD} = 'GET'; 20 | undef $ENV{HTTP_PROXY}; 21 | undef $ENV{http_proxy}; 22 | is test_proxy, ''; 23 | 24 | SKIP: { 25 | skip 'skip Windows', 1 if $^O eq 'MSWin32'; 26 | undef $ENV{REQUEST_METHOD}; 27 | $ENV{HTTP_PROXY} = 'http://proxy1.example.com'; 28 | undef $ENV{http_proxy}; 29 | is test_proxy, 'http://proxy1.example.com'; 30 | } 31 | 32 | $ENV{REQUEST_METHOD} = 'GET'; 33 | $ENV{HTTP_PROXY} = 'http://proxy1.example.com'; 34 | undef $ENV{http_proxy}; 35 | is test_proxy, ''; 36 | 37 | undef $ENV{REQUEST_METHOD}; 38 | undef $ENV{HTTP_PROXY}; 39 | $ENV{http_proxy} = 'http://proxy2.example.com'; 40 | is test_proxy, 'http://proxy2.example.com'; 41 | 42 | SKIP: { 43 | skip 'skip Windows', 1 if $^O eq 'MSWin32'; 44 | $ENV{REQUEST_METHOD} = 'GET'; 45 | undef $ENV{HTTP_PROXY}; 46 | $ENV{http_proxy} = 'http://proxy2.example.com'; 47 | is test_proxy, 'http://proxy2.example.com'; 48 | } 49 | 50 | undef $ENV{REQUEST_METHOD}; 51 | $ENV{HTTP_PROXY} = 'http://proxy1.example.com'; 52 | $ENV{http_proxy} = 'http://proxy2.example.com'; 53 | is test_proxy, 'http://proxy2.example.com'; 54 | 55 | SKIP: { 56 | skip 'skip Windows', 1 if $^O eq 'MSWin32'; 57 | $ENV{REQUEST_METHOD} = 'GET'; 58 | $ENV{HTTP_PROXY} = 'http://proxy1.example.com'; 59 | $ENV{http_proxy} = 'http://proxy2.example.com'; 60 | is test_proxy, 'http://proxy2.example.com'; 61 | } 62 | -------------------------------------------------------------------------------- /t/300_high/01_simple.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | use Furl; 4 | use Test::TCP; 5 | use Test::Requires qw(Plack::Request HTTP::Body), 'Plack'; 6 | use Plack::Loader; 7 | use Test::More; 8 | 9 | use Plack::Request; 10 | use File::Temp; 11 | use Fcntl qw/:seek/; 12 | 13 | my @data = ( 14 | ['get', [], sub { }], 15 | ['get', [['X-Foo' => 'bar']], sub { is $_->header('X-Foo'), 'bar'; }], 16 | 17 | ['head', [], sub { }], 18 | ['head', [['X-Foo' => 'bar']], sub { is $_->header('X-Foo'), 'bar'; }], 19 | 20 | ['post', [[], 'doya'], sub { is $_->content_length, 4; is $_->content, 'doya' }], 21 | ['post', [undef, 'doya'], sub { is $_->content_length, 4; is $_->content, 'doya' }], 22 | ['post', [[], ['do' => 'ya']], sub { is $_->content_length, 5; is $_->content, 'do=ya' }], 23 | ['post', [[], {'do' => 'ya'}], sub { is $_->content_length, 5; is $_->content, 'do=ya' }], 24 | ['post', [[], ['do' => 'ya', '=foo=' => 'bar baz']], 25 | sub { 26 | my $c = 'do=ya&%3Dfoo%3D=bar%20baz'; 27 | is $_->content_length, length($c); 28 | is $_->content, $c; 29 | }, 30 | ], 31 | 32 | ['put', [[], 'doya'], sub { is $_->content_length, 4; is $_->content, 'doya' }], 33 | ['put', [undef, 'doya'], sub { is $_->content_length, 4; is $_->content, 'doya' }], 34 | ['put', [[], ['do' => 'ya']], sub { is $_->content_length, 5; is $_->content, 'do=ya' }], 35 | ['put', [[], {'do' => 'ya'}], sub { is $_->content_length, 5; is $_->content, 'do=ya' }], 36 | ['put', [[], ['do' => 'ya', '=foo=' => 'bar baz']], 37 | sub { 38 | my $c = 'do=ya&%3Dfoo%3D=bar%20baz'; 39 | is $_->content_length, length($c); 40 | is $_->content, $c; 41 | }, 42 | ], 43 | 44 | ['delete', [], sub { }], 45 | ['delete', [['X-Foo' => 'bar']], sub { is $_->header('X-Foo'), 'bar'; }], 46 | ['delete', [undef, 'doya'], sub { is $_->content_length, 4; is $_->content, 'doya'; }], 47 | ); 48 | 49 | test_tcp( 50 | client => sub { 51 | my $port = shift; 52 | my $furl = Furl->new(); 53 | my $url = "http://127.0.0.1:$port"; 54 | 55 | my @d = @data; 56 | while (my $row = shift @d) { 57 | my ($method, $args) = @$row; 58 | note "-- $method"; 59 | my $res = $furl->$method($url, @$args); 60 | is $res->status, 200, "client: status by $method()" 61 | or die "BAD: " . join(', ', $res->status, $res->message, $res->content); 62 | } 63 | 64 | done_testing; 65 | }, 66 | server => sub { 67 | my $port = shift; 68 | my @d = @data; 69 | Plack::Loader->auto( port => $port )->run(sub { 70 | while (my $row = shift @d) { 71 | my $env = shift; 72 | my $row = shift @data; 73 | my ($method, $args, $code) = @$row; 74 | local $_ = Plack::Request->new($env); 75 | is uc($_->method), uc($method), 'server: method'; 76 | $code->(); 77 | return [ 78 | 200, 79 | [ 'Content-Length' => 2 ], 80 | ['OK'] 81 | ]; 82 | } 83 | }); 84 | } 85 | ); 86 | -------------------------------------------------------------------------------- /t/300_high/02_agent.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | use Test::More; 4 | 5 | use Furl; 6 | 7 | subtest 'agent' => sub { 8 | my $furl = Furl->new( agent => 'Furl/test' ); 9 | is $furl->agent, "Furl/test", 'get User-Agent'; 10 | 11 | $furl->agent('Furl/new'); 12 | is $furl->agent, "Furl/new", 'set new User-Agent'; 13 | }; 14 | 15 | done_testing; 16 | -------------------------------------------------------------------------------- /t/300_high/04_http_request.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | use Furl; 4 | use Test::TCP; 5 | use Test::Requires qw(Plack::Request HTTP::Body), 'Plack'; 6 | use Plack::Loader; 7 | use Test::More; 8 | 9 | use Plack::Request; 10 | use Test::Requires qw(Plack::Request HTTP::Body), 'HTTP::Request'; 11 | 12 | test_tcp( 13 | client => sub { 14 | my $port = shift; 15 | my $furl = Furl->new(); 16 | my $req = HTTP::Request->new(POST => "http://127.0.0.1:$port/foo", ['X-Foo' => 'ppp', 'Content-Length' => 3], 'yay'); 17 | my $res = $furl->request( $req ); 18 | is $res->code, 200, "request()"; 19 | 20 | done_testing; 21 | }, 22 | server => sub { 23 | my $port = shift; 24 | Plack::Loader->auto(port => $port)->run(sub { 25 | my $env = shift; 26 | #note explain $env; 27 | my $req = Plack::Request->new($env); 28 | is $req->header('X-Foo'), "ppp"; 29 | is $req->header('Host'), "127.0.0.1:$port"; 30 | is $req->path_info, "/foo"; 31 | is $req->content, "yay"; 32 | is $req->content_length, 3; 33 | is $req->method, "POST"; 34 | return [ 200, 35 | [ 'Content-Length' => length($req->content) ], 36 | [$req->content] 37 | ]; 38 | }); 39 | } 40 | ); 41 | 42 | -------------------------------------------------------------------------------- /t/300_high/05_suppress_dup_host_header.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | use Furl; 4 | use Test::TCP; 5 | use Test::More; 6 | use Test::Requires qw(Plack::Request HTTP::Body), 'HTTP::Request'; 7 | use FindBin; 8 | use lib "$FindBin::Bin/../.."; 9 | use t::HTTPServer; 10 | 11 | test_tcp( 12 | client => sub { 13 | my $port = shift; 14 | my $furl = Furl->new(); 15 | my $req = HTTP::Request->new(GET => "http://127.0.0.1:$port/foo"); 16 | $req->headers->header('Host' => '127.0.0.1'); 17 | my $res = $furl->request( $req ); 18 | is $res->code, 200, "HTTP status ok"; 19 | }, 20 | server => sub { 21 | my $port = shift; 22 | my $request; 23 | { 24 | no warnings 'redefine'; 25 | my $org = t::HTTPServer->can('parse_http_request'); 26 | *t::HTTPServer::parse_http_request = sub { 27 | $request .= $_[0]; 28 | $org->(@_); 29 | }; 30 | } 31 | 32 | t::HTTPServer->new(port => $port)->run(sub { 33 | my $env = shift; 34 | my $hash; 35 | for my $line (split /\n/, $request) { 36 | my ($k) = (split ':', $line)[0]; 37 | $hash->{$k}++; 38 | } 39 | is $hash->{Host}, 1, 'Host header is one'; 40 | is $env->{HTTP_HOST}, "127.0.0.1:$port", 'Host header is ok'; 41 | return [200, ['Content-Length' => 2], ['ok']]; 42 | }); 43 | }, 44 | ); 45 | 46 | done_testing; 47 | -------------------------------------------------------------------------------- /t/300_high/06_keep_request.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | use Furl; 4 | use Test::TCP; 5 | use Test::Requires qw(Plack::Request HTTP::Body), 'Plack'; 6 | use Plack::Loader; 7 | use Test::More; 8 | use Data::Dumper; 9 | 10 | use Plack::Request; 11 | use Test::Requires qw(Plack::Request HTTP::Body), 'HTTP::Request'; 12 | 13 | test_tcp( 14 | client => sub { 15 | my $port = shift; 16 | 17 | my $furl = Furl->new(capture_request => 1); 18 | 19 | # request(GET) 20 | { 21 | my $res = $furl->request(url => "http://127.0.0.1:$port/foo", method => "GET"); 22 | is $res->code, 200, "request()"; 23 | is $res->body, 'OK'; 24 | can_ok $res => 'request'; 25 | 26 | my $req = $res->request; 27 | isa_ok $req => 'Furl::Request'; 28 | is $req->uri => "http://127.0.0.1:$port/foo"; 29 | is $req->method => 'GET'; 30 | } 31 | 32 | # request(POST) 33 | { 34 | my $res = $furl->request(url => "http://127.0.0.1:$port/foo", method => "POST", content => 'GAH'); 35 | is $res->code, 200, "request()"; 36 | is $res->body, 'OK'; 37 | can_ok $res => 'request'; 38 | 39 | my $req = $res->request; 40 | isa_ok $req => 'Furl::Request'; 41 | is $req->uri => "http://127.0.0.1:$port/foo"; 42 | is $req->method => 'POST'; 43 | is $req->content => 'GAH'; 44 | } 45 | 46 | # ->get 47 | { 48 | my $res = $furl->get("http://127.0.0.1:$port/foo"); 49 | is $res->code, 200, "request()"; 50 | is $res->body, 'OK'; 51 | can_ok $res => 'request'; 52 | 53 | my $req = $res->request; 54 | isa_ok $req => 'Furl::Request'; 55 | is $req->uri => "http://127.0.0.1:$port/foo"; 56 | is $req->method => 'GET'; 57 | is $req->content => ''; 58 | } 59 | 60 | # ->get with headers 61 | { 62 | my $res = $furl->get("http://127.0.0.1:$port/foo", [ 63 | 'X-Furl-Request' => 1, 64 | ]); 65 | is $res->code, 200, "request()"; 66 | is $res->body, 'OK'; 67 | can_ok $res => 'request'; 68 | 69 | my $req = $res->request; 70 | isa_ok $req => 'Furl::Request'; 71 | is $req->uri => "http://127.0.0.1:$port/foo"; 72 | is $req->method => 'GET'; 73 | is $req->content => ''; 74 | is($req->headers->header('X-Furl-Request'), 1) or diag Dumper($req->headers); 75 | is($req->header('X-Furl-Request'), 1) or diag Dumper($req->headers); 76 | is join(',', $req->headers->keys), 'x-furl-request'; 77 | } 78 | 79 | # ->head 80 | { 81 | my $res = $furl->head("http://127.0.0.1:$port/foo"); 82 | is $res->code, 200, "request()"; 83 | is $res->body, ''; 84 | can_ok $res => 'request'; 85 | 86 | my $req = $res->request; 87 | isa_ok $req => 'Furl::Request'; 88 | is $req->uri => "http://127.0.0.1:$port/foo"; 89 | is $req->method => 'HEAD'; 90 | is $req->content => ''; 91 | } 92 | 93 | # ->head with headers 94 | { 95 | my $res = $furl->head("http://127.0.0.1:$port/foo", [ 96 | 'X-Furl-Request' => 1, 97 | ]); 98 | is $res->code, 200, "request()"; 99 | is $res->body, ''; 100 | can_ok $res => 'request'; 101 | 102 | my $req = $res->request; 103 | isa_ok $req => 'Furl::Request'; 104 | is $req->uri => "http://127.0.0.1:$port/foo"; 105 | is $req->method => 'HEAD'; 106 | is $req->content => ''; 107 | is $req->header('X-Furl-Request'), 1; 108 | } 109 | 110 | # ->post 111 | { 112 | my $res = $furl->post("http://127.0.0.1:$port/foo", [], 'GAH'); 113 | is $res->code, 200, "request()"; 114 | is $res->body, 'OK'; 115 | can_ok $res => 'request'; 116 | 117 | my $req = $res->request; 118 | isa_ok $req => 'Furl::Request'; 119 | is $req->uri => "http://127.0.0.1:$port/foo"; 120 | is $req->method => 'POST'; 121 | is $req->content => 'GAH'; 122 | } 123 | 124 | # ->post with headers 125 | { 126 | my $res = $furl->post("http://127.0.0.1:$port/foo", [ 127 | 'X-Furl-Request' => 1, 128 | ], 'GAH'); 129 | is $res->code, 200, "request()"; 130 | is $res->body, 'OK'; 131 | can_ok $res => 'request'; 132 | 133 | my $req = $res->request; 134 | isa_ok $req => 'Furl::Request'; 135 | is $req->uri => "http://127.0.0.1:$port/foo"; 136 | is $req->method => 'POST'; 137 | is $req->content => 'GAH'; 138 | is $req->header('X-Furl-Request'), 1; 139 | } 140 | 141 | # ->put 142 | { 143 | my $res = $furl->put("http://127.0.0.1:$port/foo", [], 'GAH'); 144 | is $res->code, 200, "request()"; 145 | is $res->body, 'OK'; 146 | can_ok $res => 'request'; 147 | 148 | my $req = $res->request; 149 | isa_ok $req => 'Furl::Request'; 150 | is $req->uri => "http://127.0.0.1:$port/foo"; 151 | is $req->method => 'PUT'; 152 | is $req->content => 'GAH'; 153 | } 154 | 155 | # ->put with headers 156 | { 157 | my $res = $furl->put("http://127.0.0.1:$port/foo", [ 158 | 'X-Furl-Request' => 1, 159 | ], 'GAH'); 160 | is $res->code, 200, "request()"; 161 | is $res->body, 'OK'; 162 | can_ok $res => 'request'; 163 | 164 | my $req = $res->request; 165 | isa_ok $req => 'Furl::Request'; 166 | is $req->uri => "http://127.0.0.1:$port/foo"; 167 | is $req->method => 'PUT'; 168 | is $req->content => 'GAH'; 169 | is $req->header('X-Furl-Request'), 1; 170 | } 171 | 172 | # ->delete 173 | { 174 | my $res = $furl->delete("http://127.0.0.1:$port/foo"); 175 | is $res->code, 200, "request()"; 176 | is $res->body, 'OK'; 177 | can_ok $res => 'request'; 178 | 179 | my $req = $res->request; 180 | isa_ok $req => 'Furl::Request'; 181 | is $req->uri => "http://127.0.0.1:$port/foo"; 182 | is $req->method => 'DELETE'; 183 | is $req->content => ''; 184 | } 185 | 186 | # ->delete with headers 187 | { 188 | my $res = $furl->delete("http://127.0.0.1:$port/foo", [ 189 | 'X-Furl-Request' => 1, 190 | ]); 191 | is $res->code, 200, "request()"; 192 | is $res->body, 'OK'; 193 | can_ok $res => 'request'; 194 | 195 | my $req = $res->request; 196 | isa_ok $req => 'Furl::Request'; 197 | is $req->uri => "http://127.0.0.1:$port/foo"; 198 | is $req->method => 'DELETE'; 199 | is $req->content => ''; 200 | is $req->header('X-Furl-Request'), 1; 201 | } 202 | 203 | done_testing; 204 | }, 205 | server => sub { 206 | my $port = shift; 207 | Plack::Loader->auto(port => $port)->run(sub { 208 | my $env = shift; 209 | my $req = Plack::Request->new($env); 210 | return [ 200, 211 | [ 'Content-Length' => 2 ], 212 | [ 'OK' ] 213 | ]; 214 | }); 215 | } 216 | ); 217 | 218 | -------------------------------------------------------------------------------- /t/300_high/07_cookie.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | use utf8; 4 | use Test::More; 5 | use Test::Requires 'HTTP::CookieJar', 'Plack::Request', 'Plack::Loader', 'Plack::Builder', 'Plack::Response'; 6 | use Test::TCP; 7 | use Furl; 8 | 9 | subtest 'Simple case', sub { 10 | test_tcp( 11 | client => sub { 12 | my $port = shift; 13 | my $furl = Furl->new( 14 | cookie_jar => HTTP::CookieJar->new() 15 | ); 16 | my $url = "http://127.0.0.1:$port"; 17 | 18 | subtest 'first time access', sub { 19 | my $res = $furl->get("${url}/"); 20 | 21 | note "Then, response should be 200 OK"; 22 | is $res->status, 200; 23 | note "And, content should be 'OK 1'"; 24 | is $res->content, 'OK 1'; 25 | }; 26 | 27 | subtest 'Second time access', sub { 28 | my $res = $furl->get("${url}/"); 29 | 30 | note "Then, response should be 200 OK"; 31 | is $res->status, 200; 32 | note "And, content should be 'OK 2'"; 33 | is $res->content, 'OK 2'; 34 | }; 35 | }, 36 | server => \&session_server, 37 | ); 38 | }; 39 | 40 | subtest '->request(host => ...) style simple interface', sub { 41 | test_tcp( 42 | client => sub { 43 | my $port = shift; 44 | my $furl = Furl->new( 45 | cookie_jar => HTTP::CookieJar->new() 46 | ); 47 | 48 | subtest 'first time access', sub { 49 | my $res = $furl->request( 50 | method => 'GET', 51 | scheme => 'http', 52 | host => '127.0.0.1', 53 | port => $port, 54 | ); 55 | 56 | note "Then, response should be 200 OK"; 57 | is $res->status, 200; 58 | note "And, content should be 'OK 1'"; 59 | is $res->content, 'OK 1'; 60 | }; 61 | 62 | subtest 'Second time access', sub { 63 | my $res = $furl->request( 64 | method => 'GET', 65 | scheme => 'http', 66 | host => '127.0.0.1', 67 | port => $port, 68 | ); 69 | 70 | note "Then, response should be 200 OK"; 71 | is $res->status, 200; 72 | note "And, content should be 'OK 2'"; 73 | is $res->content, 'OK 2'; 74 | }; 75 | }, 76 | server => \&session_server, 77 | ); 78 | }; 79 | 80 | subtest 'With redirect', sub { 81 | test_tcp( 82 | client => sub { 83 | my $port = shift; 84 | my $furl = Furl->new( 85 | cookie_jar => HTTP::CookieJar->new() 86 | ); 87 | my $url = "http://127.0.0.1:$port"; 88 | 89 | subtest 'first time access', sub { 90 | my $res = $furl->get("${url}/login"); 91 | 92 | note "Then, response should be 200 OK"; 93 | is $res->status, 200; 94 | note "And, content should be 'ok'"; 95 | is $res->content, 'ok'; 96 | }; 97 | 98 | subtest 'Second time access', sub { 99 | my $res = $furl->get("${url}/user_name"); 100 | 101 | note "Then, response should be 200 OK"; 102 | is $res->status, 200; 103 | note "And, content should be 'Nick'"; 104 | is $res->content, 'Nick'; 105 | }; 106 | }, 107 | server => sub { 108 | my $port = shift; 109 | my %SESSION_STORE; 110 | Plack::Loader->auto( port => $port )->run(builder { 111 | enable 'ContentLength'; 112 | enable 'StackTrace'; 113 | 114 | sub { 115 | my $env = shift; 116 | my $req = Plack::Request->new($env); 117 | my $path_info = $env->{PATH_INFO}; 118 | $path_info =~ s!^//!/!; 119 | if ($path_info eq '/login') { 120 | my $res = Plack::Response->new( 121 | 302, ['Location' => $req->uri_for('/login_done')], [] 122 | ); 123 | $res->cookies->{'user_name'} = 'Nick'; 124 | return $res->finalize; 125 | } elsif ($path_info eq '/login_done') { 126 | my $res = Plack::Response->new( 127 | 200, [], ['ok'] 128 | ); 129 | return $res->finalize; 130 | } elsif ($path_info eq '/user_name') { 131 | my $res = Plack::Response->new( 132 | 200, [], [$req->cookies->{'user_name'}] 133 | ); 134 | return $res->finalize; 135 | } else { 136 | my $res = Plack::Response->new( 137 | 404, [], ['not found:' . $env->{PATH_INFO}] 138 | ); 139 | return $res->finalize; 140 | } 141 | }; 142 | }); 143 | } 144 | ); 145 | }; 146 | 147 | done_testing; 148 | 149 | sub session_server { 150 | my $port = shift; 151 | my %SESSION_STORE; 152 | Plack::Loader->auto( port => $port )->run(builder { 153 | enable 'ContentLength'; 154 | 155 | sub { 156 | my $env = shift; 157 | my $req = Plack::Request->new($env); 158 | my $session_key = $req->cookies->{session_key} || rand(); 159 | my $cnt = ++$SESSION_STORE{$session_key}; 160 | note "CNT: $cnt"; 161 | my $res = Plack::Response->new( 162 | 200, [], ["OK ${cnt}"] 163 | ); 164 | $res->cookies->{'session_key'} = $session_key; 165 | return $res->finalize; 166 | }; 167 | }); 168 | } 169 | 170 | sub Plack::Request::uri_for { 171 | my($self, $path, $args) = @_; 172 | my $uri = $self->base; 173 | $uri->path($uri->path . $path); 174 | $uri->query_form(@$args) if $args; 175 | $uri; 176 | } 177 | -------------------------------------------------------------------------------- /t/300_high/99_error.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | use Furl; 4 | use Test::More; 5 | use File::Basename qw/basename/; 6 | 7 | my $furl = Furl->new; 8 | my $file_name = basename $0; 9 | 10 | sub test_error_message (&) { 11 | my $code = shift; 12 | local $@; 13 | eval { $code->() }; 14 | like $@, qr/$file_name/; 15 | } 16 | 17 | test_error_message { $furl->get('ttp://example.com/') }; 18 | test_error_message { $furl->head('ttp://example.com/') }; 19 | test_error_message { $furl->post('ttp://example.com/') }; 20 | test_error_message { $furl->delete('ttp://example.com/') }; 21 | test_error_message { $furl->put('ttp://example.com/') }; 22 | test_error_message { 23 | $furl->request( 24 | method => 'GET', 25 | url => 'ttp://example.com/', 26 | ); 27 | }; 28 | 29 | done_testing; 30 | -------------------------------------------------------------------------------- /t/400_components/001_response-coding/01-file.t: -------------------------------------------------------------------------------- 1 | #!perl 2 | 3 | use strict; 4 | use warnings; 5 | use Furl; 6 | use File::Spec; 7 | use Encode; 8 | use Cwd; 9 | use Test::Requires 'Test::Fake::HTTPD', 'URI'; 10 | use URI; 11 | use Test::More tests => 13; 12 | use Test::TCP; 13 | use Test::Fake::HTTPD; 14 | 15 | my $ua = Furl->new; 16 | my $cwd = getcwd; 17 | 18 | #BEGIN{ 19 | # package LWP::Protocol; 20 | # $^W = 0; 21 | #} 22 | 23 | my $httpd = run_http_server { 24 | my $req = shift; 25 | my $path = 't/400_components/001_response-coding' . $req->uri->path; 26 | open my $fh, '<', $path or die "$path: $!"; 27 | return [ 200, [ 'Content-Type' => 'text/html' ], $fh ]; 28 | }; 29 | note $httpd->host_port; 30 | 31 | for my $meth (qw/charset encoder encoding decoded_content/){ 32 | can_ok('Furl::Response', $meth); 33 | } 34 | 35 | my %charset = qw( 36 | UTF-8 utf-8-strict; 37 | EUC-JP EUC-JP 38 | Shift_JIS SHIFT_JIS 39 | ISO-2022-JP ISO-2022-JP 40 | ); 41 | 42 | my %filename = qw( 43 | UTF-8 t-utf-8.html 44 | EUC-JP t-euc-jp.html 45 | Shift_JIS t-shiftjis.html 46 | ISO-2022-JP t-iso-2022-jp.html 47 | ); 48 | 49 | for my $charset (sort keys %charset){ 50 | my $uri = URI->new('http://' . $httpd->host_port); 51 | $uri->path(File::Spec->catfile($filename{$charset})); 52 | my $res; 53 | { 54 | local $^W = 0; # to quiet LWP::Protocol 55 | $res = $ua->get($uri); 56 | } 57 | die unless $res->is_success; 58 | is $res->charset, $charset, "\$res->charset eq '$charset'"; 59 | my $canon = find_encoding($charset)->name; 60 | is $res->encoding, $canon, "\$res->encoding eq '$canon'"; 61 | } 62 | 63 | my $uri = URI->new('http://' . $httpd->host_port); 64 | $uri->path("t-null.html"); 65 | my $res = $ua->get($uri); 66 | die unless $res->is_success; 67 | if (defined $res->encoding){ 68 | is $res->encoding, "ascii", "res->encoding is ascii"; 69 | }else{ 70 | ok !$res->encoding, "res->encoding is undef"; 71 | } 72 | -------------------------------------------------------------------------------- /t/400_components/001_response-coding/t-euc-jp.html: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/tokuhirom/Furl/9866ebf2ad86593c62e2fd965c493474fcdc3f8a/t/400_components/001_response-coding/t-euc-jp.html -------------------------------------------------------------------------------- /t/400_components/001_response-coding/t-iso-2022-jp.html: -------------------------------------------------------------------------------- 1 | 3 | 4 | 5 | 6 | Test 7 | 8 | 9 |

$B4A;z!"%+%?%+%J!"$R$i$,$J$NF~$C$?(Bhtml.

10 | 11 | 12 | -------------------------------------------------------------------------------- /t/400_components/001_response-coding/t-null.html: -------------------------------------------------------------------------------- 1 | 3 | 4 | 5 | Test 6 | 7 | 8 |

The quick brown fox jumps over the black lazy dog.

9 | 10 | 11 | -------------------------------------------------------------------------------- /t/400_components/001_response-coding/t-shiftjis.html: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/tokuhirom/Furl/9866ebf2ad86593c62e2fd965c493474fcdc3f8a/t/400_components/001_response-coding/t-shiftjis.html -------------------------------------------------------------------------------- /t/400_components/001_response-coding/t-utf-8.html: -------------------------------------------------------------------------------- 1 | 3 | 4 | 5 | 6 | Test 7 | 8 | 9 |

漢字、カタカナ、ひらがなの入ったhtml.

10 | 11 | 12 | -------------------------------------------------------------------------------- /t/400_components/01_headers.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | use Test::More; 4 | use Furl::Headers; 5 | use Test::Requires qw(Plack::Request HTTP::Body), 'HTTP::Headers'; 6 | use HTTP::Headers; 7 | 8 | subtest 'total test' => sub { 9 | my $h = Furl::Headers->new([ 10 | 'x-foo' => 1, 11 | 'x-bar' => 2, 12 | 'x-foo' => 3, 13 | ]); 14 | is_deeply( 15 | +{%$h}, 16 | +{ 'x-foo' => [qw/1 3/], 'x-bar' => [2] }, 17 | 'make from arrayref' 18 | ); 19 | is( $h->header('X-Foo'), "1, 3" ); 20 | is_deeply( [$h->header('X-Foo')], [qw/1 3/] ); 21 | is( $h->header('X-Bar'), 2 ); 22 | is( $h->header('X-Bar'), 2 ); 23 | is_deeply( [$h->header('X-Foo')], [qw/1 3/] ); 24 | $h->header('X-Poo', 'san'); 25 | is( $h->header('X-Poo'), 'san' ); 26 | $h->header('X-Poo', ['san', 'winnie']); 27 | is( $h->header('X-Poo'), 'san, winnie' ); 28 | is_deeply( [$h->header('X-Poo')], ['san', 'winnie'] ); 29 | is(join(',', sort $h->keys), 'x-bar,x-foo,x-poo'); 30 | $h->remove_header('x-foo'); 31 | is(join(',', sort $h->keys), 'x-bar,x-poo'); 32 | is(join(',', sort $h->header_field_names), 'x-bar,x-poo', 'header_field_names'); 33 | is_deeply([sort split /\015\012/, $h->as_string], [sort split /\015\012/, "x-bar: 2\015\012x-poo: san\015\012x-poo: winnie\015\012"], 'as_string'); 34 | is(join(',', sort $h->flatten), '2,san,winnie,x-bar,x-poo,x-poo'); 35 | 36 | my $hh = $h->as_http_headers; 37 | is $hh->header('x-bar'), '2'; 38 | is $hh->header('x-poo'), 'san, winnie'; 39 | }; 40 | 41 | subtest 'from hashref' => sub { 42 | my $h = Furl::Headers->new({ 43 | 'x-foo' => [1, 3], 44 | 'x-bar' => [2], 45 | }); 46 | is( $h->header('X-Foo'), '1, 3', 'make from hashref' ); 47 | is_deeply( [$h->header('X-Foo')], [qw/1 3/] ); 48 | is( $h->header('X-Bar'), 2 ); 49 | is_deeply( [$h->header('X-Bar')], [2] ); 50 | }; 51 | 52 | subtest 'shorthand' => sub { 53 | my $h = Furl::Headers->new( 54 | [ 55 | 'expires' => '1111', 56 | 'last-modified' => '2222', 57 | 'if-modified-since' => '3333', 58 | 'content-type' => 'text/html', 59 | 'content-length' => '4444', 60 | ] 61 | ); 62 | is $h->expires, '1111'; 63 | is $h->last_modified, '2222'; 64 | is $h->if_modified_since, '3333'; 65 | is $h->content_type, 'text/html'; 66 | is $h->content_length, 4444; 67 | }; 68 | 69 | subtest 'clone' => sub { 70 | my $h1 = Furl::Headers->new([ 71 | expires => 1111, 72 | ]); 73 | my $h2 = $h1->clone(); 74 | is $h2->expires, '1111'; 75 | $h2->last_modified('2222'); 76 | is $h2->last_modified, '2222'; 77 | isnt $h1->last_modified, '2222'; 78 | }; 79 | 80 | # TODO make from hashref 81 | 82 | done_testing; 83 | -------------------------------------------------------------------------------- /t/400_components/02_response.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | use Test::More; 4 | use Test::Requires qw(Plack::Request HTTP::Body), 'HTTP::Response'; 5 | use Furl::Response; 6 | 7 | my $res = Furl::Response->new( 8 | 1, 200, 'OK', 9 | +{ 10 | 'x-foo' => ['yay'], 11 | 'x-bar' => ['hoge'], 12 | 'content-length' => [9], 13 | 'content-type' => ['text/html'], 14 | 'content-encoding' => ['chunked'], 15 | }, 16 | 'hit man' 17 | ); 18 | is $res->protocol, 'HTTP/1.1'; 19 | is $res->code, 200; 20 | is $res->message, 'OK'; 21 | isa_ok $res->headers, 'Furl::Headers'; 22 | is $res->content, 'hit man'; 23 | is($res->headers->header('X-Foo'), 'yay'); 24 | ok $res->is_success; 25 | is $res->status_line, '200 OK'; 26 | is $res->content_length, 9; 27 | is $res->content_type, 'text/html'; 28 | is $res->content_encoding, 'chunked'; 29 | my $hres = $res->as_http_response; 30 | isa_ok $hres, 'HTTP::Response'; 31 | is $hres->code, 200; 32 | is $hres->message, 'OK'; 33 | isa_ok $hres->headers, 'HTTP::Headers'; 34 | is $hres->content_type, 'text/html'; 35 | is $hres->content, 'hit man'; 36 | is $hres->protocol, 'HTTP/1.1'; 37 | 38 | subtest 'as_hashref' => sub { 39 | my $dat = $res->as_hashref; 40 | my $headers = delete $dat->{headers}; 41 | is_deeply( 42 | $dat, { 43 | message => 'OK', 44 | code => 200, 45 | content => 'hit man', 46 | protocol => 'HTTP/1.1', 47 | } 48 | ); 49 | is_deeply( 50 | [sort @{$headers}], 51 | [sort qw( 52 | content-type text/html 53 | x-foo yay 54 | x-bar hoge 55 | content-length 9 56 | content-encoding chunked 57 | )] 58 | ); 59 | }; 60 | 61 | subtest 'to_psgi' => sub { 62 | my $dat = $res->to_psgi; 63 | is(0+@$dat, 3); 64 | is($dat->[0], 200); 65 | is_deeply( 66 | [sort @{$dat->[1]}], 67 | [sort qw( 68 | content-type text/html 69 | x-foo yay 70 | x-bar hoge 71 | content-length 9 72 | content-encoding chunked 73 | )] 74 | ); 75 | is_deeply($dat->[2], ['hit man']); 76 | }; 77 | 78 | subtest decoded_content => sub { 79 | my $res = Furl::Response->new( 80 | 1, 200, 'OK', 81 | +{ 82 | 'content-type' => ['text/plain; charset=UTF-8'], 83 | }, 84 | "\343\201\202\343\201\204\343\201\206\343\201\210\343\201\212", 85 | ); 86 | is $res->decoded_content, "\x{3042}\x{3044}\x{3046}\x{3048}\x{304a}"; 87 | }; 88 | 89 | subtest 'as_string' => sub { 90 | my $res = Furl::Response->new( 91 | 1, 200, 'OK', 92 | +{ 93 | 'x-foo' => ['yay'], 94 | 'x-bar' => ['hoge'], 95 | 'content-length' => [9], 96 | 'content-type' => ['text/html'], 97 | 'content-encoding' => ['chunked'], 98 | }, 99 | 'hit man' 100 | ); 101 | my $expected = join("\015\012", 102 | '200 OK', 103 | 'content-encoding: chunked', 104 | 'content-length: 9', 105 | 'content-type: text/html', 106 | 'x-bar: hoge', 107 | 'x-foo: yay', 108 | '', 109 | 'hit man', 110 | ); 111 | is($res->as_string, $expected); 112 | is(length($res->as_string), length($expected)); 113 | }; 114 | 115 | done_testing; 116 | 117 | -------------------------------------------------------------------------------- /t/400_components/03_request.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | use Test::More; 4 | use Test::Requires 'HTTP::Request'; 5 | use Furl::Request; 6 | 7 | subtest 'normally' => sub { 8 | my $req = Furl::Request->new( 9 | 'POST', 10 | 'http://example.com/foo?q=bar', 11 | +{ 12 | 'x-foo' => ['yay'], 13 | 'x-bar' => ['hoge'], 14 | 'content-length' => [7], 15 | 'content-type' => ['text/plain'], 16 | }, 17 | 'hit man' 18 | ); 19 | $req->protocol('HTTP/1.0'); 20 | 21 | is $req->method, 'POST'; 22 | is $req->uri, 'http://example.com/foo?q=bar'; 23 | isa_ok $req->headers, 'Furl::Headers'; 24 | is($req->header('X-Foo'), 'yay'); 25 | is $req->content, 'hit man'; 26 | is $req->protocol, 'HTTP/1.0'; 27 | is $req->request_line, 'POST /foo?q=bar HTTP/1.0'; 28 | is $req->content_length, 7; 29 | is $req->content_type, 'text/plain'; 30 | 31 | my $hreq = $req->as_http_request; 32 | 33 | isa_ok $hreq, 'HTTP::Request'; 34 | is $hreq->method, 'POST'; 35 | is $hreq->uri, 'http://example.com/foo?q=bar'; 36 | isa_ok $hreq->headers, 'HTTP::Headers'; 37 | is $hreq->content_type, 'text/plain'; 38 | is $hreq->content, 'hit man'; 39 | is $hreq->protocol, 'HTTP/1.0'; 40 | }; 41 | 42 | subtest 'parse' => sub { 43 | my $body = <<__REQ__; 44 | POST /foo?q=bar HTTP/1.1 45 | Host: example.com 46 | X-Foo: yay 47 | X-Bar: hoge 48 | Content-Length: 7 49 | Content-Type: text/plain 50 | 51 | hit man 52 | __REQ__ 53 | chomp $body; 54 | 55 | my $req = Furl::Request->parse($body); 56 | 57 | is $req->method, 'POST'; 58 | is $req->uri, 'http://example.com/foo?q=bar'; 59 | isa_ok $req->headers, 'Furl::Headers'; 60 | is($req->headers->header('X-Foo'), 'yay'); 61 | is $req->content, 'hit man'; 62 | is $req->protocol, 'HTTP/1.1'; 63 | 64 | is $req->request_line, 'POST /foo?q=bar HTTP/1.1'; 65 | is $req->content_length, 7; 66 | is $req->content_type, 'text/plain'; 67 | 68 | my $hreq = $req->as_http_request; 69 | 70 | isa_ok $hreq, 'HTTP::Request'; 71 | is $hreq->method, 'POST'; 72 | is $hreq->uri, 'http://example.com/foo?q=bar'; 73 | isa_ok $hreq->headers, 'HTTP::Headers'; 74 | is $hreq->content_type, 'text/plain'; 75 | is $hreq->content, 'hit man'; 76 | is $hreq->protocol, 'HTTP/1.1'; 77 | }; 78 | 79 | subtest 'as_hashref' => sub { 80 | my $req = Furl::Request->new( 81 | 'POST', 82 | 'http://example.com/foo?q=bar', 83 | +{ 84 | 'x-foo' => ['yay'], 85 | 'x-bar' => ['hoge'], 86 | 'content-length' => [7], 87 | 'content-type' => ['text/plain'], 88 | }, 89 | 'hit man' 90 | ); 91 | $req->protocol('HTTP/1.1'); 92 | 93 | my $dat = $req->as_hashref; 94 | 95 | my $headers = delete $dat->{headers}; 96 | 97 | is_deeply( 98 | $dat, { 99 | method => 'POST', 100 | uri => 'http://example.com/foo?q=bar', 101 | content => 'hit man', 102 | protocol => 'HTTP/1.1', 103 | } 104 | ); 105 | 106 | is_deeply( 107 | [sort @{$headers}], 108 | [sort qw( 109 | content-type text/plain 110 | content-length 7 111 | x-foo yay 112 | x-bar hoge 113 | )] 114 | ); 115 | }; 116 | 117 | subtest 'as_string' => sub { 118 | subtest 'simple' => sub { 119 | my $req = Furl::Request->new( 120 | 'POST', 121 | 'http://example.com/foo?q=bar', 122 | +{ 123 | 'x-foo' => ['yay'], 124 | 'x-bar' => ['hoge'], 125 | 'content-length' => [7], 126 | 'content-type' => ['text/plain'], 127 | }, 128 | 'hit man' 129 | ); 130 | $req->protocol('HTTP/1.1'); 131 | 132 | my $expected = join("\015\012", 133 | 'POST http://example.com/foo?q=bar HTTP/1.1', 134 | 'content-length: 7', 135 | 'content-type: text/plain', 136 | 'x-bar: hoge', 137 | 'x-foo: yay', 138 | '', 139 | 'hit man', 140 | ); 141 | is($req->as_string, $expected); 142 | }; 143 | subtest 'Furl#post' => sub { 144 | my $req = Furl::Request->new( 145 | 'POST', 146 | 'http://example.com/foo?q=bar', 147 | +{ 148 | 'x-foo' => ['yay'], 149 | 'x-bar' => ['hoge'], 150 | 'content-length' => [7], 151 | 'content-type' => ['text/plain'], 152 | }, 153 | [X => 'Y'], 154 | ); 155 | # no protocol 156 | 157 | my $expected = join("\015\012", 158 | 'POST http://example.com/foo?q=bar', 159 | 'content-length: 7', 160 | 'content-type: text/plain', 161 | 'x-bar: hoge', 162 | 'x-foo: yay', 163 | '', 164 | 'X=Y', 165 | ); 166 | is($req->as_string, $expected); 167 | }; 168 | }; 169 | 170 | done_testing; 171 | 172 | -------------------------------------------------------------------------------- /t/800_regression/01_capture_request.t: -------------------------------------------------------------------------------- 1 | #!perl -Ilib 2 | use strict; 3 | use warnings; 4 | use utf8; 5 | use Test::More; 6 | 7 | use Furl; 8 | my $f=Furl->new(capture_request=>1, timeout=>5); 9 | my $r=$f->post("http://example.com.local."); 10 | is($r->captured_req_headers, undef); 11 | is($r->captured_req_content, undef); 12 | 13 | 14 | done_testing; 15 | 16 | -------------------------------------------------------------------------------- /t/999_intrenal/parse_url.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | use Furl::HTTP; 4 | use Test::More; 5 | 6 | sub test_parse_url { 7 | my ($uri, $expects, $desc) = @_; 8 | local $@; 9 | my @parsed = eval { Furl::HTTP->_parse_url($uri) }; 10 | unless ($@) { 11 | is_deeply \@parsed, $expects, $desc; 12 | } 13 | else { 14 | like $@, $expects; 15 | } 16 | } 17 | 18 | test_parse_url( 19 | 'http://example.com/', 20 | [ 21 | 'http', 22 | undef, 23 | undef, 24 | 'example.com', 25 | undef, 26 | '/', 27 | ], 28 | 'root', 29 | ); 30 | 31 | test_parse_url( 32 | 'http://example.com', 33 | [ 34 | 'http', 35 | undef, 36 | undef, 37 | 'example.com', 38 | undef, 39 | undef, 40 | ], 41 | 'root (omit /)', 42 | ); 43 | 44 | test_parse_url( 45 | 'http://example.com/?foo=bar', 46 | [ 47 | 'http', 48 | undef, 49 | undef, 50 | 'example.com', 51 | undef, 52 | '/?foo=bar', 53 | ], 54 | 'root with query string' 55 | ); 56 | 57 | test_parse_url( 58 | 'http://example.com?foo=bar', 59 | [ 60 | 'http', 61 | undef, 62 | undef, 63 | 'example.com', 64 | undef, 65 | '?foo=bar', 66 | ], 67 | 'root with query string (omit /)' 68 | ); 69 | 70 | test_parse_url( 71 | 'http://example.com:5000/', 72 | [ 73 | 'http', 74 | undef, 75 | undef, 76 | 'example.com', 77 | 5000, 78 | '/', 79 | ], 80 | 'with port', 81 | ); 82 | 83 | test_parse_url( 84 | 'http://example.com:5000', 85 | [ 86 | 'http', 87 | undef, 88 | undef, 89 | 'example.com', 90 | 5000, 91 | undef, 92 | ], 93 | 'with port (omit /)', 94 | ); 95 | 96 | test_parse_url( 97 | 'http://example.com:5000/?foo=bar', 98 | [ 99 | 'http', 100 | undef, 101 | undef, 102 | 'example.com', 103 | 5000, 104 | '/?foo=bar', 105 | ], 106 | 'with port and query string', 107 | ); 108 | 109 | test_parse_url( 110 | 'http://example.com:5000?foo=bar', 111 | [ 112 | 'http', 113 | undef, 114 | undef, 115 | 'example.com', 116 | 5000, 117 | '?foo=bar', 118 | ], 119 | 'with port (omit /)', 120 | ); 121 | 122 | test_parse_url( 123 | 'http://example.com:5000/hoge/fuga?foo=bar', 124 | [ 125 | 'http', 126 | undef, 127 | undef, 128 | 'example.com', 129 | 5000, 130 | '/hoge/fuga?foo=bar', 131 | ], 132 | 'popular url', 133 | ); 134 | 135 | test_parse_url( 136 | 'http://user:pass@example.com/', 137 | [ 138 | 'http', 139 | 'user', 140 | 'pass', 141 | 'example.com', 142 | undef, 143 | '/', 144 | ], 145 | 'auth url without port number', 146 | ); 147 | 148 | test_parse_url( 149 | 'http://user:pass@example.com:5000/hoge/fuga?foo=bar', 150 | [ 151 | 'http', 152 | 'user', 153 | 'pass', 154 | 'example.com', 155 | 5000, 156 | '/hoge/fuga?foo=bar', 157 | ], 158 | 'auth & popular url', 159 | ); 160 | 161 | test_parse_url( 162 | 'http://example.com:5000foobar', 163 | qr/Passed malformed URL:/, 164 | ); 165 | 166 | done_testing; 167 | -------------------------------------------------------------------------------- /t/HTTPServer.pm: -------------------------------------------------------------------------------- 1 | package t::HTTPServer; 2 | use strict; 3 | use warnings; 4 | use IO::Socket::INET; 5 | use Socket qw(IPPROTO_TCP TCP_NODELAY); 6 | use Carp (); 7 | 8 | # taken from HTTP::Status 9 | our %STATUS_CODE = ( 10 | 100 => 'Continue', 11 | 101 => 'Switching Protocols', 12 | 102 => 'Processing', # RFC 2518 (WebDAV) 13 | 200 => 'OK', 14 | 201 => 'Created', 15 | 202 => 'Accepted', 16 | 203 => 'Non-Authoritative Information', 17 | 204 => 'No Content', 18 | 205 => 'Reset Content', 19 | 206 => 'Partial Content', 20 | 207 => 'Multi-Status', # RFC 2518 (WebDAV) 21 | 300 => 'Multiple Choices', 22 | 301 => 'Moved Permanently', 23 | 302 => 'Found', 24 | 303 => 'See Other', 25 | 304 => 'Not Modified', 26 | 305 => 'Use Proxy', 27 | 307 => 'Temporary Redirect', 28 | 400 => 'Bad Request', 29 | 401 => 'Unauthorized', 30 | 402 => 'Payment Required', 31 | 403 => 'Forbidden', 32 | 404 => 'Not Found', 33 | 405 => 'Method Not Allowed', 34 | 406 => 'Not Acceptable', 35 | 407 => 'Proxy Authentication Required', 36 | 408 => 'Request Timeout', 37 | 409 => 'Conflict', 38 | 410 => 'Gone', 39 | 411 => 'Length Required', 40 | 412 => 'Precondition Failed', 41 | 413 => 'Request Entity Too Large', 42 | 414 => 'Request-URI Too Large', 43 | 415 => 'Unsupported Media Type', 44 | 416 => 'Request Range Not Satisfiable', 45 | 417 => 'Expectation Failed', 46 | 422 => 'Unprocessable Entity', # RFC 2518 (WebDAV) 47 | 423 => 'Locked', # RFC 2518 (WebDAV) 48 | 424 => 'Failed Dependency', # RFC 2518 (WebDAV) 49 | 425 => 'No code', # WebDAV Advanced Collections 50 | 426 => 'Upgrade Required', # RFC 2817 51 | 449 => 'Retry with', # unofficial Microsoft 52 | 500 => 'Internal Server Error', 53 | 501 => 'Not Implemented', 54 | 502 => 'Bad Gateway', 55 | 503 => 'Service Unavailable', 56 | 504 => 'Gateway Timeout', 57 | 505 => 'HTTP Version Not Supported', 58 | 506 => 'Variant Also Negotiates', # RFC 2295 59 | 507 => 'Insufficient Storage', # RFC 2518 (WebDAV) 60 | 509 => 'Bandwidth Limit Exceeded', # unofficial 61 | 510 => 'Not Extended', # RFC 2774 62 | ); 63 | 64 | sub new { 65 | my $class = shift; 66 | my %args = @_ == 1 ? %{$_[0]} : @_; 67 | $args{port} || Carp::croak("missing mandatory parameter 'port'"); 68 | bless { 69 | bufsize => 10*1024, 70 | protocol => "HTTP/1.1", 71 | enable_chunked => 1, 72 | %args 73 | }, $class; 74 | } 75 | 76 | sub add_trigger { 77 | my ($self, $name, $code) = @_; 78 | push @{$self->{triggers}->{$name}}, $code; 79 | return $self; 80 | } 81 | 82 | sub call_trigger { 83 | my ($self, $name, @args) = @_; 84 | for my $code (@{ $self->{triggers}->{$name} || +[] }) { 85 | $code->($self, @args); 86 | } 87 | } 88 | 89 | sub run { 90 | my ( $self, $app ) = @_; 91 | 92 | $app = $self->fill_content_length($app); 93 | 94 | local $SIG{PIPE} = "IGNORE"; 95 | my $sock = IO::Socket::INET->new( 96 | Listen => SOMAXCONN, 97 | Proto => 'tcp', 98 | ReuseAddr => 1, 99 | LocalAddr => '127.0.0.1', 100 | LocalPort => $self->{port}, 101 | Timeout => 3, 102 | ) or die $!; 103 | $sock->autoflush(1); 104 | while ( my $csock = $sock->accept ) { 105 | $csock->setsockopt( IPPROTO_TCP, TCP_NODELAY, 1 ) 106 | or die "setsockopt(TCP_NODELAY) failed:$!"; 107 | eval { 108 | $self->handle_connection($csock => $app); 109 | }; 110 | print STDERR "# $@" if $@; 111 | } 112 | } 113 | 114 | sub make_header { 115 | my ($self, $code, $headers) = @_; 116 | my $msg = $STATUS_CODE{$code} || $code; 117 | my $ret = "$self->{protocol} $code $msg\015\012"; 118 | for (my $i=0; $i<@$headers; $i+=2) { 119 | $ret .= $headers->[$i] . ': ' . $headers->[$i+1] . "\015\012"; 120 | } 121 | return $ret; 122 | } 123 | 124 | sub handle_connection { 125 | my ($self, $csock, $app) = @_; 126 | 127 | $self->call_trigger( "BEFORE_HANDLE_CONNECTION", $csock ); 128 | HANDLE_LOOP: while (1) { 129 | $self->call_trigger( "BEFORE_HANDLE_REQUEST", $csock ); 130 | my %env; 131 | my $buf = ''; 132 | PARSE_HTTP_REQUEST: while (1) { 133 | my $nread = sysread( $csock, $buf, $self->{bufsize}, length($buf) ); 134 | $buf =~ s!^(\015\012)*!! if defined($buf); # for keep-alive 135 | if ( !defined $nread ) { 136 | die "cannot read HTTP request header: $!"; 137 | } 138 | if ( $nread == 0 ) { 139 | # unexpected EOF while reading HTTP request header 140 | last HANDLE_LOOP; 141 | } 142 | my $ret = parse_http_request( $buf, \%env ); 143 | if ( $ret == -2 ) { # incomplete. 144 | next; 145 | } 146 | elsif ( $ret == -1 ) { # request is broken 147 | die "broken HTTP header"; 148 | } 149 | else { 150 | $buf = substr( $buf, $ret ); 151 | last PARSE_HTTP_REQUEST; 152 | } 153 | } 154 | $self->call_trigger( "BEFORE_CALL_APP", $csock, \%env ); 155 | my $res = $app->( \%env ); 156 | $self->call_trigger( "AFTER_CALL_APP", $csock, \%env ); 157 | my $res_header = 158 | $self->make_header( $res->[0], $res->[1] ) . "\015\012"; 159 | $self->write_all( $csock, $res_header ); 160 | for my $body (@{$res->[2]}) { 161 | $self->write_all( $csock, $body ); 162 | } 163 | $self->call_trigger( "AFTER_HANDLE_REQUEST", $csock ); 164 | last HANDLE_LOOP unless $csock->opened; 165 | } 166 | $self->call_trigger( "AFTER_HANDLE_CONNECTION", $csock ); 167 | } 168 | 169 | sub fill_content_length { 170 | my ($self, $app) = @_; 171 | 172 | sub { 173 | my $env = shift; 174 | my $res = $app->($env); 175 | my $h = t::HTTPServer::Headers->new( $res->[1] ); 176 | if ( 177 | !t::HTTPServer::Util::status_with_no_entity_body( $res->[0] ) 178 | && !$h->exists('Content-Length') 179 | && !$h->exists('Transfer-Encoding') 180 | && defined( 181 | my $content_length = t::HTTPServer::Util::content_length( $res->[2] ) 182 | ) 183 | ) { 184 | push @{$res->[1]}, 'Content-Length' => $content_length; 185 | } 186 | return $res; 187 | } 188 | } 189 | 190 | sub write_all { 191 | my ( $self, $csock, $buf ) = @_; 192 | my $off = 0; 193 | while ( my $len = length($buf) - $off ) { 194 | my $nwrite = $csock->syswrite( $buf, $len, $off ) 195 | or die "Cannot write response: $!"; 196 | $off += $nwrite; 197 | } 198 | return $off; 199 | } 200 | 201 | sub parse_http_request { 202 | my ( $chunk, $env ) = @_; 203 | Carp::croak("second param to parse_http_request should be a hashref") 204 | unless ( ref $env || '' ) eq 'HASH'; 205 | 206 | # pre-header blank lines are allowed (RFC 2616 4.1) 207 | $chunk =~ s/^(\x0d?\x0a)+//; 208 | return -2 unless length $chunk; 209 | 210 | # double line break indicates end of header; parse it 211 | if ( $chunk =~ /^(.*?\x0d?\x0a\x0d?\x0a)/s ) { 212 | return _parse_header( $chunk, length $1, $env ); 213 | } 214 | return -2; # still waiting for unknown amount of header lines 215 | } 216 | 217 | sub _parse_header { 218 | my($chunk, $eoh, $env) = @_; 219 | 220 | my $header = substr($chunk, 0, $eoh,''); 221 | $chunk =~ s/^\x0d?\x0a\x0d?\x0a//; 222 | 223 | # parse into lines 224 | my @header = split /\x0d?\x0a/,$header; 225 | my $request = shift @header; 226 | 227 | # join folded lines 228 | my @out; 229 | for(@header) { 230 | if(/^[ \t]+/) { 231 | return -1 unless @out; 232 | $out[-1] .= $_; 233 | } else { 234 | push @out, $_; 235 | } 236 | } 237 | 238 | # parse request or response line 239 | my $obj; 240 | my ($major, $minor); 241 | 242 | my ($method,$uri,$http) = split / /,$request; 243 | return -1 unless $http and $http =~ /^HTTP\/(\d+)\.(\d+)$/i; 244 | ($major, $minor) = ($1, $2); 245 | 246 | my($path, $query) = ( $uri =~ /^([^?]*)(?:\?(.*))?$/s ); 247 | # following validations are just needed to pass t/01simple.t 248 | if ($path =~ /%(?:[0-9a-f][^0-9a-f]|[^0-9a-f][0-9a-f])/i) { 249 | # invalid char in url-encoded path 250 | return -1; 251 | } 252 | if ($path =~ /%(?:[0-9a-f])$/i) { 253 | # partially url-encoded 254 | return -1; 255 | } 256 | 257 | $env->{REQUEST_METHOD} = $method; 258 | $env->{REQUEST_URI} = $uri; 259 | $env->{SERVER_PROTOCOL} = "HTTP/$major.$minor"; 260 | $env->{PATH_INFO} = uri_unescape($path); 261 | $env->{QUERY_STRING} = $query || ''; 262 | $env->{SCRIPT_NAME} = ''; 263 | 264 | # import headers 265 | my $token = qr/[^][\x00-\x1f\x7f()<>@,;:\\"\/?={} \t]+/; 266 | my $k; 267 | for my $header (@out) { 268 | if ( $header =~ s/^($token): ?// ) { 269 | $k = $1; 270 | $k =~ s/-/_/g; 271 | $k = uc $k; 272 | 273 | if ($k !~ /^(?:CONTENT_LENGTH|CONTENT_TYPE)$/) { 274 | $k = "HTTP_$k"; 275 | } 276 | } elsif ( $header =~ /^\s+/) { 277 | # multiline header 278 | } else { 279 | return -1; 280 | } 281 | 282 | if (exists $env->{$k}) { 283 | $env->{$k} .= ", $header"; 284 | } else { 285 | $env->{$k} = $header; 286 | } 287 | } 288 | 289 | return $eoh; 290 | } 291 | 292 | sub uri_unescape { 293 | local $_ = shift; 294 | $_ =~ s/%([0−9A−Fa−f]{2})/chr(hex($1))/eg; 295 | $_; 296 | } 297 | 298 | package t::HTTPServer::Util; 299 | # code taken from Plack::Util. 300 | 301 | use Scalar::Util (); 302 | 303 | sub status_with_no_entity_body { 304 | my $status = shift; 305 | return $status < 200 || $status == 204 || $status == 304; 306 | } 307 | 308 | sub content_length { 309 | my $body = shift; 310 | 311 | return unless defined $body; 312 | 313 | if (ref $body eq 'ARRAY') { 314 | my $cl = 0; 315 | for my $chunk (@$body) { 316 | $cl += length $chunk; 317 | } 318 | return $cl; 319 | } elsif ( is_real_fh($body) ) { 320 | return (-s $body) - tell($body); 321 | } 322 | 323 | return; 324 | } 325 | 326 | sub is_real_fh ($) { 327 | my $fh = shift; 328 | 329 | my $reftype = Scalar::Util::reftype($fh) or return; 330 | if ( $reftype eq 'IO' 331 | or $reftype eq 'GLOB' && *{$fh}{IO} 332 | ) { 333 | # if it's a blessed glob make sure to not break encapsulation with 334 | # fileno($fh) (e.g. if you are filtering output then file descriptor 335 | # based operations might no longer be valid). 336 | # then ensure that the fileno *opcode* agrees too, that there is a 337 | # valid IO object inside $fh either directly or indirectly and that it 338 | # corresponds to a real file descriptor. 339 | my $m_fileno = $fh->fileno; 340 | return 0 unless defined $m_fileno; 341 | return 0 unless $m_fileno >= 0; 342 | 343 | my $f_fileno = fileno($fh); 344 | return 0 unless defined $f_fileno; 345 | return 0 unless $f_fileno >= 0; 346 | return 1; 347 | } else { 348 | # anything else, including GLOBS without IO (even if they are blessed) 349 | # and non GLOB objects that look like filehandle objects cannot have a 350 | # valid file descriptor in fileno($fh) context so may break. 351 | return 0; 352 | } 353 | } 354 | 355 | package t::HTTPServer::Headers; 356 | 357 | sub new { 358 | my ($class, $headers) = @_; 359 | my %h; 360 | for (my $i=0; $i<@$headers; $i++) { 361 | my ($k, $v) = ($headers->[$i], $headers->[$i+1]); 362 | push @{$h{lc $k}}, $v; 363 | } 364 | return bless \%h, $class; 365 | } 366 | 367 | sub exists { 368 | my ($self, $key) = @_; 369 | $self->{lc $key} ? 1 : 0; 370 | } 371 | 372 | sub header { 373 | my ($self, $key) = @_; 374 | my $val = $self->{lc $key}; 375 | return unless $val; 376 | return wantarray ? @$val : join(', ', @$val); 377 | } 378 | 379 | 1; 380 | -------------------------------------------------------------------------------- /t/Slowloris.pm: -------------------------------------------------------------------------------- 1 | package t::Slowloris; 2 | use strict; 3 | use warnings; 4 | 5 | package Slowloris; 6 | use Test::SharedFork; 7 | 8 | our $WriteBytes = 1; 9 | our $SleepBeforeWrite = 0; 10 | our $SleepBeforeRead = 0; 11 | 12 | package Slowloris::Socket; 13 | use parent qw(IO::Socket::INET); 14 | use Time::HiRes qw(sleep); 15 | sub syswrite { 16 | my($sock, $buff, $len, $off) = @_; 17 | sleep $SleepBeforeWrite if $SleepBeforeWrite; 18 | my $w = $off; 19 | while($off < $len) { 20 | my $n = $sock->SUPER::syswrite($buff, $Slowloris::WriteBytes, $off); 21 | defined($n) or return undef; 22 | $off += $n; 23 | 24 | } 25 | return $off - $w; 26 | } 27 | 28 | sub sysread { 29 | my $sock = shift; 30 | sleep $SleepBeforeRead if $SleepBeforeRead; 31 | return $sock->SUPER::sysread(@_); 32 | } 33 | 34 | package Slowloris::Server; 35 | use parent qw(HTTP::Server::PSGI); 36 | 37 | sub setup_listener { 38 | my $self = shift; 39 | $self->SUPER::setup_listener(@_); 40 | bless $self->{listen_sock}, 'Slowloris::Socket'; 41 | } 42 | 43 | 1; 44 | 45 | -------------------------------------------------------------------------------- /t/Util.pm: -------------------------------------------------------------------------------- 1 | package t::Util; 2 | use strict; 3 | use warnings; 4 | use base qw/Exporter/; 5 | use Test::More; 6 | use Furl::HTTP; 7 | use Fcntl qw(O_CREAT O_RDWR SEEK_SET); 8 | 9 | our @EXPORT = qw/online skip_if_offline/; 10 | 11 | my $orig = \&Furl::new; 12 | sub wrapped_env_proxy { 13 | my ($class, %args) = @_; 14 | $args{proxy} = $ENV{HTTP_PROXY} if ($args{url}||'') !~ /^https?:\/\/\d+/; 15 | return $orig->($class, %args); 16 | }; 17 | { 18 | no strict 'refs'; 19 | no warnings 'redefine'; 20 | *Furl::new = \&wrapped_env_proxy if $ENV{TEST_ENV_PROXY}; 21 | } 22 | 23 | # taken from LWP::Online 24 | my @RELIABLE_HTTP = ( 25 | # These are some initial trivial checks. 26 | # The regex are case-sensitive to at least 27 | # deal with the "couldn't get site.com case". 28 | 'http://google.com/' => sub { /About Google/ }, 29 | 'http://yahoo.com/' => sub { $_ =~ /Yahoo!/ }, 30 | 'http://amazon.com/' => sub { /Amazon/ and /Cart/ }, 31 | 'http://cnn.com/' => sub { /CNN/ }, 32 | ); 33 | 34 | sub online () { 35 | # return the cache if exists 36 | sysopen my $cache, '.online', O_CREAT | O_RDWR 37 | or return 0; 38 | 39 | my $online = <$cache>; 40 | if(defined $online) { 41 | return $online; # cache 42 | } 43 | 44 | my $furl = Furl::HTTP->new(timeout => 5); 45 | my $good = 0; 46 | my $bad = 0; 47 | note 'checking if online'; 48 | $online = eval { 49 | for (my $i=0; $i<@RELIABLE_HTTP; $i+=2) { 50 | my ($url, $check) = @RELIABLE_HTTP[$i, $i+1]; 51 | note "getting $url"; 52 | my ($version, $code, $msg, $headers, $content) 53 | = $furl->request(url => $url); 54 | note "$code $msg"; 55 | local $_ = $content; 56 | if ($code == 200 && $check->()) { 57 | $good++; 58 | } else { 59 | $bad++; 60 | } 61 | 62 | return 1 if $good > 1; 63 | return 0 if $bad > 2; 64 | } 65 | }; 66 | diag $@ if $@; 67 | 68 | seek $cache, 0, SEEK_SET; 69 | print $cache $online ? 1 : 0; 70 | close $cache; 71 | return $online; 72 | } 73 | 74 | sub skip_if_offline { 75 | plan skip_all => "This test requires online env" unless online(); 76 | } 77 | 78 | 1; 79 | -------------------------------------------------------------------------------- /xt/02_perlcritic.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | use Test::More; 4 | 5 | eval { 6 | require Perl::Critic; 7 | Perl::Critic->VERSION(1.105); 8 | 9 | require Test::Perl::Critic; 10 | Test::Perl::Critic->VERSION(1.02); 11 | Test::Perl::Critic->import( 12 | -profile => \(join q{}, ) 13 | ); 14 | }; 15 | note $@ if $@; 16 | plan skip_all => "Perl::Critic 1.105+ or Test::Perl::Critic 1.02+ is not installed." if $@; 17 | 18 | all_critic_ok('lib', 'script', 'bin'); 19 | 20 | __END__ 21 | 22 | only=1 23 | 24 | # ------------------------------------------------------------------------- 25 | # Not important. 26 | 27 | [BuiltinFunctions::ProhibitSleepViaSelect] 28 | [BuiltinFunctions::RequireGlobFunction] 29 | [ClassHierarchies::ProhibitOneArgBless] 30 | 31 | # ------------------------------------------------------------------------- 32 | # Bug detection 33 | [InputOutput::ProhibitBarewordFileHandles] 34 | [Modules::RequireFilenameMatchesPackage] 35 | [Subroutines::ProhibitNestedSubs] 36 | [Subroutines::ProhibitReturnSort] 37 | [TestingAndDebugging::RequireUseStrict] 38 | [Variables::ProhibitConditionalDeclarations] 39 | [Variables::RequireLexicalLoopIterators] 40 | 41 | [TestingAndDebugging::ProhibitNoStrict] 42 | allow=refs 43 | 44 | # ------------------------------------------------------------------------- 45 | # Security issue detection 46 | [InputOutput::RequireEncodingWithUTF8Layer] 47 | [Modules::ProhibitEvilModules] 48 | [InputOutput::ProhibitTwoArgOpen] 49 | 50 | -------------------------------------------------------------------------------- /xt/04_leaktrace.t: -------------------------------------------------------------------------------- 1 | #!perl -w 2 | use strict; 3 | use Test::Requires qw(Plack::Request HTTP::Body), qw(Test::LeakTrace); 4 | use Test::More; 5 | 6 | use Furl; 7 | 8 | no_leaks_ok { 9 | my $furl = Furl->new(); 10 | my $res = $furl->request( 11 | method => 'GET', 12 | host => 'example.com', 13 | path => '/', 14 | ); 15 | $res->is_success or die $res->status_line; 16 | }; 17 | 18 | my $furl = Furl->new(); 19 | no_leaks_ok { 20 | for(1 .. 5) { 21 | my $res = $furl->request( 22 | method => 'GET', 23 | host => 'example.com', 24 | path => '/', 25 | ); 26 | $res->is_success or die $res->status_line; 27 | } 28 | }; 29 | 30 | done_testing; 31 | 32 | -------------------------------------------------------------------------------- /xt/05_valgrind.t: -------------------------------------------------------------------------------- 1 | use Test::More; 2 | eval 'use Test::Valgrind'; 3 | plan skip_all => 4 | 'Test::Valgrind is required to test your distribution with valgrind' 5 | if $@; 6 | leaky(); 7 | -------------------------------------------------------------------------------- /xt/200_online/01_idn.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | use utf8; 4 | use FindBin; 5 | use lib "$FindBin::Bin/../.."; 6 | use t::Util; 7 | use Test::More; 8 | use Furl; 9 | use Test::Requires qw(Plack::Request HTTP::Body), 'Net::IDN::Encode'; 10 | 11 | skip_if_offline(); 12 | 13 | my $url = 'http://日本語.jp/'; 14 | 15 | my $furl = Furl->new(); 16 | my $res = $furl->get($url); 17 | ok $res->is_success or $res->status_line; 18 | 19 | utf8::decode($url); 20 | $res = $furl->get($url); 21 | ok $res->is_success or $res->status_line; 22 | 23 | done_testing; 24 | -------------------------------------------------------------------------------- /xt/200_online/02_google.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | use utf8; 4 | use FindBin; 5 | use lib "$FindBin::Bin/../.."; 6 | use t::Util; 7 | use Test::More; 8 | use Furl; 9 | 10 | skip_if_offline(); 11 | 12 | my $url = 'http://www.google.co.jp/'; 13 | 14 | my $furl = Furl->new(); 15 | $furl->env_proxy(); 16 | for(1 .. 2) { 17 | note "getting"; 18 | my $res = $furl->get($url); 19 | note "done"; 20 | ok $res->is_success or diag $res->status_line 21 | } 22 | done_testing; 23 | -------------------------------------------------------------------------------- /xt/200_online/03_yahoo_com.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | use utf8; 4 | use FindBin; 5 | use lib "$FindBin::Bin/../.."; 6 | use t::Util; 7 | use Test::More; 8 | use Furl; 9 | 10 | plan skip_all => 'SSL cert error' if $ENV{TRAVIS}; 11 | 12 | skip_if_offline(); 13 | 14 | my $url = 'http://www.yahoo.com/'; 15 | 16 | my $furl = Furl->new(); 17 | $furl->env_proxy(); 18 | for(1 .. 2) { 19 | note "getting"; 20 | my $res = $furl->get($url); 21 | note "done"; 22 | ok $res->is_success or die $res->status_line; 23 | } 24 | 25 | done_testing; 26 | -------------------------------------------------------------------------------- /xt/200_online/04_ssl.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | use utf8; 4 | use Test::More; 5 | use Test::Requires qw(Plack::Request HTTP::Body), qw(IO::Socket::SSL); 6 | use Furl; 7 | use IO::Socket::SSL; 8 | use FindBin; 9 | use lib "$FindBin::Bin/../.."; 10 | use t::Util; 11 | 12 | # this test moved to xt/ since mixi's ssl sucks. 13 | # ref. http://www.machu.jp/diary/20080918.html#p01 14 | 15 | skip_if_offline(); 16 | 17 | my $furl = Furl->new(); 18 | $furl->env_proxy(); 19 | for my $url('https://mixi.jp/', 'https://mixi.jp') { 20 | my $res = $furl->get($url); 21 | ok $res->is_success, $url or diag $res->status_line; 22 | } 23 | 24 | done_testing; 25 | -------------------------------------------------------------------------------- /xt/200_online/05_connect_error.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | 4 | use Furl::HTTP; 5 | use Test::More; 6 | use Test::Requires qw(Plack::Request HTTP::Body), qw(IO::Socket::SSL); 7 | use Time::HiRes qw(time); 8 | 9 | my $n = shift(@ARGV) || 2; 10 | 11 | # TODO add proxy tests 12 | 13 | note 'name resolution error'; 14 | { 15 | my $furl = Furl::HTTP->new(timeout => 60); 16 | my (undef, $code, $msg, $headers, $content) = 17 | $furl->request( 18 | host => 'a.', # an non-existent gTLD 19 | port => 80, 20 | path_query => '/foo', 21 | ); 22 | is $code, 500, "nameerror"; 23 | like $msg, qr/Internal Response: Cannot resolve host name: a/; 24 | is ref($headers), 'ARRAY'; 25 | ok $content, "content: $content"; 26 | } 27 | 28 | note 'refused error'; 29 | { 30 | my $furl = Furl::HTTP->new( 31 | timeout => 60, 32 | ssl_opts => { 33 | SSL_verify_mode => IO::Socket::SSL::SSL_VERIFY_PEER(), 34 | }, 35 | ); 36 | for my $scheme (qw(http https)) { 37 | for (1 .. $n) { 38 | my $start_at = time; 39 | my (undef, $code, $msg, $headers, $content) = 40 | $furl->request( 41 | host => '255.255.255.255', 42 | port => 80, 43 | scheme => $scheme, 44 | path_query => '/foo', 45 | ); 46 | my $elapsed = time - $start_at; 47 | is $code, 500, "request/$scheme/$_"; 48 | if (Furl::HTTP::WIN32) { 49 | like $msg, qr/Internal Response: (Failed to send HTTP request:|Cannot create SSL connection:)/; 50 | } 51 | else { 52 | like $msg, qr/Internal Response: (Cannot connect to 255.255.255.255:80:|Cannot create SSL connection:)/; 53 | } 54 | is ref($headers), 'ARRAY'; 55 | ok $content, "content: $content"; 56 | ok $elapsed < 0.5 unless Furl::HTTP::WIN32 && $scheme eq 'https'; 57 | } 58 | } 59 | } 60 | 61 | note 'timeout error'; 62 | # Timeout parameter of IO::Socket::SSL does not seem to be accurate, so only test http 63 | for my $scheme (qw(http)) { 64 | for my $timeout (1.5, 4, 8) { 65 | my $furl = Furl::HTTP->new(timeout => $timeout); 66 | my $start_at = time; 67 | my (undef, $code, $msg, $headers, $content) = 68 | $furl->request( 69 | host => 'google.com', 70 | port => 81, 71 | scheme => $scheme, 72 | path_query => '/foo', 73 | ); 74 | my $elapsed = time - $start_at; 75 | is $code, 500, "request/$scheme/timeout/$timeout"; 76 | like $msg, qr/Internal Response: Cannot connect to google.com:81:/; 77 | is ref($headers), 'ARRAY'; 78 | ok $content, "content: $content"; 79 | ok $timeout - 0.1 <= $elapsed && $elapsed <= $timeout + 1, "elapsed: $elapsed"; 80 | } 81 | } 82 | 83 | done_testing; 84 | -------------------------------------------------------------------------------- /xt/200_online/06_net-dns-lite.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | 4 | use Furl::HTTP; 5 | use Test::More; 6 | use Test::Requires qw(Plack::Request HTTP::Body), qw(Net::DNS::Lite); 7 | use Time::HiRes qw(time sleep); 8 | 9 | my $n = shift(@ARGV) || 2; 10 | 11 | # TODO add proxy tests 12 | 13 | { 14 | my $furl = Furl::HTTP->new( 15 | inet_aton => sub { Net::DNS::Lite::inet_aton(@_) }, 16 | ); 17 | for (1 .. $n) { 18 | my $start_at = time; 19 | my (undef, $code, $msg, $headers, $content) = $furl->request( 20 | host => 'google.com', # authoritative dns does not respond 21 | port => 80, 22 | path_query => '/', 23 | ); 24 | my $elapsed = time - $start_at; 25 | is $code, 200, "request/$_"; 26 | is ref($headers), 'ARRAY'; 27 | } 28 | } 29 | 30 | note 'dns timeout'; 31 | { 32 | my $called_inet_aton = 0; 33 | my $furl = Furl::HTTP->new( 34 | timeout => 1, 35 | inet_aton => sub { 36 | # mimic timeout 37 | my ($name, $timeout) = @_; 38 | $called_inet_aton++; 39 | sleep $timeout; 40 | return undef; 41 | } 42 | ); 43 | for (1 .. $n) { 44 | my $start_at = time; 45 | my (undef, $code, $msg, $headers, $content) = $furl->request( 46 | host => 'www.google.com.', # would fail anyway, since inet_aton always returns timeout 47 | port => 80, 48 | path_query => '/foo', 49 | ); 50 | my $elapsed = time - $start_at; 51 | is $code, 500, "request/$_"; 52 | like $msg, qr/Internal Response: Cannot resolve host name: www\.google\.com/; 53 | is ref($headers), 'ARRAY'; 54 | ok $content, "content: $content"; 55 | ok 0.5 <= $elapsed && $elapsed < 1.5, "elapsed: $elapsed"; 56 | note "inet_aton calling count: $called_inet_aton"; 57 | } 58 | } 59 | 60 | done_testing; 61 | -------------------------------------------------------------------------------- /xt/200_online/07_ssl_shutdown.t: -------------------------------------------------------------------------------- 1 | #!perl 2 | use strict; 3 | use warnings; 4 | use Test::More; 5 | use Furl; 6 | use IO::Socket::SSL; 7 | 8 | my $res = Furl->new( 9 | ssl_opts => { 10 | SSL_verify_mode => SSL_VERIFY_PEER(), 11 | }, 12 | )->get('https://foursquare.com/login'); 13 | ok $res->is_success, 'SSL get'; 14 | done_testing; 15 | 16 | -------------------------------------------------------------------------------- /xt/perlcriticrc: -------------------------------------------------------------------------------- 1 | [TestingAndDebugging::ProhibitNoStrict] 2 | allow=refs 3 | [-Subroutines::ProhibitSubroutinePrototypes] 4 | [-Subroutines::ProhibitExplicitReturnUndef] 5 | [TestingAndDebugging::RequireUseStrict] 6 | equivalent_modules = perl5i::2 7 | [-ControlStructures::ProhibitMutatingListFunctions] 8 | --------------------------------------------------------------------------------