Hijk-0.27/0000755000175000017500000000000013004630023011312 5ustar gugodgugodHijk-0.27/README.md0000644000175000017500000000043312673734616012621 0ustar gugodgugodHijk ==== Specialized HTTP Client [![Tavis-CI Build Status](https://travis-ci.org/gugod/Hijk.png?branch=master)](https://travis-ci.org/gugod/Hijk) [![Coverage Status](https://coveralls.io/repos/gugod/Hijk/badge.png?branch=master)](https://coveralls.io/r/gugod/Hijk?branch=master) Hijk-0.27/META.yml0000644000175000017500000000140613004630022012563 0ustar gugodgugod--- abstract: 'Fast & minimal low-level HTTP client' author: - 'Kang-min Liu & Borislav Nikolov' build_requires: ExtUtils::MakeMaker: '6.36' Module::Install::CPANfile: '0' Net::Ping: '2.41' Plack: '0' Test::Exception: '0' Test::More: '0' configure_requires: CPAN::Meta: '0' ExtUtils::MakeMaker: '6.36' dynamic_config: '0' generated_by: 'Module::Install version 1.17, CPAN::Meta::Converter version 2.150001' license: mit meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: '1.4' name: Hijk no_index: directory: - examples - inc - t requires: Time::HiRes: '0' resources: license: http://opensource.org/licenses/mit-license.php repository: https://github.com/gugod/Hijk version: '0.27' x_module_name: Hijk Hijk-0.27/LICENSE0000644000175000017500000000206712673734616012354 0ustar gugodgugodThe MIT License Copyright (c) 2013,2014 Kang-min Liu Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions: The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. Hijk-0.27/examples/0000755000175000017500000000000013004630023013130 5ustar gugodgugodHijk-0.27/examples/hijkurl0000755000175000017500000000171012673734616014555 0ustar gugodgugod#!/usr/bin/env perl use strict; use warnings; use Getopt::Long; use Hijk; use URI; my ($method, $output_file, $header, $body) = ("GET", "-", ""); my $timeout = 60; my $dump_header; GetOptions( "method|X=s" => \$method, "H=s", => \$header, 'd=s', => \$body, "output|o=s" => \$output_file, "timeout=s" => \$timeout, "D|dump-header=s" => \$dump_header, ); $method = uc($method); my $uri_string = shift(@ARGV) or die "$0 "; my $uri = URI->new($uri_string); my $res = Hijk::request { method => $method, host => $uri->host, port => $uri->port || 80, timeout => $timeout*1000, path => $uri->path, query_string => $uri->query, $header ? ( head => [split /: /, $header, 2] ) : (), $body ? ( body => $body ) : (), parse_chunked => 1, }; if ($dump_header) { for (keys %{$res->{head}}) { print "$_: $res->{head}{$_}\n"; } print "\n"; } print $res->{body}; Hijk-0.27/examples/bench-nginx.pl0000755000175000017500000000413112673734616015717 0ustar gugodgugod#!/usr/bin/env perl use strict; use warnings; use Benchmark ':all'; use Hijk; use HTTP::Tiny; use LWP::UserAgent; use HTTP::Request; # Rate 1k.img lwp____ 1k.img tiny___ 1k.img hijk pp 1k.img hijk xs #1k.img lwp____ 820/s -- -54% -94% -95% #1k.img tiny___ 1776/s 117% -- -86% -90% #1k.img hijk pp 12821/s 1464% 622% -- -29% #1k.img hijk xs 18182/s 2118% 924% 42% -- # Rate 10k.img lwp____ 10k.img tiny___ 10k.img hijk pp 10k.img hijk xs #10k.img lwp____ 781/s -- -54% -93% -95% #10k.img tiny___ 1692/s 117% -- -85% -89% #10k.img hijk pp 11364/s 1355% 572% -- -27% #10k.img hijk xs 15625/s 1900% 823% 37% -- # Rate 100k.img lwp____ 100k.img tiny___ 100k.img hijk pp 100k.img hijk xs #100k.img lwp____ 452/s -- -62% -93% -95% #100k.img tiny___ 1179/s 161% -- -83% -86% #100k.img hijk pp 6944/s 1436% 489% -- -16% #100k.img hijk xs 8264/s 1728% 601% 19% -- foreach my $f(qw(1k.img 10k.img 100k.img)) { my $tiny = HTTP::Tiny->new(); my $req = HTTP::Request->new('GET',"http://localhost:8080/$f"); my $lwp = LWP::UserAgent->new(); cmpthese(10_000,{ $f. ' tiny___' => sub { my $res = $tiny->get("http://localhost:8080/$f"); }, $f . ' hijk pp' => sub { my $res = Hijk::request({path => "/$f", host => 'localhost', port => 8080, method => 'GET'}); }, $f . ' lwp____' => sub { my $res = $lwp->request($req); }, }); } Hijk-0.27/examples/dumbbench-thisurl.pl0000755000175000017500000000175112673734616017143 0ustar gugodgugod#!/usr/bin/env perl use strict; use warnings; use Dumbbench; use Hijk; use HTTP::Tiny; use LWP::UserAgent; use HTTP::Request; my $url = shift; my $uri = URI->new($url); my $tiny = HTTP::Tiny->new(); my $req = HTTP::Request->new('GET',$url); my $lwp = LWP::UserAgent->new(); my $hijk_req_arg = { path => $uri->path, host => $uri->host, port => $uri->port || 80, method => 'GET' }; my $bench = Dumbbench->new( target_rel_precision => 0.005, initial_runs => 1_000, ); $bench->add_instances( Dumbbench::Instance::PerlSub->new( name => "hijk", code => sub { my $res = Hijk::request($hijk_req_arg); } ), Dumbbench::Instance::PerlSub->new( name => "httptiny", code => sub { my $res = $tiny->get($url); } ), Dumbbench::Instance::PerlSub->new( name => "lwpua", code => sub { my $res = $lwp->request($req); } ), ); $bench->run; $bench->report; Hijk-0.27/examples/bench-chunked-response.pl0000644000175000017500000000116012673734616020045 0ustar gugodgugod#!/usr/bin/env perl use strict; use warnings; use Benchmark ':all'; use Hijk; use HTTP::Tiny; use LWP::UserAgent; use HTTP::Request; my $req = HTTP::Request->new('GET','http://localhost:5000/'); my $tiny = HTTP::Tiny->new(); my $lwp = LWP::UserAgent->new(); cmpthese(10_000,{ 'lwp____' => sub { my $res = $lwp->request($req); }, 'tiny___' => sub { my $res = $tiny->get('http://localhost:5000/'); }, 'hijk pp' => sub { my $res = Hijk::request({ path => "/", host => 'localhost', port => 5000, method => 'GET' }); } }); Hijk-0.27/examples/bench-elasticsearch.pl0000755000175000017500000000223012673734616017404 0ustar gugodgugod#!/usr/bin/env perl use strict; use warnings; use Benchmark ':all'; use Hijk; use HTTP::Tiny; use LWP::UserAgent; use HTTP::Request; my $tiny = HTTP::Tiny->new(); my $req = HTTP::Request->new('GET','http://localhost:9200/_search'); my $body = '{"query":{"match_all":{}}}'; $req->content($body); my $lwp = LWP::UserAgent->new(); # current results on Intel(R) Core(TM)2 Duo CPU P8400@2.26GHz with 2gb ram # and elasticsearch with one index containing ~ 500 small documents: # Rate lwp____ tiny___ hijk pp hijk xs #lwp____ 593/s -- -52% -94% -95% #tiny___ 1235/s 108% -- -88% -90% #hijk pp 10101/s 1602% 718% -- -22% #hijk xs 12987/s 2088% 952% 29% -- cmpthese(10_000,{ 'tiny___' => sub { my $res = $tiny->get('http://localhost:9200/_search',{content => $body }); }, 'hijk pp' => sub { my $res = Hijk::request({path => "/_search", body => $body, host => 'localhost', port => 9200, method => 'GET'}); }, 'lwp____' => sub { my $res = $lwp->request($req); }, }); Hijk-0.27/META.json0000644000175000017500000000255413004630022012740 0ustar gugodgugod{ "abstract" : "Fast & minimal low-level HTTP client", "author" : [ "Kang-min Liu & Borislav Nikolov" ], "dynamic_config" : "0", "generated_by" : "Module::Install version 1.17, CPAN::Meta::Converter version 2.150001", "license" : [ "mit" ], "meta-spec" : { "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", "version" : "2" }, "name" : "Hijk", "no_index" : { "directory" : [ "examples", "inc", "t" ] }, "prereqs" : { "build" : { "requires" : { "ExtUtils::MakeMaker" : "6.36" } }, "configure" : { "requires" : { "CPAN::Meta" : "0", "ExtUtils::MakeMaker" : "6.36" } }, "runtime" : { "requires" : { "Time::HiRes" : "0" } }, "test" : { "requires" : { "Module::Install::CPANfile" : "0", "Net::Ping" : "2.41", "Plack" : "0", "Test::Exception" : "0", "Test::More" : "0" } } }, "release_status" : "stable", "resources" : { "license" : [ "http://opensource.org/licenses/mit-license.php" ], "repository" : { "url" : "https://github.com/gugod/Hijk" } }, "version" : "0.27", "x_module_name" : "Hijk" } Hijk-0.27/Changes0000644000175000017500000002167713004627605012636 0ustar gugodgugod0.27: # 2016-10-28T12:59:00+0100 - Unbreak with Elasticeasrch 5.0. See https://rt.cpan.org/Public/Bug/Display.html?id=118425 0.26: # 2015-11-25T12:30:00+0100 - No functional changes since 0.25, but we had some Travis-specific changes in the repo, releasing just so we have the latest code there on the CPAN. 0.25: # 2015-11-25T12:20:00+0100 - Make the t/select-timeout.t test which fails on various odd CPANtesters platforms a TODO. Maybe some OS-specific issue, maybe an issue with kill() in the CPANtesters sandboxes not behaving as we expect. 0.24: # 2015-07-05T13:40:00+0200 - Minor copyediting and formatting changes to the documentation. No code changes at all. 0.23: # 2015-07-03T17:00:00+0200 - The "Host" header can now be overriden by supplying a new `no_default_host_header` option along with a `Host` header in `head => []` to request(). Before this we'd always send "Host: $host" over, where $host was the host we were connecting to, now you can customize this. - Fixed a bug where if passed passed `head => []` to request() we'd emit a ":" header, i.e. just an empty header name with an empty value. You could have just not passed the `head => ` value if the array was empty, but no we won't screw up and emit a single line consisting of ":" if given an empty array. 0.22: # 2015-05-27T07:54:17+0200 - No feature change. Re-package due to a missing file in the tarball: https://rt.cpan.org/Ticket/Display.html?id=104624 0.21: # 2015-05-22T15:26:23+0200 - Fix "Too many CRLF" issue. Hijk has been always generating HTTP request with an extra CRLF at the end. While many HTTP servers are ignoring those, some treat it as errors. We now eliminate the extra CRLF at the end of every request. See also http://www.w3.org/Protocols/rfc2616/rfc2616-sec4.html - Handle better when select() is interrupted by signals. 0.20: # 2015-03-20-T15:10:00+0000 - Fix a regression in 0.14. When the chunked encoding support was introduced we accidentally stopped supporting "Content-Length: 0", treat those responses as the zero-body again. This broke e.g. PUT requests that would return no payload. - Add support for 204 No Content responses. According to the HTTP standard we must try to consume the body if there's no Content-Length, but not if the server returns a 204 response, then it MUST NOT include a body (see http://tools.ietf.org/html/rfc2616#page-60). This re-adds support for e.g. 204 No Content response, in practice this "worked" before 0.14, but only accidentally and other types of responses wouldn't work. - We now handle our system calls returning EINTR. 0.19: # 2015-01-10-T18:30:00+0000 - Fix a major regression in 0.16. The introduction of "head_as_array" completely broke the disconnection logic when the socket_cache was enabled (which is the default). When talking to a webserver that would disconnect us after N requests request N+1 would always fail with a 0 byte response error. This issue was reported as RT #101424 (https://rt.cpan.org/Public/Bug/Display.html?id=101424) - Fix a minor regression in 0.16: The introduction of "head_as_array" broke the "proto" part of the return value in a relatively obscure edge case where we'd read the header & had no Content-Length and couldn't read() anything. - Fix an edge case in the Trailer support. It would only kick in if we got the Transfer-Encoding header before the "Trailer" header, not the other way around. 0.18: # 2014-12-10T14:00:00+000 - We now do the right thing on "method => 'HEAD'". I.e. ignore the Content-Length parameter, previously we'd just hang trying to slurp up the body. - Fix an edge case with some of the live tests leaving around a HTTP server if they died, these don't run by default. 0.17: # 2014-08-31T18:30:00+000 - Minor documentation changes, no functional changes. - The version number for the last release was incorrect in this changelog, fixed in this release. 0.16: # 2014-08-31T00:10:00+000 - Major Change: There are several new Hijk::Error::* constants for common issues that happened during normal requests in the face of regular exceptions out of the control of this library, such as network blips. Existing code that checks $res->{error} should be forwards-compatible with this change, but anything that was doing e.g. regex checks against regular errors thrown by this library should be updated to check the new Hijk::Error::* constants instead. - It's now possible to specify "head_as_array" to get the returned headers as an array (with potential duplicated headers), rather than the default behavior of lossily returning them as a hash. - There's now a "read_length" option to control how much we POSIX::read($fd, $buf, $read_length) at a time. We don't expect this to be useful, it's mainly configurable on general principle so we don't have arbitrary unconfigurable hardcoded constants in the source. 0.15: # 2014-08-30T10:00:00+000 - The new code to support chunked transfer encoding would return a nonexisting Hijk::Error::* value of "0" when it encountered a read timeout. This meant that not only was the error reporting broken, but anything checking if there were errors via the simple idiom of "if ($res->{error}) {...}" wouldn't properly report errors. We'll now correctly report these errors as Hijk::Error::READ_TIMEOUT. - Since there may still be other bugs like that in this new parsing mode it's disabled by default, if you know you want to parse chunked responses you have to pass parse_chunked => 1 for now. Usually you probably just want to disable chunked encoding on the other end, see the note about how to do that with nginx in the docs. 0.14: # 2014-08-29T15:40:36+0900 - Start support chunked transfer encoding. 0.13: # 2014-04-27T20:00:43+0200 - Switch to use non-blocknig fd to avoid a rare deadlock situation when select() is successful and the following read() blocks forever because there are really nothing to read. 0.12: # 2014-01-31T18:20:00+0100 - Instead of dying on e.g. "Bad arg length for Socket::pack_sockaddr_in, length is 0, should be 4" when given a host we can't resolve we'll now return a $res with the error value set to Hijk::Error::CANNOT_RESOLVEif we can't gethostbyname() the provided hostname. Makes it easier to handle DNS resolution failures. 0.11: # 2014-01-06T13:20:00+0100 - Fixed broken HTTP header parsing for servers that didn't return the entire header all at the same time, but in chunks. - We now return "proto" as well as "status" etc. in the response, so you can see what the protocol the server was using to speak to us. Also we pro-actively connections to servers that claim they're speaking HTTP/1.0. - Document that what the socket_cache is keyed on, for anyone wanting to implement a tied hash or whatever. - Fix a minor bug causing redundant work under "socket_cache => undef" 0.10: # 2013-12-19T16:50:00+0100 - We can now talk HTTP/1.0 an addition to HTTP/1.1, have a way to disable the socket cache, and can specify connect and read timeouts independently. - Fix a really nasty bug with mixings up requests after encountering a timeout. See http://lists.unbit.it/pipermail/uwsgi/2013-December/006802.html for details. - Remove spurious requirenment on perl v5.14.2 - First stab at https://github.com/gugod/Hijk/issues/3 we'll now return an error key in the response with Hijk::Error::{CONNECT_TIMEOUT,READ_TIMEOUT} instead of dying. - Nuked the Hijk::HTTP::XS support from the repo, we've decided it was too complex for its own good. - Add support for an on_connect callback for seeing how long the connect/reads take. 0.09: # 2013-12-13T07:38:25+0100 - KEEP CALM AND REMOVE FETCH OPTION - Hijk::request will use XS parser only if Hijk::HTTP::XS is loaded 0.08: # 2013-12-12T20:10:00+0100 - We only checked for undefined return codes from POSIX::read(), not 0, resulting in an infinite select/read loop when a server with keep-alive enabled cut off our connection. 0.07: # 2013-12-09T12:50:00+0100 - Skip the live connect timeout test by default, it will fail making live connections on various firewalled/locked down hosts. 0.06: # 2013-12-09T12:20:00+0100 - Declare missing test dependency on Test::Exception - Declare test dependency on Net::Ping 2.41 - Various POD improvements describing more limitations in the API and providing examples. - Don't unconditionally load the yet-to-be-released Hijk::HTTP::XS module, instead provide a "fetch" option. - Shutdown and delete the cached connection in case of read error. - Handle syswrite() returning undef without spewing an uninitialized comparison error - Various work on the test suite. 0.05: # 2013-12-04T22:33:31+0100 - Properly invalidate connection cache when seeing 'Connection: close' in the response. 0.04: # 2013-12-04T00:06:16+0100 - Implement 'connect timeout' and 'read timeout' 0.02: # 2013-11-24T16:14:20+0100 - Passthrug extra HTTP header with the 'head' request arg. 0.01: # 2013-11-24T01:49:08+0100 - Initial Release, with all wanted features are implemented. Hijk-0.27/lib/0000755000175000017500000000000013004630023012060 5ustar gugodgugodHijk-0.27/lib/Hijk.pm0000644000175000017500000007452413004627767013344 0ustar gugodgugodpackage Hijk; use strict; use warnings; use Time::HiRes; use POSIX qw(:errno_h); use Socket qw(PF_INET SOCK_STREAM pack_sockaddr_in inet_ntoa $CRLF SOL_SOCKET SO_ERROR); use Fcntl qw(F_GETFL F_SETFL O_NONBLOCK); our $VERSION = "0.27"; sub Hijk::Error::CONNECT_TIMEOUT () { 1 << 0 } # 1 sub Hijk::Error::READ_TIMEOUT () { 1 << 1 } # 2 sub Hijk::Error::TIMEOUT () { Hijk::Error::READ_TIMEOUT | Hijk::Error::CONNECT_TIMEOUT } # 3 sub Hijk::Error::CANNOT_RESOLVE () { 1 << 2 } # 4 sub Hijk::Error::REQUEST_SELECT_ERROR () { 1 << 3 } # 8 sub Hijk::Error::REQUEST_WRITE_ERROR () { 1 << 4 } # 16 sub Hijk::Error::REQUEST_ERROR () { Hijk::Error::REQUEST_SELECT_ERROR | Hijk::Error::REQUEST_WRITE_ERROR } # 24 sub Hijk::Error::RESPONSE_READ_ERROR () { 1 << 5 } # 32 sub Hijk::Error::RESPONSE_BAD_READ_VALUE () { 1 << 6 } # 64 sub Hijk::Error::RESPONSE_ERROR () { Hijk::Error::RESPONSE_READ_ERROR | Hijk::Error::RESPONSE_BAD_READ_VALUE } # 96 sub _read_http_message { my ($fd, $read_length, $read_timeout, $parse_chunked, $head_as_array, $method) = @_; $read_timeout = undef if defined($read_timeout) && $read_timeout <= 0; my ($body,$buf,$decapitated,$nbytes,$proto); my $status_code = 0; my $header = $head_as_array ? [] : {}; my $no_content_len = 0; my $head = ""; my $method_has_no_content = do { no warnings qw(uninitialized); $method eq "HEAD" }; my $close_connection; vec(my $rin = '', $fd, 1) = 1; do { return ($close_connection,undef,0,undef,undef, Hijk::Error::READ_TIMEOUT) if ((_select($rin, undef, undef, $read_timeout) != 1) || (defined($read_timeout) && $read_timeout <= 0)); my $nbytes = POSIX::read($fd, $buf, $read_length); return ($close_connection, $proto, $status_code, $header, $body) if $no_content_len && $decapitated && (!defined($nbytes) || $nbytes == 0); if (!defined($nbytes)) { next if ($! == EWOULDBLOCK || $! == EAGAIN || $! == EINTR); return ( $close_connection, undef, 0, undef, undef, Hijk::Error::RESPONSE_READ_ERROR, "Failed to read http " . ($decapitated ? "body": "head") . " from socket", $!+0, "$!", ); } if ($nbytes == 0) { return ( $close_connection, undef, 0, undef, undef, Hijk::Error::RESPONSE_BAD_READ_VALUE, "Wasn't expecting a 0 byte response for http " . ($decapitated ? "body": "head" ) . ". This shouldn't happen", ); } if ($decapitated) { $body .= $buf; if (!$no_content_len) { $read_length -= $nbytes; } } else { $head .= $buf; my $neck_pos = index($head, "${CRLF}${CRLF}"); if ($neck_pos > 0) { $decapitated = 1; $body = substr($head, $neck_pos+4); $head = substr($head, 0, $neck_pos); $proto = substr($head, 0, 8); $status_code = substr($head, 9, 3); $method_has_no_content = 1 if $status_code == 204; # 204 NO CONTENT, see http://tools.ietf.org/html/rfc2616#page-60 substr($head, 0, index($head, $CRLF) + 2, ""); # 2 = length($CRLF) my ($doing_chunked, $content_length, $trailer_mode, $trailer_value_is_true); for (split /${CRLF}/o, $head) { my ($key, $value) = split /: /, $_, 2; my $key_lc = lc($key); # Figure this out now so we don't need to scan the # list later under $head_as_array, and just for # simplicity and to avoid duplicating code later # when !$head_as_array. if ($key_lc eq 'transfer-encoding' and $value eq 'chunked') { $doing_chunked = 1; } elsif ( ($key_lc eq 'content-length') || (lc($key) eq 'content-length') ) { $content_length = $value; } elsif ($key_lc eq 'connection' and $value eq 'close') { $close_connection = 1; } elsif ($key_lc eq 'trailer' and $value) { $trailer_value_is_true = 1; } if ($head_as_array) { push @$header => $key, $value; } else { $header->{$key} = $value; } } # We're processing the headers as a stream, and we # only want to turn on $trailer_mode if # Transfer-Encoding=chunked && Trailer=TRUE. However I # don't think there's any guarantee that # Transfer-Encoding comes before Trailer, so we're # effectively doing a second-pass here. if ($doing_chunked and $trailer_value_is_true) { $trailer_mode = 1; } if ($doing_chunked) { die "PANIC: The experimental Hijk support for chunked transfer encoding needs to be explicitly enabled with parse_chunked => 1" unless $parse_chunked; # if there is chunked encoding we have to ignore content length even if we have it return ( $close_connection, $proto, $status_code, $header, _read_chunked_body( $body, $fd, $read_length, $read_timeout, $head_as_array ? $trailer_mode : ($header->{Trailer} ? 1 : 0), ), ); } if (defined $content_length) { if ($content_length == 0) { $read_length = 0; } else { $read_length = $content_length - length($body); } } else { $read_length = 10204; $no_content_len = 1; } } } } while( !$decapitated || (!$method_has_no_content && ($read_length > 0 || $no_content_len)) ); return ($close_connection, $proto, $status_code, $header, $body); } sub _read_chunked_body { my ($buf,$fd,$read_length,$read_timeout,$true_trailer_header) = @_; my $chunk_size = 0; my $body = ""; my $trailer_mode = 0; my $wait_for_last_clrf = 0; vec(my $rin = '', $fd, 1) = 1; while(1) { # just read a 10k block and process it until it is consumed if (length($buf) < 3 || length($buf) < $chunk_size || $wait_for_last_clrf > 0) { return (undef, Hijk::Error::READ_TIMEOUT) if ((_select($rin, undef, undef, $read_timeout) != 1) || (defined($read_timeout) && $read_timeout <= 0)); my $current_buf = ""; my $nbytes = POSIX::read($fd, $current_buf, $read_length); if (!defined($nbytes)) { next if ($! == EWOULDBLOCK || $! == EAGAIN || $! == EINTR); return ( undef, Hijk::Error::RESPONSE_READ_ERROR, "Failed to chunked http body from socket", $!+0, "$!", ); } if ($nbytes == 0) { return ( undef, Hijk::Error::RESPONSE_BAD_READ_VALUE, "Wasn't expecting a 0 byte response for chunked http body. This shouldn't happen, buf:<$buf>, current_buf:<$current_buf>", ); } $buf .= $current_buf; } if ($wait_for_last_clrf > 0) { $wait_for_last_clrf -= length($buf); return $body if ($wait_for_last_clrf <= 0); } if ($trailer_mode) { # http://tools.ietf.org/html/rfc2616#section-14.40 # http://tools.ietf.org/html/rfc2616#section-3.6.1 # A server using chunked transfer-coding in a response MUST NOT use the # trailer for any header fields unless at least one of the following is # true: # a)the request included a TE header field that indicates "trailers" is # acceptable in the transfer-coding of the response, as described in # section 14.39; or, # b)the server is the origin server for the response, the trailer # fields consist entirely of optional metadata, and the recipient # could use the message (in a manner acceptable to the origin server) # without receiving this metadata. In other words, the origin server # is willing to accept the possibility that the trailer fields might # be silently discarded along the path to the client. # in case of trailer mode, we just read everything until the next CRLFCRLF my $neck_pos = index($buf, "${CRLF}${CRLF}"); if ($neck_pos > 0) { return $body; } } else { if ($chunk_size > 0 && length($buf) >= $chunk_size) { $body .= substr($buf, 0, $chunk_size - 2); # our chunk size includes the following CRLF $buf = substr($buf, $chunk_size); $chunk_size = 0; } else { my $neck_pos = index($buf, ${CRLF}); if ($neck_pos > 0) { $chunk_size = hex(substr($buf, 0, $neck_pos)); if ($chunk_size == 0) { if ($true_trailer_header) { $trailer_mode = 1; } else { $buf = substr($buf, $neck_pos + 2); # in case we are missing the ending CLRF, we have to wait for it # otherwise it is left int he socket if (length($buf) < 2) { $wait_for_last_clrf = 2 - length($buf); } else { return $body; } } } else { $chunk_size += 2; # include the following CRLF $buf = substr($buf, $neck_pos + 2); } } elsif($neck_pos == 0) { return ( undef, Hijk::Error::RESPONSE_BAD_READ_VALUE, "Wasn't expecting CLRF without chunk size. This shouldn't happen, buf:<$buf>", ); } } } } } sub _construct_socket { my ($host, $port, $connect_timeout) = @_; # If we can't find the IP address there'll be no point in even # setting up a socket. my $addr; { my $inet_aton = gethostbyname($host); return (undef, {error => Hijk::Error::CANNOT_RESOLVE}) unless defined $inet_aton; $addr = pack_sockaddr_in($port, $inet_aton); } my $tcp_proto = getprotobyname("tcp"); my $soc; socket($soc, PF_INET, SOCK_STREAM, $tcp_proto) || die "Failed to construct TCP socket: $!"; my $flags = fcntl($soc, F_GETFL, 0) or die "Failed to set fcntl F_GETFL flag: $!"; fcntl($soc, F_SETFL, $flags | O_NONBLOCK) or die "Failed to set fcntl O_NONBLOCK flag: $!"; if (!connect($soc, $addr) && $! != EINPROGRESS) { die "Failed to connect $!"; } $connect_timeout = undef if defined($connect_timeout) && $connect_timeout <= 0; vec(my $rout = '', fileno($soc), 1) = 1; if (_select(undef, $rout, undef, $connect_timeout) != 1) { if (defined($connect_timeout)) { return (undef, {error => Hijk::Error::CONNECT_TIMEOUT}); } else { return ( undef, { error => Hijk::Error::REQUEST_SELECT_ERROR, error_message => "select() error on constructing the socket", errno_number => $!+0, errno_string => "$!", }, ); } } if ($! = unpack("L", getsockopt($soc, SOL_SOCKET, SO_ERROR))) { die $!; } return $soc; } sub _build_http_message { my $args = $_[0]; my $path_and_qs = ($args->{path} || "/") . ( defined($args->{query_string}) ? ("?".$args->{query_string}) : "" ); return join( $CRLF, ($args->{method} || "GET")." $path_and_qs " . ($args->{protocol} || "HTTP/1.1"), ($args->{no_default_host_header} ? () : ("Host: $args->{host}")), defined($args->{body}) ? ("Content-Length: " . length($args->{body})) : (), ($args->{head} and @{$args->{head}}) ? ( map { $args->{head}[2*$_] . ": " . $args->{head}[2*$_+1] } 0..$#{$args->{head}}/2 ) : (), "" ) . $CRLF . (defined($args->{body}) ? $args->{body} : ""); } our $SOCKET_CACHE = {}; sub request { my $args = $_[0]; # Backwards compatibility for code that provided the old timeout # argument. $args->{connect_timeout} = $args->{read_timeout} = $args->{timeout} if exists $args->{timeout}; # Ditto for providing a default socket cache, allow for setting it # to "socket_cache => undef" to disable the cache. $args->{socket_cache} = $SOCKET_CACHE unless exists $args->{socket_cache}; # Provide a default for the read_length option $args->{read_length} = 10 * 2 ** 10 unless exists $args->{read_length}; # Use $; so we can use the $socket_cache->{$$, $host, $port} # idiom to access the cache. my $cache_key; $cache_key = join($;, $$, @$args{qw(host port)}) if defined $args->{socket_cache}; my $soc; if (defined $cache_key and exists $args->{socket_cache}->{$cache_key}) { $soc = $args->{socket_cache}->{$cache_key}; } else { ($soc, my $error) = _construct_socket(@$args{qw(host port connect_timeout)}); return $error if $error; $args->{socket_cache}->{$cache_key} = $soc if defined $cache_key; $args->{on_connect}->() if exists $args->{on_connect}; } my $r = _build_http_message($args); my $total = length($r); my $left = $total; vec(my $rout = '', fileno($soc), 1) = 1; while ($left > 0) { if (_select(undef, $rout, undef, undef) != 1) { delete $args->{socket_cache}->{$cache_key} if defined $cache_key; return { error => Hijk::Error::REQUEST_SELECT_ERROR, error_message => "Got error on select() before the write() when while writing the HTTP request the socket", errno_number => $!+0, errno_string => "$!", }; } my $rc = syswrite($soc,$r,$left, $total - $left); if (!defined($rc)) { next if ($! == EWOULDBLOCK || $! == EAGAIN || $! == EINTR); delete $args->{socket_cache}->{$cache_key} if defined $cache_key; shutdown($soc, 2); return { error => Hijk::Error::REQUEST_WRITE_ERROR, error_message => "Got error trying to write the HTTP request with write() to the socket", errno_number => $!+0, errno_string => "$!", }; } $left -= $rc; } my ($close_connection,$proto,$status,$head,$body,$error,$error_message,$errno_number,$errno_string); eval { ($close_connection,$proto,$status,$head,$body,$error,$error_message,$errno_number,$errno_string) = _read_http_message(fileno($soc), @$args{qw(read_length read_timeout parse_chunked head_as_array method)}); 1; } or do { my $err = $@ || "zombie error"; delete $args->{socket_cache}->{$cache_key} if defined $cache_key; shutdown($soc, 2); die $err; }; if ($status == 0 # We always close connections for 1.0 because some servers LIE # and say that they're 1.0 but don't close the connection on # us! An example of this. Test::HTTP::Server (used by the # ShardedKV::Storage::Rest tests) is an example of such a # server. In either case we can't cache a connection for a 1.0 # server anyway, so BEGONE! or $close_connection or (defined $proto and $proto eq 'HTTP/1.0')) { delete $args->{socket_cache}->{$cache_key} if defined $cache_key; shutdown($soc, 2); } return { proto => $proto, status => $status, head => $head, body => $body, defined($error) ? ( error => $error ) : (), defined($error_message) ? ( error_message => $error_message ) : (), defined($errno_number) ? ( errno_number => $errno_number ) : (), defined($errno_string) ? ( errno_string => $errno_string ) : (), }; } sub _select { my ($rbits, $wbits, $ebits, $timeout) = @_; while (1) { my $start = Time::HiRes::time(); my $nfound = select($rbits, $wbits, $ebits, $timeout); if ($nfound == -1 && $! == EINTR) { $timeout -= Time::HiRes::time() - $start if $timeout; next; } return $nfound; } } 1; __END__ =encoding utf8 =head1 NAME Hijk - Fast & minimal low-level HTTP client =head1 SYNOPSIS A simple GET request: use Hijk (); my $res = Hijk::request({ method => "GET", host => "example.com", port => "80", path => "/flower", query_string => "color=red" }); if (exists $res->{error} and $res->{error} & Hijk::Error::TIMEOUT) { die "Oh noes we had some sort of timeout"; } die "Expecting an 'OK' response" unless $res->{status} == 200; say $res->{body}; A POST request, you have to manually set the appropriate headers, URI escape your values etc. use Hijk (); use URI::Escape qw(uri_escape); my $res = Hijk::request({ method => "POST", host => "example.com", port => "80", path => "/new", head => [ "Content-Type" => "application/x-www-form-urlencoded" ], query_string => "type=flower&bucket=the%20one%20out%20back", body => "description=" . uri_escape("Another flower, let's hope it's exciting"), }); die "Expecting an 'OK' response" unless $res->{status} == 200; =head1 DESCRIPTION Hijk is a fast & minimal low-level HTTP client intended to be used where you control both the client and the server, e.g. for talking to some internal service from a frontend user-facing web application. It is C a general HTTP user agent, it doesn't support redirects, proxies, SSL and any number of other advanced HTTP features like (in roughly descending order of feature completeness) L, L, L, L or L. This library is basically one step above manually talking HTTP over sockets. Having said that it's lightning fast and extensively used in production at L where it's used as the go-to transport layer for talking to internal services. It uses non-blocking sockets and correctly handles all combinations of connect/read timeouts and other issues you might encounter from various combinations of parts of your system going down or becoming otherwise unavailable. =head1 FUNCTION: Hijk::request( $args :HashRef ) :HashRef C is the only function you should use. It (or anything else in this package for that matter) is not exported, so you have to use the fully qualified name. It takes a C of arguments and either dies or returns a C as a response. The C argument to it must contain some of the key-value pairs from the following list. The value for C and C are mandatory, but others are optional with default values listed below. protocol => "HTTP/1.1", # (or "HTTP/1.0") host => ..., port => ..., connect_timeout => undef, read_timeout => undef, read_length => 10240, method => "GET", path => "/", query_string => "", head => [], body => "", socket_cache => \%Hijk::SOCKET_CACHE, # (undef to disable, or \my %your_socket_cache) on_connect => undef, # (or sub { ... }) parse_chunked => 0, head_as_array => 0, no_default_host_header => 1, Notice how Hijk does not take a full URI string as input, you have to specify the individual parts of the URL. Users who need to parse an existing URI string to produce a request should use the L module to do so. The value of C is an C of key-value pairs instead of a C, this way you can decide in which order the headers are sent, and you can send the same header name multiple times. For example: head => [ "Content-Type" => "application/json", "X-Requested-With" => "Hijk", ] Will produce these request headers: Content-Type: application/json X-Requested-With: Hijk In addition Hijk will provide a C header for you by default with the C value you pass to C. To suppress this (e.g. to send custom C requests) pass a true value to the C option and provide your own C header in the C C (or don't, if you want to construct a C-less request knock yourself out...). Hijk doesn't escape any values for you, it just passes them through as-is. You can easily produce invalid requests if e.g. any of these strings contain a newline, or aren't otherwise properly escaped. The value of C or C is in floating point seconds, and is used as the time limit for connecting to the host, and reading the response back from it, respectively. The default value for both is C, meaning no timeout limit. If you don't supply these timeouts and the host really is unreachable or slow, we'll reach the TCP timeout limit before returning some other error to you. The default C is C, but you can also specify C. The advantage of using C is support for keep-alive, which matters a lot in environments where the connection setup represents non-trivial overhead. Sometimes that overhead is negligible (e.g. on Linux talking to an nginx on the local network), and keeping open connections down and reducing complexity is more important, in those cases you can either use C, or specify C in the request, but just using C is an easy way to accomplish the same thing. By default we will provide a C for you which is a global singleton that we maintain keyed on C. Alternatively you can pass in C hash of your own which we'll use as the cache. To completely disable the cache pass in C. The optional C callback is intended to be used for you to figure out from production traffic what you should set the C. I.e. you can start a timer when you call C that you end when C is called, that's how long it took us to get a connection. If you start another timer in that callback that you end when C returns to you that'll give you how long it took to send/receive data after we constructed the socket, i.e. it'll help you to tweak your C. The C callback is provided with no arguments, and is called in void context. We have experimental support for parsing chunked responses encoding. historically Hijk didn't support this at all and if you wanted to use it with e.g. nginx you had to add C to the nginx config file. Since you may just want to do that instead of having Hijk do more work to parse this out with a more complex and experimental codepath you have to explicitly enable it with C. Otherwise Hijk will die when it encounters chunked responses. The C option may be turned on by default in the future. The return value is a C representing a response. It contains the following key-value pairs. proto => :Str status => :StatusCode body => :Str head => :HashRef (or :ArrayRef with "head_as_array") error => :PositiveInt error_message => :Str errno_number => :Int errno_string => :Str For example, to send a request to C, pass the following parameters: my $res = Hijk::request({ host => "example.com", port => "80", path => "/flower", query_string => "color=red" }); die "Response is not 'OK'" unless $res->{status} == 200; Notice that you do not need to put the leading C<"?"> character in the C. You do, however, need to properly C the content of C. Again, Hijk doesn't escape any values for you, so these values B be properly escaped before being passed in, unless you want to issue invalid requests. By default the C in the response is a C rather then an C. This makes it easier to retrieve specific header fields, but it means that we'll clobber any duplicated header names with the most recently seen header value. To get the returned headers as an C instead specify C. If you want to fiddle with the C value it controls how much we C at a time. We currently don't support servers returning a http body without an accompanying C header; bodies B have a C or we won't pick them up. =head1 ERROR CODES If we had a recoverable error we'll include an "error" key whose value is a bitfield that you can check against Hijk::Error::* constants. Those are: Hijk::Error::CONNECT_TIMEOUT Hijk::Error::READ_TIMEOUT Hijk::Error::TIMEOUT Hijk::Error::CANNOT_RESOLVE Hijk::Error::REQUEST_SELECT_ERROR Hijk::Error::REQUEST_WRITE_ERROR Hijk::Error::REQUEST_ERROR Hijk::Error::RESPONSE_READ_ERROR Hijk::Error::RESPONSE_BAD_READ_VALUE Hijk::Error::RESPONSE_ERROR In addition we might return C, C and C keys, see the discussion of C and C errors below. The C constant is the same as C. It's there for convenience so you can do: .. if exists $res->{error} and $res->{error} & Hijk::Error::TIMEOUT; Instead of the more verbose: .. if exists $res->{error} and $res->{error} & (Hijk::Error::CONNECT_TIMEOUT | Hijk::Error::READ_TIMEOUT) We'll return C if we can't C the host you've provided. If we fail to do a C or C during when sending the response we'll return C or C, respectively. Similarly to C the C constant is a union of these two, and any other request errors we might add in the future. When we're getting the response back we'll return C when we can't C the response, and C when the value we got from C is C<0>. The C constant is a union of these two and any other response errors we might add in the future. Some of these C and C errors are re-thrown errors from system calls. In that case we'll also pass along C which is a short human readable error message about the error, as well as C & C, which are C<$!+0> and C<"$!"> at the time we had the error. Hijk might encounter other errors during the course of the request and B call C if that happens, so if you don't want your program to stop when a request like that fails wrap it in C. Having said that the point of the C interface is that all errors that happen during normal operation, i.e. making valid requests against servers where you can have issues like timeouts, network blips or the server thread on the other end being suddenly kill -9'd should be caught, categorized and returned in a structural way by Hijk. We're not currently aware of any issues that occur in such normal operations that aren't classified as a C, and if we find new issues that fit the criteria above we'll likely just make a new C for it. We're just not trying to guarantee that the library can never C, and aren't trying to catch truly exceptional issues like e.g. C failing on a valid socket. =head1 AUTHORS =over 4 =item Kang-min Liu =item Ævar Arnfjörð Bjarmason =item Borislav Nikolov =item Damian Gryski =back =head1 COPYRIGHT Copyright (c) 2013 Kang-min Liu C<< >>. =head1 LICENCE The MIT License =head1 DISCLAIMER OF WARRANTY BECAUSE THIS SOFTWARE IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY FOR THE SOFTWARE, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES PROVIDE THE SOFTWARE "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE SOFTWARE IS WITH YOU. SHOULD THE SOFTWARE PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, REPAIR, OR CORRECTION. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR REDISTRIBUTE THE SOFTWARE AS PERMITTED BY THE ABOVE LICENCE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE SOFTWARE (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A FAILURE OF THE SOFTWARE TO OPERATE WITH ANY OTHER SOFTWARE), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGES. =cut Hijk-0.27/Makefile.PL0000644000175000017500000000032412673734616013313 0ustar gugodgugoduse inc::Module::Install; license('mit'); author('Kang-min Liu & Borislav Nikolov'); repository('https://github.com/gugod/Hijk'); all_from("lib/Hijk.pm"); cpanfile(); makemaker_args( NORECURS => 1 ); WriteAll(); Hijk-0.27/t/0000755000175000017500000000000013004630023011555 5ustar gugodgugodHijk-0.27/t/select-timeout.t0000644000175000017500000000205112673734616014733 0ustar gugodgugod#!/usr/bin/env perl use strict; use warnings; use Test::More; use Test::Exception; use Hijk; use Time::HiRes; my $parent_pid = $$; pipe(my $rh, my $wh) or die "Failed to create pipe: $!"; my $pid = fork; die "Fail to fork then start a plack server" unless defined $pid; if ($pid == 0) { Time::HiRes::sleep(0.5); for (1..10) { kill('HUP', $parent_pid); Time::HiRes::sleep(0.1); } exit; } $SIG{HUP} = sub { warn "SIGHUP received\n" }; my $timeout = 2; vec(my $rin = '', fileno($rh), 2) = 1; my $start = Time::HiRes::time; Hijk::_select($rin, undef, undef, $timeout); my $elapsed = Time::HiRes::time - $start; { my $msg = sprintf("handle signal during select, took=%.2fs, expected at least=%.2fs", $elapsed, $timeout); if ($elapsed >= $timeout) { pass($msg); } else { TODO: { local $TODO = "We don't know why, but this fails on various BSDs etc. It is known, and probably some general OS issue. Don't clutter CPANtesters with it"; fail($msg); } } } done_testing; Hijk-0.27/t/parse-http-connection-close-message.t0000644000175000017500000000227012673734616020744 0ustar gugodgugod#!/usr/bin/env perl use strict; use warnings; use Test::More; use File::Temp (); use File::Temp qw/ :seekable /; use Hijk; my $fh = File::Temp->new(); my $fd = do { local $/ = undef; my $msg = join( "\x0d\x0a", 'HTTP/1.1 200 OK', 'Date: Sat, 23 Nov 2013 23:10:28 GMT', 'Last-Modified: Sat, 26 Oct 2013 19:41:47 GMT', 'ETag: "4b9d0211dd8a2819866bccff777af225"', 'Content-Type: text/html', 'Server: Example', 'Connection: close', '', '' ); print $fh $msg; $fh->flush; $fh->seek(0, 0); fileno($fh); }; my (undef, $proto, $status, $head, $body) = Hijk::_read_http_message($fd, 10240, 0); is $status, 200; is $body, ""; is_deeply $head, { "Date" => "Sat, 23 Nov 2013 23:10:28 GMT", "Last-Modified" => "Sat, 26 Oct 2013 19:41:47 GMT", "ETag" => '"4b9d0211dd8a2819866bccff777af225"', "Content-Type" => "text/html", "Server" => "Example", "Connection" => "close", }; (undef, $proto, $status, $head, $body, my $error, my $error_message) = Hijk::_read_http_message($fd, 10240, 0); is $error, Hijk::Error::RESPONSE_BAD_READ_VALUE; like $error_message, qr/0 byte/; done_testing; Hijk-0.27/t/chunked.t0000644000175000017500000000311612673734616013414 0ustar gugodgugod#!/usr/bin/env perl use strict; use Test::More; use File::Temp (); use File::Temp qw/ :seekable /; use Hijk; my $fh = File::Temp->new(); my $fd = do { local $/ = undef; my $data = "4\r\nWiki\r\n5\r\npedia\r\ne\r\n in\r\n\r\nchunks.\r\n0\r\n\r\n"; my $msg = join( "\x0d\x0a", 'HTTP/1.1 200 OK', 'Date: Sat, 23 Nov 2013 23:10:28 GMT', 'Last-Modified: Sat, 26 Oct 2013 19:41:47 GMT', 'ETag: "4b9d0211dd8a2819866bccff777af225"', 'Content-Type: text/html', 'Server: Example', 'Transfer-Encoding: chunked', 'non-sence: ' . 'a' x 20000, '', $data ); print $fh $msg; $fh->flush; $fh->seek(0, 0); fileno($fh); }; my (undef, $proto, $status, $head, $body) = Hijk::_read_http_message($fd, 10240, undef, 1); is $status, 200; is $body, "Wikipedia in\r\n\r\nchunks."; is_deeply $head, { "Date" => "Sat, 23 Nov 2013 23:10:28 GMT", "Last-Modified" => "Sat, 26 Oct 2013 19:41:47 GMT", "ETag" => '"4b9d0211dd8a2819866bccff777af225"', "Content-Type" => "text/html", "Server" => "Example", 'non-sence' => 'a' x 20000, "Transfer-Encoding" => "chunked", }; # fetch again without seeking back # this will force select() to return because there are actually # 0 bytes to read - so we can simulate connection closed # from the other end of the socket (like expired keep-alive) (undef, $proto, $status, $head, $body, my $error, my $error_message) = Hijk::_read_http_message($fd, 10240); is $error, Hijk::Error::RESPONSE_BAD_READ_VALUE; like $error_message, qr/0 byte/; done_testing; Hijk-0.27/t/live-unixis.t0000644000175000017500000000255112673734616014251 0ustar gugodgugod#!/usr/bin/env perl use strict; use warnings; use Hijk; use Test::More; use Test::Exception; unless ($ENV{TEST_LIVE}) { plan skip_all => "Enable live testing by setting env: TEST_LIVE=1"; } if($ENV{http_proxy}) { plan skip_all => "http_proxy is set. We cannot test when proxy is required to visit u.nix.is"; } for my $i (1..1000) { lives_ok { my $res = Hijk::request({ host => 'u.nix.is', port => 80, connect_timeout => 3, read_timeout => 3, path => "/?Hijk_test_nr=$i", head => [ "X-Request-Nr" => $i, "Referer" => "Hijk (file:" . __FILE__ . "; iteration: $i)", ], }); ok !exists($res->{error}), '$res->{error} does not exist, because we do not expect connect timeout to happen'; cmp_ok $res->{status}, '==', 200, "We got a 200 OK response"; if (exists $res->{head}->{Connection} and $res->{head}->{Connection} eq 'close') { cmp_ok scalar(keys %{$Hijk::SOCKET_CACHE}), '==', 0, "We were told to close the connection. We should have no entry in the socket cache"; } else { cmp_ok scalar(keys %{$Hijk::SOCKET_CACHE}), '==', 1, "We have an entry in the global socket cache"; } } "We could make request number $i"; } done_testing; Hijk-0.27/t/live-google.t0000644000175000017500000000746712712333606014205 0ustar gugodgugod#!/usr/bin/env perl use strict; use warnings; use Hijk; use Time::HiRes (); use Test::More; use Test::Exception; unless ($ENV{TEST_LIVE}) { plan skip_all => "Enable live testing by setting env: TEST_LIVE=1"; } if($ENV{http_proxy}) { plan skip_all => "http_proxy is set. We cannot test when proxy is required to visit google.com"; } my %args = ( host => "google.com", port => "80", method => "GET", ); subtest "timeout and cache" => sub { lives_ok { my $res = Hijk::request({ host => 'google.com', port => 80, timeout => 0 }); ok !exists($res->{error}), '$res->{error} does not exist, because we do not expect connect timeout to happen'; cmp_ok scalar(keys %{$Hijk::SOCKET_CACHE}), '==', 1, "We have an entry in the global socket cache"; %{$Hijk::SOCKET_CACHE} = (); } "We could make the request"; lives_ok { my %socket_cache; my $res = Hijk::request({ host => 'google.com', port => 80, timeout => 0, socket_cache => \%socket_cache, }); ok !exists($res->{error}), '$res->{error} does not exist, because we do not expect connect timeout to happen'; cmp_ok scalar(keys %{$Hijk::SOCKET_CACHE}), '==', 0, "We have nothing in the global socket cache..."; cmp_ok scalar(keys %socket_cache), '==', 1, "...because we used our own cache"; } "We could make the request"; lives_ok { my %socket_cache; my $res = Hijk::request({ host => 'google.com', port => 80, timeout => 0, socket_cache => undef, }); ok !exists($res->{error}), '$res->{error} does not exist, because we do not expect connect timeout to happen'; cmp_ok scalar(keys %{$Hijk::SOCKET_CACHE}), '==', 0, "We have nothing in the global socket cache"; cmp_ok $res->{body}, "ne", "", "We a body with a GET requests"; } "We could make the request"; lives_ok { my %socket_cache; my $res = Hijk::request({ method => "HEAD", host => 'google.com', port => 80, timeout => 0, socket_cache => undef, }); ok !exists($res->{error}), '$res->{error} does not exist, because we do not expect connect timeout to happen'; cmp_ok scalar(keys %{$Hijk::SOCKET_CACHE}), '==', 0, "We have nothing in the global socket cache"; cmp_ok $res->{body}, "eq", "", "We have no body from HEAD requests"; } "We could make the request"; }; subtest "with 1ms timeout limit, expect an exception." => sub { lives_ok { my $res = Hijk::request({%args, timeout => 0.001}); ok exists $res->{error}; ok $res->{error} & Hijk::Error::TIMEOUT; }; }; subtest "with 10s timeout limit, do not expect an exception." => sub { lives_ok { my $res = Hijk::request({%args, timeout => 10}); diag substr($res->{body}, 0, 80); } 'google.com send back something within 10s'; }; subtest "without timeout, do not expect an exception." => sub { lives_ok { my $res = Hijk::request({%args, timeout => 0}); } 'google.com send back something without timeout'; }; subtest "Test the on_connect callback" => sub { lives_ok { my $connect_time = -Time::HiRes::time(); my $read_time; my $res = Hijk::request({ %args, timeout => 10, socket_cache => undef, on_connect => sub { $connect_time += Time::HiRes::time(); $read_time = -Time::HiRes::time(); return; }, }); $read_time += Time::HiRes::time(); ok($connect_time, "Managed to connect in $connect_time"); ok($read_time, "Managed to read in $read_time"); }; }; done_testing; Hijk-0.27/t/parse-http-message-head-as-array.t0000644000175000017500000000203112673734616020113 0ustar gugodgugod#!/usr/bin/env perl use strict; use warnings; use Test::More; use File::Temp (); use File::Temp qw/ :seekable /; use Hijk; my $fh = File::Temp->new(); my $fd = do { local $/ = undef; my $msg = join( "\x0d\x0a", 'HTTP/1.1 200 OK', 'Date: Sat, 23 Nov 2013 23:10:28 GMT', 'Last-Modified: Sat, 26 Oct 2013 19:41:47 GMT', 'ETag: "4b9d0211dd8a2819866bccff777af225"', 'Content-Type: text/html', 'Server: Example', 'Content-Length: 4', '', 'OHAI' ); print $fh $msg; $fh->flush; $fh->seek(0, 0); fileno($fh); }; my (undef, $proto, $status, $head, $body) = Hijk::_read_http_message($fd, 10240, 0, 0, 1); is $proto, "HTTP/1.1"; is $status, 200; is $body, "OHAI"; is_deeply $head, [ "Date" => "Sat, 23 Nov 2013 23:10:28 GMT", "Last-Modified" => "Sat, 26 Oct 2013 19:41:47 GMT", "ETag" => '"4b9d0211dd8a2819866bccff777af225"', "Content-Type" => "text/html", "Server" => "Example", "Content-Length" => "4", ]; done_testing; Hijk-0.27/t/live-connect-timeout.t0000644000175000017500000000265612673734616016055 0ustar gugodgugod#!/usr/bin/env perl use strict; use warnings; use Test::More; use Test::Exception; use Net::Ping; use Hijk; unless ($ENV{TEST_LIVE}) { plan skip_all => "Enable live testing by setting env: TEST_LIVE=1"; } # find a ip and confirm it is not reachable. my $pinger = Net::Ping->new("tcp", 2); $pinger->port_number(80); my $ip; my $iter = 10; do { $ip = join ".", 172, (int(rand()*15+16)), int(rand()*250+1), int(rand()*255+1); } while($iter-- > 0 && $pinger->ping($ip)); if ($iter == 0) { plan skip_all => "Cannot randomly generate an unreachable IP." } pass "ip generated = $ip"; my ($res, $exception); eval { $res = Hijk::request({ host => $ip, port => 80, timeout => 1 # seconds }); 1; } or do { $exception = $@ || "unknown error."; $exception =~ s/\n//g; }; if ($exception) { pass "On $^O, we have exception trying to connect to an unreachable IP: $exception"; is(scalar(keys %{$Hijk::SOCKET_CACHE}), 0, "We have nothing in the socket cache after the connect exception."); } else { ok exists $res->{error}, "On $^O, ".'$res->{error} exists because we expect error to happen.'; is $res->{error}, Hijk::Error::CONNECT_TIMEOUT, '$res->{error} contiain the value of Hijk::Error::CONNECT_TIMEOUT, indicating that it timed-out when establishing connection'; is(scalar(keys %{$Hijk::SOCKET_CACHE}), 0, "We have nothing in the socket cache after a timeout"); } done_testing; Hijk-0.27/t/chunked-trailer.t0000644000175000017500000000312612673734616015055 0ustar gugodgugod#!/usr/bin/env perl use strict; use Test::More; use File::Temp (); use File::Temp qw/ :seekable /; use Hijk; my $fh = File::Temp->new(); my $fd = do { local $/ = undef; my $data = "4\r\nWiki\r\n5\r\npedia\r\ne\r\n in\r\n\r\nchunks.\r\n0\r\n"; my $msg = join( "\x0d\x0a", 'HTTP/1.1 200 OK', 'Last-Modified: Sat, 26 Oct 2013 19:41:47 GMT', 'ETag: "4b9d0211dd8a2819866bccff777af225"', 'Content-Type: text/html', 'Server: Example', 'Transfer-Encoding: chunked', 'Trailer: Date', 'non-sence: ' . 'a' x 20000, '', $data, 'Date: Sat, 23 Nov 2013 23:10:28 GMT', '' ); print $fh $msg; $fh->flush; $fh->seek(0, 0); fileno($fh); }; my (undef, $proto, $status, $head, $body) = Hijk::_read_http_message($fd, 10240, undef, 1); is $status, 200; is $body, "Wikipedia in\r\n\r\nchunks."; is_deeply $head, { "Last-Modified" => "Sat, 26 Oct 2013 19:41:47 GMT", "ETag" => '"4b9d0211dd8a2819866bccff777af225"', "Content-Type" => "text/html", "Server" => "Example", 'non-sence' => 'a' x 20000, "Transfer-Encoding" => "chunked", 'Trailer' => 'Date', }; # fetch again without seeking back # this will force select() to return because there are actually # 0 bytes to read - so we can simulate connection closed # from the other end of the socket (like expired keep-alive) (undef, $proto, $status, $head, $body, my $error, my $error_message) = Hijk::_read_http_message($fd, 10240); is $error, Hijk::Error::RESPONSE_BAD_READ_VALUE; like $error_message, qr/0 byte/; done_testing; Hijk-0.27/t/bin/0000755000175000017500000000000013004630023012325 5ustar gugodgugodHijk-0.27/t/bin/it-takes-time.psgi0000644000175000017500000000062712673734616015723 0ustar gugodgugod#!/usr/bin/env perl use strict; use warnings; use Time::HiRes qw(sleep time); use Plack::Request; sub { my $env = shift; my $start_time = time; my $req = Plack::Request->new($env); my ($t) = $env->{QUERY_STRING} =~ m/\At=([0-9\.]+)\z/; $t ||= 1; sleep $t; return [200, [], [$start_time, ",", time]]; } __END__ curl 'http://localhost:5000?t=2.5' curl 'http://localhost:5000?t=17' Hijk-0.27/t/bin/head-request.psgi0000644000175000017500000000054512673734616015634 0ustar gugodgugod#!/usr/bin/env perl use strict; use warnings; sub { my $env = shift; my ($gimme_content_length) = $env->{QUERY_STRING} =~ m/\Agimme_content_length=([01])\z/; my $hello_world = "Hello world"; return [ 200, [ ($gimme_content_length ? () : ()), ], [$hello_world], ]; } Hijk-0.27/t/bin/split-in-chunks.psgi0000644000175000017500000000171312673734616016273 0ustar gugodgugod#!/usr/bin/env perl # need Starman to produce chunked response. # starman --worker 4 t/bin/split-in-chunks.psgi ## perl -E 'print "GET / HTTP/1.1\r\nHost: localhost\r\n\r\n"' | nc localhost 5000 use strict; use warnings; my $epic_graph = <([ 200, [ 'Content-Type', 'text/plain' ]]); my @chunks; while($epic_graph) { my $l = rand() * 30 + 1; my $chunk = substr($epic_graph, 0, $l, ''); $writer->write($chunk); } $writer->close; } } Hijk-0.27/t/live-invalid-domain.t0000644000175000017500000000067712673734616015634 0ustar gugodgugod#!/usr/bin/env perl use strict; use warnings; use Hijk; use Test::More; unless ($ENV{TEST_LIVE}) { plan skip_all => "Enable live testing by setting env: TEST_LIVE=1"; } my $res = Hijk::request({ method => "GET", host => "hlagh.google.com", port => "80", }); ok exists $res->{error}, "We got an error back for this invalid domain"; is $res->{error}, Hijk::Error::CANNOT_RESOLVE, "We can't resolve the domain"; done_testing; Hijk-0.27/t/live-elasticsearch.t0000644000175000017500000000216312673734616015543 0ustar gugodgugod#!/usr/bin/env perl use strict; use warnings; use Hijk; use Test::More; unless ($ENV{TEST_LIVE}) { plan skip_all => "Enable live testing by setting env: TEST_LIVE=1"; } unless ($ENV{TEST_ELASTICSEARCH}) { plan skip_all => "Enable live ElasticSearch testing by setting env: TEST_ELASTICSEARCH=1"; } my %args = ( host => $ENV{TEST_HOST} || "localhost", port => "9200", method => "GET", ); my @tests = ( [ path => "/_stats" ], [ path => "/_search", body => q!{"query":{"match_all":{}}}! ], [ path => "/_search", query_string => "search_type=count", body => q!{"query":{"match_all":{}}}! ], ); for ((@tests) x (300)) { my $a = {%args, @$_ }; my $res = Hijk::request($a); if ($res->{error}) { fail "Error happened when requesting $a->{path}: $res->{error}"; } else { my $res_body = $res->{body}; my $test_name = "$a->{path}\t". substr($res_body, 0, 60)."...\n"; if (substr($res_body, 0, 1) eq '{' && substr($res_body, -1, 1) eq '}' ) { pass $test_name; } else { fail $test_name; } } } done_testing; Hijk-0.27/t/build_http_message.t0000644000175000017500000001034412673734616015636 0ustar gugodgugod#!/usr/bin/env perl use strict; use warnings; use Test::More; use Hijk; my $CRLF = "\x0d\x0a"; for my $protocol ("HTTP/1.0", "HTTP/1.1") { is Hijk::_build_http_message({ protocol => $protocol, host => "www.example.com" }), "GET / $protocol${CRLF}". "Host: www.example.com${CRLF}". "${CRLF}"; is Hijk::_build_http_message({ protocol => $protocol, host => "example.com" }), "GET / $protocol${CRLF}". "Host: example.com${CRLF}". "${CRLF}"; is Hijk::_build_http_message({ method => "HEAD", protocol => $protocol, host => "example.com" }), "HEAD / $protocol${CRLF}". "Host: example.com${CRLF}". "${CRLF}"; is Hijk::_build_http_message({ protocol => $protocol, host => "www.example.com", port => "8080" }), "GET / $protocol${CRLF}". "Host: www.example.com${CRLF}". "${CRLF}"; is Hijk::_build_http_message({ protocol => $protocol, host => "www.example.com", query_string => "a=b" }), "GET /?a=b $protocol${CRLF}". "Host: www.example.com${CRLF}". "${CRLF}"; is Hijk::_build_http_message({ protocol => $protocol, host => "www.example.com", path => "/flower" }), "GET /flower $protocol${CRLF}". "Host: www.example.com${CRLF}". "${CRLF}"; is Hijk::_build_http_message({ protocol => $protocol, host => "www.example.com", path => "/flower", query_string => "a=b" }), "GET /flower?a=b $protocol${CRLF}". "Host: www.example.com${CRLF}". "${CRLF}"; is Hijk::_build_http_message({ protocol => $protocol, host => "www.example.com", body => "morning" }), "GET / $protocol${CRLF}". "Host: www.example.com${CRLF}". "Content-Length: 7${CRLF}". "${CRLF}". "morning"; is Hijk::_build_http_message({ protocol => $protocol, host => "www.example.com", body => "0" }), "GET / $protocol${CRLF}". "Host: www.example.com${CRLF}". "Content-Length: 1${CRLF}". "${CRLF}". "0"; is Hijk::_build_http_message({ protocol => $protocol, host => "www.example.com", body => undef }), "GET / $protocol${CRLF}". "Host: www.example.com${CRLF}". "${CRLF}"; is Hijk::_build_http_message({ protocol => $protocol, host => "www.example.com", body => "" }), "GET / $protocol${CRLF}". "Host: www.example.com${CRLF}". "Content-Length: 0${CRLF}". "${CRLF}"; is Hijk::_build_http_message({ protocol => $protocol, host => "www.example.com", head => ["X-Head" => "extra stuff"] }), "GET / $protocol${CRLF}". "Host: www.example.com${CRLF}". "X-Head: extra stuff${CRLF}". "${CRLF}"; is Hijk::_build_http_message({ protocol => $protocol, host => "www.example.com", head => ["X-Head" => "extra stuff", "X-Hat" => "ditto"] }), "GET / $protocol${CRLF}". "Host: www.example.com${CRLF}". "X-Head: extra stuff${CRLF}". "X-Hat: ditto${CRLF}${CRLF}"; is Hijk::_build_http_message({ protocol => $protocol, host => "www.example.com", head => ["X-Head" => "extra stuff"], body => "OHAI" }), "GET / $protocol${CRLF}". "Host: www.example.com${CRLF}". "Content-Length: 4${CRLF}". "X-Head: extra stuff${CRLF}". "${CRLF}". "OHAI"; # Allow overriding Host header in head arrayref is Hijk::_build_http_message({ protocol => $protocol, host => "localhost", head => [ "Host" => "www.example.com" ], no_default_host_header => 1 }), "GET / $protocol${CRLF}". "Host: www.example.com${CRLF}${CRLF}"; # Also allow sending no Host header at all is Hijk::_build_http_message({ protocol => $protocol, host => "localhost", no_default_host_header => 1 }), "GET / $protocol${CRLF}${CRLF}"; is Hijk::_build_http_message({ protocol => $protocol, host => "localhost", head => [], no_default_host_header => 1 }), "GET / $protocol${CRLF}${CRLF}"; # Or even crazy multiple Host headers, whatever that means! is Hijk::_build_http_message({ protocol => $protocol, host => "localhost", head => [ Host => "foo", Host => "bar" ], no_default_host_header => 1 }), "GET / $protocol${CRLF}". "Host: foo${CRLF}". "Host: bar${CRLF}${CRLF}"; } done_testing; Hijk-0.27/t/parse-http-message.t0000644000175000017500000000202012673734616015475 0ustar gugodgugod#!/usr/bin/env perl use strict; use warnings; use Test::More; use File::Temp (); use File::Temp qw/ :seekable /; use Hijk; my $fh = File::Temp->new(); my $fd = do { local $/ = undef; my $msg = join( "\x0d\x0a", 'HTTP/1.1 200 OK', 'Date: Sat, 23 Nov 2013 23:10:28 GMT', 'Last-Modified: Sat, 26 Oct 2013 19:41:47 GMT', 'ETag: "4b9d0211dd8a2819866bccff777af225"', 'Content-Type: text/html', 'Server: Example', 'Content-Length: 4', '', 'OHAI' ); print $fh $msg; $fh->flush; $fh->seek(0, 0); fileno($fh); }; my (undef, $proto, $status, $head, $body) = Hijk::_read_http_message($fd, 10240); is $proto, "HTTP/1.1"; is $status, 200; is $body, "OHAI"; is_deeply $head, { "Date" => "Sat, 23 Nov 2013 23:10:28 GMT", "Last-Modified" => "Sat, 26 Oct 2013 19:41:47 GMT", "ETag" => '"4b9d0211dd8a2819866bccff777af225"', "Content-Type" => "text/html", "Content-Length" => "4", "Server" => "Example", }; done_testing; Hijk-0.27/t/live-couchdb.t0000644000175000017500000000374012673734616014342 0ustar gugodgugod#!/usr/bin/env perl use strict; use warnings; use Test::More; use Hijk; use URI; use Time::HiRes 'time'; plan skip_all => "Enable live testing by setting env: TEST_LIVE=1" unless $ENV{TEST_LIVE}; plan skip_all => "Enable live CouchDB testing by setting env: TEST_COUCHDB=http://localhost:5984/" unless $ENV{TEST_COUCHDB}; my $uri = URI->new($ENV{TEST_COUCHDB}); plan skip_all => "Fail to parse the value of TEST_COUCHDB: $ENV{TEST_COUCHDB}" unless $uri->isa("URI::http"); subtest "get the welcome message" => sub { my $rd = { host => $uri->host, port => $uri->port }; my $res; my $t0 = time; my $count = my $total = 1000; my $ok = 0; while ($count--) { $res = Hijk::request($rd); $ok++ if $res->{status} eq '200'; } my $t1 = time; is $ok, $total, sprintf("spent %f s", $t1 - $t0); }; subtest "create database, then delete it." => sub { my $db_name = "hijk_test_$$"; my $rd = { host => $uri->host, port => $uri->port, path => "/${db_name}", method => "PUT", }; my $res = Hijk::request($rd); if ($res->{status} eq '412') { pass "db $db_name already exists (unexpected, but it is fine): $res->{body}"; } else { pass "db $db_name created"; is $res->{status}, '201', "status = 201. see http://docs.couchdb.org/en/latest/intro/api.html#databases"; my $res2 = Hijk::request($rd); if ($res2->{status} eq '412') { pass "The 2nd creation request is done with error (expected): $res->{body}"; } else { fail "The 2nd request is done without error, that is unexpected. http_status = $res2->{status}, $res2->{body}"; } } $rd->{method} = "GET"; $res = Hijk::request($rd); is $res->{status}, '200', "$db_name exists. res_body = $res->{body}"; $rd->{method} = "DELETE"; $res = Hijk::request($rd); is $res->{status}, '200', "$db_name is deleted. res_body = $res->{body}"; }; done_testing; Hijk-0.27/t/live-plack.t0000644000175000017500000000304012740673744014015 0ustar gugodgugod#!/usr/bin/env perl use strict; use warnings; use FindBin; use Hijk; use Test::More; use Test::Exception; unless ($ENV{TEST_LIVE}) { plan skip_all => "Enable live testing by setting env: TEST_LIVE=1"; } my $pid = fork; die "Fail to fork then start a plack server" unless defined $pid; if ($pid == 0) { require Plack::Runner; my $runner = Plack::Runner->new; $runner->parse_options("--port", "5001", "$FindBin::Bin/bin/it-takes-time.psgi"); $runner->run; exit; } sleep 5; # hopfully this is enough to launch that psgi. my %args = ( host => "localhost", port => "5001", query_string => "t=5", method => "GET", ); subtest "expect connection failure (mismatching port number)" => sub { dies_ok { my $port = int 15001+rand()*3000; diag "Connecting to a wrong port: $port"; my $res = Hijk::request({%args, port => $port, timeout => 10}); } 'We connect to wrong port so, as expected, the connection cannot be established.'; diag "Dying message: $@"; }; subtest "expect read timeout" => sub { lives_ok { my $res = Hijk::request({%args, timeout => 1}); ok exists $res->{error}, '$res->{error} should exist becasue a read timeout is expected.'; is $res->{error}, Hijk::Error::READ_TIMEOUT, '$res->{error} == Hijk::Error::READ_TIMEOUT'; }; }; subtest "do not expect timeout" => sub { lives_ok { my $res = Hijk::request({%args, timeout => 10}); } 'local plack send back something within 10s'; }; END { kill INT => $pid if $pid } done_testing; Hijk-0.27/t/chunked-trailer-head-as-array.t0000644000175000017500000000313112673734616017465 0ustar gugodgugod#!/usr/bin/env perl use strict; use Test::More; use File::Temp (); use File::Temp qw/ :seekable /; use Hijk; my $fh = File::Temp->new(); my $fd = do { local $/ = undef; my $data = "4\r\nWiki\r\n5\r\npedia\r\ne\r\n in\r\n\r\nchunks.\r\n0\r\n"; my $msg = join( "\x0d\x0a", 'HTTP/1.1 200 OK', 'Last-Modified: Sat, 26 Oct 2013 19:41:47 GMT', 'ETag: "4b9d0211dd8a2819866bccff777af225"', 'Content-Type: text/html', 'Server: Example', 'Transfer-Encoding: chunked', 'Trailer: Date', 'non-sence: ' . 'a' x 20000, '', $data, 'Date: Sat, 23 Nov 2013 23:10:28 GMT', '' ); print $fh $msg; $fh->flush; $fh->seek(0, 0); fileno($fh); }; my (undef, $proto, $status, $head, $body) = Hijk::_read_http_message($fd, 10240, undef, 1, 1); is $status, 200; is $body, "Wikipedia in\r\n\r\nchunks."; is_deeply $head, [ "Last-Modified" => "Sat, 26 Oct 2013 19:41:47 GMT", "ETag" => '"4b9d0211dd8a2819866bccff777af225"', "Content-Type" => "text/html", "Server" => "Example", "Transfer-Encoding" => "chunked", 'Trailer' => 'Date', 'non-sence' => 'a' x 20000, ]; # fetch again without seeking back # this will force select() to return because there are actually # 0 bytes to read - so we can simulate connection closed # from the other end of the socket (like expired keep-alive) (undef, $proto, $status, $head, $body, my $error, my $error_message) = Hijk::_read_http_message($fd, 10240); is $error, Hijk::Error::RESPONSE_BAD_READ_VALUE; like $error_message, qr/0 byte/; done_testing; Hijk-0.27/t/live-head-request.t0000644000175000017500000000322012673734616015313 0ustar gugodgugod#!/usr/bin/env perl use strict; use warnings; use FindBin; use Hijk; use Test::More; unless ($ENV{TEST_LIVE}) { plan skip_all => "Enable live testing by setting env: TEST_LIVE=1"; } my $pid = fork; die "Fail to fork then start a plack server" unless defined $pid; if ($pid == 0) { require Plack::Runner; my $runner = Plack::Runner->new; $runner->parse_options("--port", "5002", "$FindBin::Bin/bin/head-request.psgi"); $runner->run; exit; } sleep 10; # hopfully this is enough to launch that psgi. my %args = ( timeout => 1, host => "localhost", port => "5002", method => "HEAD", ); subtest "expect HEAD response with a Content-Length" => sub { my $res = Hijk::request({%args, query_string => "gimme_content_length=1"}); ok !exists $res->{error}, '$res->{error} should not exist because this request should have been successful'; cmp_ok $res->{head}->{"Content-Length"}, "==", 11, "Got a Content-Length"; cmp_ok $res->{body}, "eq", "", "Got no body even though we had a Content-Length"; }; subtest "expect HEAD response without a Content-Length" => sub { my $res = Hijk::request({%args, query_string => "gimme_content_length="}); ok !exists $res->{error}, '$res->{error} should not exist because this request should have been successful'; TODO: { local $TODO = "I can't figure out how to get plackup(1) not to implicitly add Content-Length"; ok !exists $res->{head}->{"Content-Length"}, "We should get no Content-Length"; } cmp_ok $res->{body}, "eq", "", "Got no body wit the HEAD response, also have no Content-Length"; }; END { kill INT => $pid if $pid } done_testing; Hijk-0.27/t/parse-http-no-content-len-message.t0000644000175000017500000000231012673734616020335 0ustar gugodgugod#!/usr/bin/env perl use strict; use warnings; use Test::More; use File::Temp (); use File::Temp qw/ :seekable /; use Hijk; my $fh = File::Temp->new(); my $fd = do { local $/ = undef; my $msg = join( "\x0d\x0a", 'HTTP/1.1 200 OK', 'Date: Sat, 23 Nov 2013 23:10:28 GMT', 'Last-Modified: Sat, 26 Oct 2013 19:41:47 GMT', 'ETag: "4b9d0211dd8a2819866bccff777af225"', 'Content-Type: text/html', 'Server: Example', 'Connection: close', '', 'a' x 100000 ); print $fh $msg; $fh->flush; $fh->seek(0, 0); fileno($fh); }; my (undef, $proto, $status, $head, $body) = Hijk::_read_http_message($fd, 10240, 0); is $status, 200; is_deeply $head, { "Date" => "Sat, 23 Nov 2013 23:10:28 GMT", "Last-Modified" => "Sat, 26 Oct 2013 19:41:47 GMT", "ETag" => '"4b9d0211dd8a2819866bccff777af225"', "Content-Type" => "text/html", "Server" => "Example", "Connection" => "close", }; is $body, 'a' x 100000; (undef, $proto, $status, $head, $body, my $error, my $error_message) = Hijk::_read_http_message($fd, 10240); is $error, Hijk::Error::RESPONSE_BAD_READ_VALUE; like $error_message, qr/0 byte/; done_testing; Hijk-0.27/inc/0000755000175000017500000000000013004630023012063 5ustar gugodgugodHijk-0.27/inc/Module/0000755000175000017500000000000013004630023013310 5ustar gugodgugodHijk-0.27/inc/Module/CPANfile.pm0000644000175000017500000001135013004630022015226 0ustar gugodgugod#line 1 package Module::CPANfile; use strict; use warnings; use Cwd; use Carp (); use Module::CPANfile::Environment; use Module::CPANfile::Requirement; our $VERSION = '1.1002'; BEGIN { if (${^TAINT}) { *untaint = sub { my $str = shift; ($str) = $str =~ /^(.+)$/s; $str; }; } else { *untaint = sub { $_[0] }; } } sub new { my($class, $file) = @_; bless {}, $class; } sub load { my($proto, $file) = @_; my $self = ref $proto ? $proto : $proto->new; $self->parse($file || _default_cpanfile()); $self; } sub save { my($self, $path) = @_; open my $out, ">", $path or die "$path: $!"; print {$out} $self->to_string; } sub parse { my($self, $file) = @_; my $code = do { open my $fh, "<", $file or die "$file: $!"; join '', <$fh>; }; $code = untaint $code; my $env = Module::CPANfile::Environment->new($file); $env->parse($code) or die $@; $self->{_mirrors} = $env->mirrors; $self->{_prereqs} = $env->prereqs; } sub from_prereqs { my($proto, $prereqs) = @_; my $self = $proto->new; $self->{_prereqs} = Module::CPANfile::Prereqs->from_cpan_meta($prereqs); $self; } sub mirrors { my $self = shift; $self->{_mirrors} || []; } sub features { my $self = shift; map $self->feature($_), $self->{_prereqs}->identifiers; } sub feature { my($self, $identifier) = @_; $self->{_prereqs}->feature($identifier); } sub prereq { shift->prereqs } sub prereqs { my $self = shift; $self->{_prereqs}->as_cpan_meta; } sub merged_requirements { my $self = shift; $self->{_prereqs}->merged_requirements; } sub effective_prereqs { my($self, $features) = @_; $self->prereqs_with(@{$features || []}); } sub prereqs_with { my($self, @feature_identifiers) = @_; my $prereqs = $self->prereqs; my @others = map { $self->feature($_)->prereqs } @feature_identifiers; $prereqs->with_merged_prereqs(\@others); } sub prereq_specs { my $self = shift; $self->prereqs->as_string_hash; } sub prereq_for_module { my($self, $module) = @_; $self->{_prereqs}->find($module); } sub options_for_module { my($self, $module) = @_; my $prereq = $self->prereq_for_module($module) or return; $prereq->requirement->options; } sub merge_meta { my($self, $file, $version) = @_; require CPAN::Meta; $version ||= $file =~ /\.yml$/ ? '1.4' : '2'; my $prereq = $self->prereqs; my $meta = CPAN::Meta->load_file($file); my $prereqs_hash = $prereq->with_merged_prereqs($meta->effective_prereqs)->as_string_hash; my $struct = { %{$meta->as_struct}, prereqs => $prereqs_hash }; CPAN::Meta->new($struct)->save($file, { version => $version }); } sub _dump { my $str = shift; require Data::Dumper; chomp(my $value = Data::Dumper->new([$str])->Terse(1)->Dump); $value; } sub _default_cpanfile { my $file = Cwd::abs_path('cpanfile'); untaint $file; } sub to_string { my($self, $include_empty) = @_; my $mirrors = $self->mirrors; my $prereqs = $self->prereq_specs; my $code = ''; $code .= $self->_dump_mirrors($mirrors); $code .= $self->_dump_prereqs($prereqs, $include_empty); for my $feature ($self->features) { $code .= sprintf "feature %s, %s => sub {\n", _dump($feature->{identifier}), _dump($feature->{description}); $code .= $self->_dump_prereqs($feature->{spec}, $include_empty, 4); $code .= "}\n\n"; } $code =~ s/\n+$/\n/s; $code; } sub _dump_mirrors { my($self, $mirrors) = @_; my $code = ""; for my $url (@$mirrors) { $code .= "mirror '$url';\n"; } $code =~ s/\n+$/\n/s; $code; } sub _dump_prereqs { my($self, $prereqs, $include_empty, $base_indent) = @_; my $code = ''; for my $phase (qw(runtime configure build test develop)) { my $indent = $phase eq 'runtime' ? '' : ' '; $indent = (' ' x ($base_indent || 0)) . $indent; my($phase_code, $requirements); $phase_code .= "on $phase => sub {\n" unless $phase eq 'runtime'; for my $type (qw(requires recommends suggests conflicts)) { for my $mod (sort keys %{$prereqs->{$phase}{$type}}) { my $ver = $prereqs->{$phase}{$type}{$mod}; $phase_code .= $ver eq '0' ? "${indent}$type '$mod';\n" : "${indent}$type '$mod', '$ver';\n"; $requirements++; } } $phase_code .= "\n" unless $requirements; $phase_code .= "};\n" unless $phase eq 'runtime'; $code .= $phase_code . "\n" if $requirements or $include_empty; } $code =~ s/\n+$/\n/s; $code; } 1; __END__ #line 342 Hijk-0.27/inc/Module/Install/0000755000175000017500000000000013004630023014716 5ustar gugodgugodHijk-0.27/inc/Module/Install/CPANfile.pm0000644000175000017500000000304613004630021016636 0ustar gugodgugod#line 1 package Module::Install::CPANfile; use strict; use 5.008_001; our $VERSION = '0.12'; use Module::CPANfile; use base qw(Module::Install::Base); sub merge_meta_with_cpanfile { my $self = shift; require CPAN::Meta; my $file = Module::CPANfile->load; if ($self->is_admin) { # force generate META.json CPAN::Meta->load_file('META.yml')->save('META.json'); print "Regenerate META.json and META.yml using cpanfile\n"; $file->merge_meta('META.yml'); $file->merge_meta('META.json'); } for my $metafile (grep -e, qw(MYMETA.yml MYMETA.json)) { print "Merging cpanfile prereqs to $metafile\n"; $file->merge_meta($metafile); } } sub cpanfile { my($self, %options) = @_; $self->dynamic_config(0) unless $options{dynamic}; my $write_all = \&::WriteAll; *main::WriteAll = sub { $write_all->(@_); $self->merge_meta_with_cpanfile; }; $self->configure_requires("CPAN::Meta"); if ($self->is_admin) { $self->admin->include_one_dist("Module::CPANfile"); if (eval { require CPAN::Meta::Check; 1 }) { my $prereqs = Module::CPANfile->load->prereqs; my @err = CPAN::Meta::Check::verify_dependencies($prereqs, [qw/runtime build test develop/], 'requires'); for (@err) { warn "Warning: $_\n"; } } else { warn "CPAN::Meta::Check is not installed. Skipping dependencies check for the author.\n"; } } } 1; __END__ =encoding utf-8 #line 149 Hijk-0.27/inc/Module/Install/WriteAll.pm0000644000175000017500000000237613004630022017006 0ustar gugodgugod#line 1 package Module::Install::WriteAll; use strict; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.17'; @ISA = qw{Module::Install::Base}; $ISCORE = 1; } sub WriteAll { my $self = shift; my %args = ( meta => 1, sign => 0, inline => 0, check_nmake => 1, @_, ); $self->sign(1) if $args{sign}; $self->admin->WriteAll(%args) if $self->is_admin; $self->check_nmake if $args{check_nmake}; unless ( $self->makemaker_args->{PL_FILES} ) { # XXX: This still may be a bit over-defensive... unless ($self->makemaker(6.25)) { $self->makemaker_args( PL_FILES => {} ) if -f 'Build.PL'; } } # Until ExtUtils::MakeMaker support MYMETA.yml, make sure # we clean it up properly ourself. $self->realclean_files('MYMETA.yml'); if ( $args{inline} ) { $self->Inline->write; } else { $self->Makefile->write; } # The Makefile write process adds a couple of dependencies, # so write the META.yml files after the Makefile. if ( $args{meta} ) { $self->Meta->write; } # Experimental support for MYMETA if ( $ENV{X_MYMETA} ) { if ( $ENV{X_MYMETA} eq 'JSON' ) { $self->Meta->write_mymeta_json; } else { $self->Meta->write_mymeta_yaml; } } return 1; } 1; Hijk-0.27/inc/Module/Install/Can.pm0000644000175000017500000000640513004630022015761 0ustar gugodgugod#line 1 package Module::Install::Can; use strict; use Config (); use ExtUtils::MakeMaker (); use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.17'; @ISA = 'Module::Install::Base'; $ISCORE = 1; } # check if we can load some module ### Upgrade this to not have to load the module if possible sub can_use { my ($self, $mod, $ver) = @_; $mod =~ s{::|\\}{/}g; $mod .= '.pm' unless $mod =~ /\.pm$/i; my $pkg = $mod; $pkg =~ s{/}{::}g; $pkg =~ s{\.pm$}{}i; local $@; eval { require $mod; $pkg->VERSION($ver || 0); 1 }; } # Check if we can run some command sub can_run { my ($self, $cmd) = @_; my $_cmd = $cmd; return $_cmd if (-x $_cmd or $_cmd = MM->maybe_command($_cmd)); for my $dir ((split /$Config::Config{path_sep}/, $ENV{PATH}), '.') { next if $dir eq ''; require File::Spec; my $abs = File::Spec->catfile($dir, $cmd); return $abs if (-x $abs or $abs = MM->maybe_command($abs)); } return; } # Can our C compiler environment build XS files sub can_xs { my $self = shift; # Ensure we have the CBuilder module $self->configure_requires( 'ExtUtils::CBuilder' => 0.27 ); # Do we have the configure_requires checker? local $@; eval "require ExtUtils::CBuilder;"; if ( $@ ) { # They don't obey configure_requires, so it is # someone old and delicate. Try to avoid hurting # them by falling back to an older simpler test. return $self->can_cc(); } # Do we have a working C compiler my $builder = ExtUtils::CBuilder->new( quiet => 1, ); unless ( $builder->have_compiler ) { # No working C compiler return 0; } # Write a C file representative of what XS becomes require File::Temp; my ( $FH, $tmpfile ) = File::Temp::tempfile( "compilexs-XXXXX", SUFFIX => '.c', ); binmode $FH; print $FH <<'END_C'; #include "EXTERN.h" #include "perl.h" #include "XSUB.h" int main(int argc, char **argv) { return 0; } int boot_sanexs() { return 1; } END_C close $FH; # Can the C compiler access the same headers XS does my @libs = (); my $object = undef; eval { local $^W = 0; $object = $builder->compile( source => $tmpfile, ); @libs = $builder->link( objects => $object, module_name => 'sanexs', ); }; my $result = $@ ? 0 : 1; # Clean up all the build files foreach ( $tmpfile, $object, @libs ) { next unless defined $_; 1 while unlink; } return $result; } # Can we locate a (the) C compiler sub can_cc { my $self = shift; if ($^O eq 'VMS') { require ExtUtils::CBuilder; my $builder = ExtUtils::CBuilder->new( quiet => 1, ); return $builder->have_compiler; } my @chunks = split(/ /, $Config::Config{cc}) or return; # $Config{cc} may contain args; try to find out the program part while (@chunks) { return $self->can_run("@chunks") || (pop(@chunks), next); } return; } # Fix Cygwin bug on maybe_command(); if ( $^O eq 'cygwin' ) { require ExtUtils::MM_Cygwin; require ExtUtils::MM_Win32; if ( ! defined(&ExtUtils::MM_Cygwin::maybe_command) ) { *ExtUtils::MM_Cygwin::maybe_command = sub { my ($self, $file) = @_; if ($file =~ m{^/cygdrive/}i and ExtUtils::MM_Win32->can('maybe_command')) { ExtUtils::MM_Win32->maybe_command($file); } else { ExtUtils::MM_Unix->maybe_command($file); } } } } 1; __END__ #line 245 Hijk-0.27/inc/Module/Install/Makefile.pm0000644000175000017500000002743713004630021017004 0ustar gugodgugod#line 1 package Module::Install::Makefile; use strict 'vars'; use ExtUtils::MakeMaker (); use Module::Install::Base (); use Fcntl qw/:flock :seek/; use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.17'; @ISA = 'Module::Install::Base'; $ISCORE = 1; } sub Makefile { $_[0] } my %seen = (); sub prompt { shift; # Infinite loop protection my @c = caller(); if ( ++$seen{"$c[1]|$c[2]|$_[0]"} > 3 ) { die "Caught an potential prompt infinite loop ($c[1]|$c[2]|$_[0])"; } # In automated testing or non-interactive session, always use defaults if ( ($ENV{AUTOMATED_TESTING} or -! -t STDIN) and ! $ENV{PERL_MM_USE_DEFAULT} ) { local $ENV{PERL_MM_USE_DEFAULT} = 1; goto &ExtUtils::MakeMaker::prompt; } else { goto &ExtUtils::MakeMaker::prompt; } } # Store a cleaned up version of the MakeMaker version, # since we need to behave differently in a variety of # ways based on the MM version. my $makemaker = eval $ExtUtils::MakeMaker::VERSION; # If we are passed a param, do a "newer than" comparison. # Otherwise, just return the MakeMaker version. sub makemaker { ( @_ < 2 or $makemaker >= eval($_[1]) ) ? $makemaker : 0 } # Ripped from ExtUtils::MakeMaker 6.56, and slightly modified # as we only need to know here whether the attribute is an array # or a hash or something else (which may or may not be appendable). my %makemaker_argtype = ( C => 'ARRAY', CONFIG => 'ARRAY', # CONFIGURE => 'CODE', # ignore DIR => 'ARRAY', DL_FUNCS => 'HASH', DL_VARS => 'ARRAY', EXCLUDE_EXT => 'ARRAY', EXE_FILES => 'ARRAY', FUNCLIST => 'ARRAY', H => 'ARRAY', IMPORTS => 'HASH', INCLUDE_EXT => 'ARRAY', LIBS => 'ARRAY', # ignore '' MAN1PODS => 'HASH', MAN3PODS => 'HASH', META_ADD => 'HASH', META_MERGE => 'HASH', PL_FILES => 'HASH', PM => 'HASH', PMLIBDIRS => 'ARRAY', PMLIBPARENTDIRS => 'ARRAY', PREREQ_PM => 'HASH', CONFIGURE_REQUIRES => 'HASH', SKIP => 'ARRAY', TYPEMAPS => 'ARRAY', XS => 'HASH', # VERSION => ['version',''], # ignore # _KEEP_AFTER_FLUSH => '', clean => 'HASH', depend => 'HASH', dist => 'HASH', dynamic_lib=> 'HASH', linkext => 'HASH', macro => 'HASH', postamble => 'HASH', realclean => 'HASH', test => 'HASH', tool_autosplit => 'HASH', # special cases where you can use makemaker_append CCFLAGS => 'APPENDABLE', DEFINE => 'APPENDABLE', INC => 'APPENDABLE', LDDLFLAGS => 'APPENDABLE', LDFROM => 'APPENDABLE', ); sub makemaker_args { my ($self, %new_args) = @_; my $args = ( $self->{makemaker_args} ||= {} ); foreach my $key (keys %new_args) { if ($makemaker_argtype{$key}) { if ($makemaker_argtype{$key} eq 'ARRAY') { $args->{$key} = [] unless defined $args->{$key}; unless (ref $args->{$key} eq 'ARRAY') { $args->{$key} = [$args->{$key}] } push @{$args->{$key}}, ref $new_args{$key} eq 'ARRAY' ? @{$new_args{$key}} : $new_args{$key}; } elsif ($makemaker_argtype{$key} eq 'HASH') { $args->{$key} = {} unless defined $args->{$key}; foreach my $skey (keys %{ $new_args{$key} }) { $args->{$key}{$skey} = $new_args{$key}{$skey}; } } elsif ($makemaker_argtype{$key} eq 'APPENDABLE') { $self->makemaker_append($key => $new_args{$key}); } } else { if (defined $args->{$key}) { warn qq{MakeMaker attribute "$key" is overriden; use "makemaker_append" to append values\n}; } $args->{$key} = $new_args{$key}; } } return $args; } # For mm args that take multiple space-separated args, # append an argument to the current list. sub makemaker_append { my $self = shift; my $name = shift; my $args = $self->makemaker_args; $args->{$name} = defined $args->{$name} ? join( ' ', $args->{$name}, @_ ) : join( ' ', @_ ); } sub build_subdirs { my $self = shift; my $subdirs = $self->makemaker_args->{DIR} ||= []; for my $subdir (@_) { push @$subdirs, $subdir; } } sub clean_files { my $self = shift; my $clean = $self->makemaker_args->{clean} ||= {}; %$clean = ( %$clean, FILES => join ' ', grep { length $_ } ($clean->{FILES} || (), @_), ); } sub realclean_files { my $self = shift; my $realclean = $self->makemaker_args->{realclean} ||= {}; %$realclean = ( %$realclean, FILES => join ' ', grep { length $_ } ($realclean->{FILES} || (), @_), ); } sub libs { my $self = shift; my $libs = ref $_[0] ? shift : [ shift ]; $self->makemaker_args( LIBS => $libs ); } sub inc { my $self = shift; $self->makemaker_args( INC => shift ); } sub _wanted_t { } sub tests_recursive { my $self = shift; my $dir = shift || 't'; unless ( -d $dir ) { die "tests_recursive dir '$dir' does not exist"; } my %tests = map { $_ => 1 } split / /, ($self->tests || ''); require File::Find; File::Find::find( sub { /\.t$/ and -f $_ and $tests{"$File::Find::dir/*.t"} = 1 }, $dir ); $self->tests( join ' ', sort keys %tests ); } sub write { my $self = shift; die "&Makefile->write() takes no arguments\n" if @_; # Check the current Perl version my $perl_version = $self->perl_version; if ( $perl_version ) { eval "use $perl_version; 1" or die "ERROR: perl: Version $] is installed, " . "but we need version >= $perl_version"; } # Make sure we have a new enough MakeMaker require ExtUtils::MakeMaker; if ( $perl_version and $self->_cmp($perl_version, '5.006') >= 0 ) { # This previous attempted to inherit the version of # ExtUtils::MakeMaker in use by the module author, but this # was found to be untenable as some authors build releases # using future dev versions of EU:MM that nobody else has. # Instead, #toolchain suggests we use 6.59 which is the most # stable version on CPAN at time of writing and is, to quote # ribasushi, "not terminally fucked, > and tested enough". # TODO: We will now need to maintain this over time to push # the version up as new versions are released. $self->build_requires( 'ExtUtils::MakeMaker' => 6.59 ); $self->configure_requires( 'ExtUtils::MakeMaker' => 6.59 ); } else { # Allow legacy-compatibility with 5.005 by depending on the # most recent EU:MM that supported 5.005. $self->build_requires( 'ExtUtils::MakeMaker' => 6.36 ); $self->configure_requires( 'ExtUtils::MakeMaker' => 6.36 ); } # Generate the MakeMaker params my $args = $self->makemaker_args; $args->{DISTNAME} = $self->name; $args->{NAME} = $self->module_name || $self->name; $args->{NAME} =~ s/-/::/g; $args->{VERSION} = $self->version or die <<'EOT'; ERROR: Can't determine distribution version. Please specify it explicitly via 'version' in Makefile.PL, or set a valid $VERSION in a module, and provide its file path via 'version_from' (or 'all_from' if you prefer) in Makefile.PL. EOT if ( $self->tests ) { my @tests = split ' ', $self->tests; my %seen; $args->{test} = { TESTS => (join ' ', grep {!$seen{$_}++} @tests), }; } elsif ( $Module::Install::ExtraTests::use_extratests ) { # Module::Install::ExtraTests doesn't set $self->tests and does its own tests via harness. # So, just ignore our xt tests here. } elsif ( -d 'xt' and ($Module::Install::AUTHOR or $ENV{RELEASE_TESTING}) ) { $args->{test} = { TESTS => join( ' ', map { "$_/*.t" } grep { -d $_ } qw{ t xt } ), }; } if ( $] >= 5.005 ) { $args->{ABSTRACT} = $self->abstract; $args->{AUTHOR} = join ', ', @{$self->author || []}; } if ( $self->makemaker(6.10) ) { $args->{NO_META} = 1; #$args->{NO_MYMETA} = 1; } if ( $self->makemaker(6.17) and $self->sign ) { $args->{SIGN} = 1; } unless ( $self->is_admin ) { delete $args->{SIGN}; } if ( $self->makemaker(6.31) and $self->license ) { $args->{LICENSE} = $self->license; } my $prereq = ($args->{PREREQ_PM} ||= {}); %$prereq = ( %$prereq, map { @$_ } # flatten [module => version] map { @$_ } grep $_, ($self->requires) ); # Remove any reference to perl, PREREQ_PM doesn't support it delete $args->{PREREQ_PM}->{perl}; # Merge both kinds of requires into BUILD_REQUIRES my $build_prereq = ($args->{BUILD_REQUIRES} ||= {}); %$build_prereq = ( %$build_prereq, map { @$_ } # flatten [module => version] map { @$_ } grep $_, ($self->configure_requires, $self->build_requires) ); # Remove any reference to perl, BUILD_REQUIRES doesn't support it delete $args->{BUILD_REQUIRES}->{perl}; # Delete bundled dists from prereq_pm, add it to Makefile DIR my $subdirs = ($args->{DIR} || []); if ($self->bundles) { my %processed; foreach my $bundle (@{ $self->bundles }) { my ($mod_name, $dist_dir) = @$bundle; delete $prereq->{$mod_name}; $dist_dir = File::Basename::basename($dist_dir); # dir for building this module if (not exists $processed{$dist_dir}) { if (-d $dist_dir) { # List as sub-directory to be processed by make push @$subdirs, $dist_dir; } # Else do nothing: the module is already present on the system $processed{$dist_dir} = undef; } } } unless ( $self->makemaker('6.55_03') ) { %$prereq = (%$prereq,%$build_prereq); delete $args->{BUILD_REQUIRES}; } if ( my $perl_version = $self->perl_version ) { eval "use $perl_version; 1" or die "ERROR: perl: Version $] is installed, " . "but we need version >= $perl_version"; if ( $self->makemaker(6.48) ) { $args->{MIN_PERL_VERSION} = $perl_version; } } if ($self->installdirs) { warn qq{old INSTALLDIRS (probably set by makemaker_args) is overriden by installdirs\n} if $args->{INSTALLDIRS}; $args->{INSTALLDIRS} = $self->installdirs; } my %args = map { ( $_ => $args->{$_} ) } grep {defined($args->{$_} ) } keys %$args; my $user_preop = delete $args{dist}->{PREOP}; if ( my $preop = $self->admin->preop($user_preop) ) { foreach my $key ( keys %$preop ) { $args{dist}->{$key} = $preop->{$key}; } } my $mm = ExtUtils::MakeMaker::WriteMakefile(%args); $self->fix_up_makefile($mm->{FIRST_MAKEFILE} || 'Makefile'); } sub fix_up_makefile { my $self = shift; my $makefile_name = shift; my $top_class = ref($self->_top) || ''; my $top_version = $self->_top->VERSION || ''; my $preamble = $self->preamble ? "# Preamble by $top_class $top_version\n" . $self->preamble : ''; my $postamble = "# Postamble by $top_class $top_version\n" . ($self->postamble || ''); local *MAKEFILE; open MAKEFILE, "+< $makefile_name" or die "fix_up_makefile: Couldn't open $makefile_name: $!"; eval { flock MAKEFILE, LOCK_EX }; my $makefile = do { local $/; }; $makefile =~ s/\b(test_harness\(\$\(TEST_VERBOSE\), )/$1'inc', /; $makefile =~ s/( -I\$\(INST_ARCHLIB\))/ -Iinc$1/g; $makefile =~ s/( "-I\$\(INST_LIB\)")/ "-Iinc"$1/g; $makefile =~ s/^(FULLPERL = .*)/$1 "-Iinc"/m; $makefile =~ s/^(PERL = .*)/$1 "-Iinc"/m; # Module::Install will never be used to build the Core Perl # Sometimes PERL_LIB and PERL_ARCHLIB get written anyway, which breaks # PREFIX/PERL5LIB, and thus, install_share. Blank them if they exist $makefile =~ s/^PERL_LIB = .+/PERL_LIB =/m; #$makefile =~ s/^PERL_ARCHLIB = .+/PERL_ARCHLIB =/m; # Perl 5.005 mentions PERL_LIB explicitly, so we have to remove that as well. $makefile =~ s/(\"?)-I\$\(PERL_LIB\)\1//g; # XXX - This is currently unused; not sure if it breaks other MM-users # $makefile =~ s/^pm_to_blib\s+:\s+/pm_to_blib :: /mg; seek MAKEFILE, 0, SEEK_SET; truncate MAKEFILE, 0; print MAKEFILE "$preamble$makefile$postamble" or die $!; close MAKEFILE or die $!; 1; } sub preamble { my ($self, $text) = @_; $self->{preamble} = $text . $self->{preamble} if defined $text; $self->{preamble}; } sub postamble { my ($self, $text) = @_; $self->{postamble} ||= $self->admin->postamble; $self->{postamble} .= $text if defined $text; $self->{postamble} } 1; __END__ #line 544 Hijk-0.27/inc/Module/Install/Win32.pm0000644000175000017500000000340313004630022016155 0ustar gugodgugod#line 1 package Module::Install::Win32; use strict; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.17'; @ISA = 'Module::Install::Base'; $ISCORE = 1; } # determine if the user needs nmake, and download it if needed sub check_nmake { my $self = shift; $self->load('can_run'); $self->load('get_file'); require Config; return unless ( $^O eq 'MSWin32' and $Config::Config{make} and $Config::Config{make} =~ /^nmake\b/i and ! $self->can_run('nmake') ); print "The required 'nmake' executable not found, fetching it...\n"; require File::Basename; my $rv = $self->get_file( url => 'http://download.microsoft.com/download/vc15/Patch/1.52/W95/EN-US/Nmake15.exe', ftp_url => 'ftp://ftp.microsoft.com/Softlib/MSLFILES/Nmake15.exe', local_dir => File::Basename::dirname($^X), size => 51928, run => 'Nmake15.exe /o > nul', check_for => 'Nmake.exe', remove => 1, ); die <<'END_MESSAGE' unless $rv; ------------------------------------------------------------------------------- Since you are using Microsoft Windows, you will need the 'nmake' utility before installation. It's available at: http://download.microsoft.com/download/vc15/Patch/1.52/W95/EN-US/Nmake15.exe or ftp://ftp.microsoft.com/Softlib/MSLFILES/Nmake15.exe Please download the file manually, save it to a directory in %PATH% (e.g. C:\WINDOWS\COMMAND\), then launch the MS-DOS command line shell, "cd" to that directory, and run "Nmake15.exe" from there; that will create the 'nmake.exe' file needed by this module. You may then resume the installation process described in README. ------------------------------------------------------------------------------- END_MESSAGE } 1; Hijk-0.27/inc/Module/Install/Base.pm0000644000175000017500000000214713004630021016130 0ustar gugodgugod#line 1 package Module::Install::Base; use strict 'vars'; use vars qw{$VERSION}; BEGIN { $VERSION = '1.17'; } # Suspend handler for "redefined" warnings BEGIN { my $w = $SIG{__WARN__}; $SIG{__WARN__} = sub { $w }; } #line 42 sub new { my $class = shift; unless ( defined &{"${class}::call"} ) { *{"${class}::call"} = sub { shift->_top->call(@_) }; } unless ( defined &{"${class}::load"} ) { *{"${class}::load"} = sub { shift->_top->load(@_) }; } bless { @_ }, $class; } #line 61 sub AUTOLOAD { local $@; my $func = eval { shift->_top->autoload } or return; goto &$func; } #line 75 sub _top { $_[0]->{_top}; } #line 90 sub admin { $_[0]->_top->{admin} or Module::Install::Base::FakeAdmin->new; } #line 106 sub is_admin { ! $_[0]->admin->isa('Module::Install::Base::FakeAdmin'); } sub DESTROY {} package Module::Install::Base::FakeAdmin; use vars qw{$VERSION}; BEGIN { $VERSION = $Module::Install::Base::VERSION; } my $fake; sub new { $fake ||= bless(\@_, $_[0]); } sub AUTOLOAD {} sub DESTROY {} # Restore warning handler BEGIN { $SIG{__WARN__} = $SIG{__WARN__}->(); } 1; #line 159 Hijk-0.27/inc/Module/Install/Metadata.pm0000644000175000017500000004330213004630021016774 0ustar gugodgugod#line 1 package Module::Install::Metadata; use strict 'vars'; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.17'; @ISA = 'Module::Install::Base'; $ISCORE = 1; } my @boolean_keys = qw{ sign }; my @scalar_keys = qw{ name module_name abstract version distribution_type tests installdirs }; my @tuple_keys = qw{ configure_requires build_requires requires recommends bundles resources }; my @resource_keys = qw{ homepage bugtracker repository }; my @array_keys = qw{ keywords author }; *authors = \&author; sub Meta { shift } sub Meta_BooleanKeys { @boolean_keys } sub Meta_ScalarKeys { @scalar_keys } sub Meta_TupleKeys { @tuple_keys } sub Meta_ResourceKeys { @resource_keys } sub Meta_ArrayKeys { @array_keys } foreach my $key ( @boolean_keys ) { *$key = sub { my $self = shift; if ( defined wantarray and not @_ ) { return $self->{values}->{$key}; } $self->{values}->{$key} = ( @_ ? $_[0] : 1 ); return $self; }; } foreach my $key ( @scalar_keys ) { *$key = sub { my $self = shift; return $self->{values}->{$key} if defined wantarray and !@_; $self->{values}->{$key} = shift; return $self; }; } foreach my $key ( @array_keys ) { *$key = sub { my $self = shift; return $self->{values}->{$key} if defined wantarray and !@_; $self->{values}->{$key} ||= []; push @{$self->{values}->{$key}}, @_; return $self; }; } foreach my $key ( @resource_keys ) { *$key = sub { my $self = shift; unless ( @_ ) { return () unless $self->{values}->{resources}; return map { $_->[1] } grep { $_->[0] eq $key } @{ $self->{values}->{resources} }; } return $self->{values}->{resources}->{$key} unless @_; my $uri = shift or die( "Did not provide a value to $key()" ); $self->resources( $key => $uri ); return 1; }; } foreach my $key ( grep { $_ ne "resources" } @tuple_keys) { *$key = sub { my $self = shift; return $self->{values}->{$key} unless @_; my @added; while ( @_ ) { my $module = shift or last; my $version = shift || 0; push @added, [ $module, $version ]; } push @{ $self->{values}->{$key} }, @added; return map {@$_} @added; }; } # Resource handling my %lc_resource = map { $_ => 1 } qw{ homepage license bugtracker repository }; sub resources { my $self = shift; while ( @_ ) { my $name = shift or last; my $value = shift or next; if ( $name eq lc $name and ! $lc_resource{$name} ) { die("Unsupported reserved lowercase resource '$name'"); } $self->{values}->{resources} ||= []; push @{ $self->{values}->{resources} }, [ $name, $value ]; } $self->{values}->{resources}; } # Aliases for build_requires that will have alternative # meanings in some future version of META.yml. sub test_requires { shift->build_requires(@_) } sub install_requires { shift->build_requires(@_) } # Aliases for installdirs options sub install_as_core { $_[0]->installdirs('perl') } sub install_as_cpan { $_[0]->installdirs('site') } sub install_as_site { $_[0]->installdirs('site') } sub install_as_vendor { $_[0]->installdirs('vendor') } sub dynamic_config { my $self = shift; my $value = @_ ? shift : 1; if ( $self->{values}->{dynamic_config} ) { # Once dynamic we never change to static, for safety return 0; } $self->{values}->{dynamic_config} = $value ? 1 : 0; return 1; } # Convenience command sub static_config { shift->dynamic_config(0); } sub perl_version { my $self = shift; return $self->{values}->{perl_version} unless @_; my $version = shift or die( "Did not provide a value to perl_version()" ); # Normalize the version $version = $self->_perl_version($version); # We don't support the really old versions unless ( $version >= 5.005 ) { die "Module::Install only supports 5.005 or newer (use ExtUtils::MakeMaker)\n"; } $self->{values}->{perl_version} = $version; } sub all_from { my ( $self, $file ) = @_; unless ( defined($file) ) { my $name = $self->name or die( "all_from called with no args without setting name() first" ); $file = join('/', 'lib', split(/-/, $name)) . '.pm'; $file =~ s{.*/}{} unless -e $file; unless ( -e $file ) { die("all_from cannot find $file from $name"); } } unless ( -f $file ) { die("The path '$file' does not exist, or is not a file"); } $self->{values}{all_from} = $file; # Some methods pull from POD instead of code. # If there is a matching .pod, use that instead my $pod = $file; $pod =~ s/\.pm$/.pod/i; $pod = $file unless -e $pod; # Pull the different values $self->name_from($file) unless $self->name; $self->version_from($file) unless $self->version; $self->perl_version_from($file) unless $self->perl_version; $self->author_from($pod) unless @{$self->author || []}; $self->license_from($pod) unless $self->license; $self->abstract_from($pod) unless $self->abstract; return 1; } sub provides { my $self = shift; my $provides = ( $self->{values}->{provides} ||= {} ); %$provides = (%$provides, @_) if @_; return $provides; } sub auto_provides { my $self = shift; return $self unless $self->is_admin; unless (-e 'MANIFEST') { warn "Cannot deduce auto_provides without a MANIFEST, skipping\n"; return $self; } # Avoid spurious warnings as we are not checking manifest here. local $SIG{__WARN__} = sub {1}; require ExtUtils::Manifest; local *ExtUtils::Manifest::manicheck = sub { return }; require Module::Build; my $build = Module::Build->new( dist_name => $self->name, dist_version => $self->version, license => $self->license, ); $self->provides( %{ $build->find_dist_packages || {} } ); } sub feature { my $self = shift; my $name = shift; my $features = ( $self->{values}->{features} ||= [] ); my $mods; if ( @_ == 1 and ref( $_[0] ) ) { # The user used ->feature like ->features by passing in the second # argument as a reference. Accomodate for that. $mods = $_[0]; } else { $mods = \@_; } my $count = 0; push @$features, ( $name => [ map { ref($_) ? ( ref($_) eq 'HASH' ) ? %$_ : @$_ : $_ } @$mods ] ); return @$features; } sub features { my $self = shift; while ( my ( $name, $mods ) = splice( @_, 0, 2 ) ) { $self->feature( $name, @$mods ); } return $self->{values}->{features} ? @{ $self->{values}->{features} } : (); } sub no_index { my $self = shift; my $type = shift; push @{ $self->{values}->{no_index}->{$type} }, @_ if $type; return $self->{values}->{no_index}; } sub read { my $self = shift; $self->include_deps( 'YAML::Tiny', 0 ); require YAML::Tiny; my $data = YAML::Tiny::LoadFile('META.yml'); # Call methods explicitly in case user has already set some values. while ( my ( $key, $value ) = each %$data ) { next unless $self->can($key); if ( ref $value eq 'HASH' ) { while ( my ( $module, $version ) = each %$value ) { $self->can($key)->($self, $module => $version ); } } else { $self->can($key)->($self, $value); } } return $self; } sub write { my $self = shift; return $self unless $self->is_admin; $self->admin->write_meta; return $self; } sub version_from { require ExtUtils::MM_Unix; my ( $self, $file ) = @_; $self->version( ExtUtils::MM_Unix->parse_version($file) ); # for version integrity check $self->makemaker_args( VERSION_FROM => $file ); } sub abstract_from { require ExtUtils::MM_Unix; my ( $self, $file ) = @_; $self->abstract( bless( { DISTNAME => $self->name }, 'ExtUtils::MM_Unix' )->parse_abstract($file) ); } # Add both distribution and module name sub name_from { my ($self, $file) = @_; if ( Module::Install::_read($file) =~ m/ ^ \s* package \s* ([\w:]+) [\s|;]* /ixms ) { my ($name, $module_name) = ($1, $1); $name =~ s{::}{-}g; $self->name($name); unless ( $self->module_name ) { $self->module_name($module_name); } } else { die("Cannot determine name from $file\n"); } } sub _extract_perl_version { if ( $_[0] =~ m/ ^\s* (?:use|require) \s* v? ([\d_\.]+) \s* ; /ixms ) { my $perl_version = $1; $perl_version =~ s{_}{}g; return $perl_version; } else { return; } } sub perl_version_from { my $self = shift; my $perl_version=_extract_perl_version(Module::Install::_read($_[0])); if ($perl_version) { $self->perl_version($perl_version); } else { warn "Cannot determine perl version info from $_[0]\n"; return; } } sub author_from { my $self = shift; my $content = Module::Install::_read($_[0]); if ($content =~ m/ =head \d \s+ (?:authors?)\b \s* ([^\n]*) | =head \d \s+ (?:licen[cs]e|licensing|copyright|legal)\b \s* .*? copyright .*? \d\d\d[\d.]+ \s* (?:\bby\b)? \s* ([^\n]*) /ixms) { my $author = $1 || $2; # XXX: ugly but should work anyway... if (eval "require Pod::Escapes; 1") { # Pod::Escapes has a mapping table. # It's in core of perl >= 5.9.3, and should be installed # as one of the Pod::Simple's prereqs, which is a prereq # of Pod::Text 3.x (see also below). $author =~ s{ E<( (\d+) | ([A-Za-z]+) )> } { defined $2 ? chr($2) : defined $Pod::Escapes::Name2character_number{$1} ? chr($Pod::Escapes::Name2character_number{$1}) : do { warn "Unknown escape: E<$1>"; "E<$1>"; }; }gex; } elsif (eval "require Pod::Text; 1" && $Pod::Text::VERSION < 3) { # Pod::Text < 3.0 has yet another mapping table, # though the table name of 2.x and 1.x are different. # (1.x is in core of Perl < 5.6, 2.x is in core of # Perl < 5.9.3) my $mapping = ($Pod::Text::VERSION < 2) ? \%Pod::Text::HTML_Escapes : \%Pod::Text::ESCAPES; $author =~ s{ E<( (\d+) | ([A-Za-z]+) )> } { defined $2 ? chr($2) : defined $mapping->{$1} ? $mapping->{$1} : do { warn "Unknown escape: E<$1>"; "E<$1>"; }; }gex; } else { $author =~ s{E}{<}g; $author =~ s{E}{>}g; } $self->author($author); } else { warn "Cannot determine author info from $_[0]\n"; } } #Stolen from M::B my %license_urls = ( perl => 'http://dev.perl.org/licenses/', apache => 'http://apache.org/licenses/LICENSE-2.0', apache_1_1 => 'http://apache.org/licenses/LICENSE-1.1', artistic => 'http://opensource.org/licenses/artistic-license.php', artistic_2 => 'http://opensource.org/licenses/artistic-license-2.0.php', lgpl => 'http://opensource.org/licenses/lgpl-license.php', lgpl2 => 'http://opensource.org/licenses/lgpl-2.1.php', lgpl3 => 'http://opensource.org/licenses/lgpl-3.0.html', bsd => 'http://opensource.org/licenses/bsd-license.php', gpl => 'http://opensource.org/licenses/gpl-license.php', gpl2 => 'http://opensource.org/licenses/gpl-2.0.php', gpl3 => 'http://opensource.org/licenses/gpl-3.0.html', mit => 'http://opensource.org/licenses/mit-license.php', mozilla => 'http://opensource.org/licenses/mozilla1.1.php', open_source => undef, unrestricted => undef, restrictive => undef, unknown => undef, ); sub license { my $self = shift; return $self->{values}->{license} unless @_; my $license = shift or die( 'Did not provide a value to license()' ); $license = __extract_license($license) || lc $license; $self->{values}->{license} = $license; # Automatically fill in license URLs if ( $license_urls{$license} ) { $self->resources( license => $license_urls{$license} ); } return 1; } sub _extract_license { my $pod = shift; my $matched; return __extract_license( ($matched) = $pod =~ m/ (=head \d \s+ L(?i:ICEN[CS]E|ICENSING)\b.*?) (=head \d.*|=cut.*|)\z /xms ) || __extract_license( ($matched) = $pod =~ m/ (=head \d \s+ (?:C(?i:OPYRIGHTS?)|L(?i:EGAL))\b.*?) (=head \d.*|=cut.*|)\z /xms ); } sub __extract_license { my $license_text = shift or return; my @phrases = ( '(?:under )?the same (?:terms|license) as (?:perl|the perl (?:\d )?programming language)' => 'perl', 1, '(?:under )?the terms of (?:perl|the perl programming language) itself' => 'perl', 1, 'Artistic and GPL' => 'perl', 1, 'GNU general public license' => 'gpl', 1, 'GNU public license' => 'gpl', 1, 'GNU lesser general public license' => 'lgpl', 1, 'GNU lesser public license' => 'lgpl', 1, 'GNU library general public license' => 'lgpl', 1, 'GNU library public license' => 'lgpl', 1, 'GNU Free Documentation license' => 'unrestricted', 1, 'GNU Affero General Public License' => 'open_source', 1, '(?:Free)?BSD license' => 'bsd', 1, 'Artistic license 2\.0' => 'artistic_2', 1, 'Artistic license' => 'artistic', 1, 'Apache (?:Software )?license' => 'apache', 1, 'GPL' => 'gpl', 1, 'LGPL' => 'lgpl', 1, 'BSD' => 'bsd', 1, 'Artistic' => 'artistic', 1, 'MIT' => 'mit', 1, 'Mozilla Public License' => 'mozilla', 1, 'Q Public License' => 'open_source', 1, 'OpenSSL License' => 'unrestricted', 1, 'SSLeay License' => 'unrestricted', 1, 'zlib License' => 'open_source', 1, 'proprietary' => 'proprietary', 0, ); while ( my ($pattern, $license, $osi) = splice(@phrases, 0, 3) ) { $pattern =~ s#\s+#\\s+#gs; if ( $license_text =~ /\b$pattern\b/i ) { return $license; } } return ''; } sub license_from { my $self = shift; if (my $license=_extract_license(Module::Install::_read($_[0]))) { $self->license($license); } else { warn "Cannot determine license info from $_[0]\n"; return 'unknown'; } } sub _extract_bugtracker { my @links = $_[0] =~ m#L<( https?\Q://rt.cpan.org/\E[^>]+| https?\Q://github.com/\E[\w_]+/[\w_]+/issues| https?\Q://code.google.com/p/\E[\w_\-]+/issues/list )>#gx; my %links; @links{@links}=(); @links=keys %links; return @links; } sub bugtracker_from { my $self = shift; my $content = Module::Install::_read($_[0]); my @links = _extract_bugtracker($content); unless ( @links ) { warn "Cannot determine bugtracker info from $_[0]\n"; return 0; } if ( @links > 1 ) { warn "Found more than one bugtracker link in $_[0]\n"; return 0; } # Set the bugtracker bugtracker( $links[0] ); return 1; } sub requires_from { my $self = shift; my $content = Module::Install::_readperl($_[0]); my @requires = $content =~ m/^use\s+([^\W\d]\w*(?:::\w+)*)\s+(v?[\d\.]+)/mg; while ( @requires ) { my $module = shift @requires; my $version = shift @requires; $self->requires( $module => $version ); } } sub test_requires_from { my $self = shift; my $content = Module::Install::_readperl($_[0]); my @requires = $content =~ m/^use\s+([^\W\d]\w*(?:::\w+)*)\s+([\d\.]+)/mg; while ( @requires ) { my $module = shift @requires; my $version = shift @requires; $self->test_requires( $module => $version ); } } # Convert triple-part versions (eg, 5.6.1 or 5.8.9) to # numbers (eg, 5.006001 or 5.008009). # Also, convert double-part versions (eg, 5.8) sub _perl_version { my $v = $_[-1]; $v =~ s/^([1-9])\.([1-9]\d?\d?)$/sprintf("%d.%03d",$1,$2)/e; $v =~ s/^([1-9])\.([1-9]\d?\d?)\.(0|[1-9]\d?\d?)$/sprintf("%d.%03d%03d",$1,$2,$3 || 0)/e; $v =~ s/(\.\d\d\d)000$/$1/; $v =~ s/_.+$//; if ( ref($v) ) { # Numify $v = $v + 0; } return $v; } sub add_metadata { my $self = shift; my %hash = @_; for my $key (keys %hash) { warn "add_metadata: $key is not prefixed with 'x_'.\n" . "Use appopriate function to add non-private metadata.\n" unless $key =~ /^x_/; $self->{values}->{$key} = $hash{$key}; } } ###################################################################### # MYMETA Support sub WriteMyMeta { die "WriteMyMeta has been deprecated"; } sub write_mymeta_yaml { my $self = shift; # We need YAML::Tiny to write the MYMETA.yml file unless ( eval { require YAML::Tiny; 1; } ) { return 1; } # Generate the data my $meta = $self->_write_mymeta_data or return 1; # Save as the MYMETA.yml file print "Writing MYMETA.yml\n"; YAML::Tiny::DumpFile('MYMETA.yml', $meta); } sub write_mymeta_json { my $self = shift; # We need JSON to write the MYMETA.json file unless ( eval { require JSON; 1; } ) { return 1; } # Generate the data my $meta = $self->_write_mymeta_data or return 1; # Save as the MYMETA.yml file print "Writing MYMETA.json\n"; Module::Install::_write( 'MYMETA.json', JSON->new->pretty(1)->canonical->encode($meta), ); } sub _write_mymeta_data { my $self = shift; # If there's no existing META.yml there is nothing we can do return undef unless -f 'META.yml'; # We need Parse::CPAN::Meta to load the file unless ( eval { require Parse::CPAN::Meta; 1; } ) { return undef; } # Merge the perl version into the dependencies my $val = $self->Meta->{values}; my $perl = delete $val->{perl_version}; if ( $perl ) { $val->{requires} ||= []; my $requires = $val->{requires}; # Canonize to three-dot version after Perl 5.6 if ( $perl >= 5.006 ) { $perl =~ s{^(\d+)\.(\d\d\d)(\d*)}{join('.', $1, int($2||0), int($3||0))}e } unshift @$requires, [ perl => $perl ]; } # Load the advisory META.yml file my @yaml = Parse::CPAN::Meta::LoadFile('META.yml'); my $meta = $yaml[0]; # Overwrite the non-configure dependency hashes delete $meta->{requires}; delete $meta->{build_requires}; delete $meta->{recommends}; if ( exists $val->{requires} ) { $meta->{requires} = { map { @$_ } @{ $val->{requires} } }; } if ( exists $val->{build_requires} ) { $meta->{build_requires} = { map { @$_ } @{ $val->{build_requires} } }; } return $meta; } 1; Hijk-0.27/inc/Module/Install/Fetch.pm0000644000175000017500000000462713004630022016315 0ustar gugodgugod#line 1 package Module::Install::Fetch; use strict; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.17'; @ISA = 'Module::Install::Base'; $ISCORE = 1; } sub get_file { my ($self, %args) = @_; my ($scheme, $host, $path, $file) = $args{url} =~ m|^(\w+)://([^/]+)(.+)/(.+)| or return; if ( $scheme eq 'http' and ! eval { require LWP::Simple; 1 } ) { $args{url} = $args{ftp_url} or (warn("LWP support unavailable!\n"), return); ($scheme, $host, $path, $file) = $args{url} =~ m|^(\w+)://([^/]+)(.+)/(.+)| or return; } $|++; print "Fetching '$file' from $host... "; unless (eval { require Socket; Socket::inet_aton($host) }) { warn "'$host' resolve failed!\n"; return; } return unless $scheme eq 'ftp' or $scheme eq 'http'; require Cwd; my $dir = Cwd::getcwd(); chdir $args{local_dir} or return if exists $args{local_dir}; if (eval { require LWP::Simple; 1 }) { LWP::Simple::mirror($args{url}, $file); } elsif (eval { require Net::FTP; 1 }) { eval { # use Net::FTP to get past firewall my $ftp = Net::FTP->new($host, Passive => 1, Timeout => 600); $ftp->login("anonymous", 'anonymous@example.com'); $ftp->cwd($path); $ftp->binary; $ftp->get($file) or (warn("$!\n"), return); $ftp->quit; } } elsif (my $ftp = $self->can_run('ftp')) { eval { # no Net::FTP, fallback to ftp.exe require FileHandle; my $fh = FileHandle->new; local $SIG{CHLD} = 'IGNORE'; unless ($fh->open("|$ftp -n")) { warn "Couldn't open ftp: $!\n"; chdir $dir; return; } my @dialog = split(/\n/, <<"END_FTP"); open $host user anonymous anonymous\@example.com cd $path binary get $file $file quit END_FTP foreach (@dialog) { $fh->print("$_\n") } $fh->close; } } else { warn "No working 'ftp' program available!\n"; chdir $dir; return; } unless (-f $file) { warn "Fetching failed: $@\n"; chdir $dir; return; } return if exists $args{size} and -s $file != $args{size}; system($args{run}) if exists $args{run}; unlink($file) if $args{remove}; print(((!exists $args{check_for} or -e $args{check_for}) ? "done!" : "failed! ($!)"), "\n"); chdir $dir; return !$?; } 1; Hijk-0.27/inc/Module/CPANfile/0000755000175000017500000000000013004630023014671 5ustar gugodgugodHijk-0.27/inc/Module/CPANfile/Requirement.pm0000644000175000017500000000064613004630022017534 0ustar gugodgugod#line 1 package Module::CPANfile::Requirement; use strict; sub new { my ($class, %args) = @_; $args{version} ||= 0; bless +{ name => delete $args{name}, version => delete $args{version}, options => \%args, }, $class; } sub name { $_[0]->{name} } sub version { $_[0]->{version} } sub options { $_[0]->{options} } sub has_options { keys %{$_[0]->{options}} > 0; } 1; Hijk-0.27/inc/Module/CPANfile/Prereq.pm0000644000175000017500000000064713004630022016473 0ustar gugodgugod#line 1 package Module::CPANfile::Prereq; use strict; sub new { my($class, %options) = @_; bless \%options, $class; } sub feature { $_[0]->{feature} } sub phase { $_[0]->{phase} } sub type { $_[0]->{type} } sub module { $_[0]->{module} } sub requirement { $_[0]->{requirement} } sub match_feature { my($self, $identifier) = @_; no warnings 'uninitialized'; $self->feature eq $identifier; } 1; Hijk-0.27/inc/Module/CPANfile/Prereqs.pm0000644000175000017500000000501513004630022016650 0ustar gugodgugod#line 1 package Module::CPANfile::Prereqs; use strict; use Carp (); use CPAN::Meta::Feature; use Module::CPANfile::Prereq; sub from_cpan_meta { my($class, $prereqs) = @_; my $self = $class->new; for my $phase (keys %$prereqs) { for my $type (keys %{ $prereqs->{$phase} }) { while (my($module, $requirement) = each %{ $prereqs->{$phase}{$type} }) { $self->add_prereq( phase => $phase, type => $type, module => $module, requirement => Module::CPANfile::Requirement->new(name => $module, version => $requirement), ); } } } $self; } sub new { my $class = shift; bless { prereqs => [], features => {}, }, $class; } sub add_feature { my($self, $identifier, $description) = @_; $self->{features}{$identifier} = { description => $description }; } sub add_prereq { my($self, %args) = @_; $self->add( Module::CPANfile::Prereq->new(%args) ); } sub add { my($self, $prereq) = @_; push @{$self->{prereqs}}, $prereq; } sub as_cpan_meta { my $self = shift; $self->{cpanmeta} ||= $self->build_cpan_meta; } sub build_cpan_meta { my($self, $identifier) = @_; my $prereq_spec = {}; $self->prereq_each($identifier, sub { my $prereq = shift; $prereq_spec->{$prereq->phase}{$prereq->type}{$prereq->module} = $prereq->requirement->version; }); CPAN::Meta::Prereqs->new($prereq_spec); } sub prereq_each { my($self, $identifier, $code) = @_; for my $prereq (@{$self->{prereqs}}) { next unless $prereq->match_feature($identifier); $code->($prereq); } } sub merged_requirements { my $self = shift; my $reqs = CPAN::Meta::Requirements->new; for my $prereq (@{$self->{prereqs}}) { $reqs->add_string_requirement($prereq->module, $prereq->requirement->version); } $reqs; } sub find { my($self, $module) = @_; for my $prereq (@{$self->{prereqs}}) { return $prereq if $prereq->module eq $module; } return; } sub identifiers { my $self = shift; keys %{$self->{features}}; } sub feature { my($self, $identifier) = @_; my $data = $self->{features}{$identifier} or Carp::croak("Unknown feature '$identifier'"); my $prereqs = $self->build_cpan_meta($identifier); CPAN::Meta::Feature->new($identifier, { description => $data->{description}, prereqs => $prereqs->as_string_hash, }); } 1; Hijk-0.27/inc/Module/CPANfile/Environment.pm0000644000175000017500000000642513004630022017541 0ustar gugodgugod#line 1 package Module::CPANfile::Environment; use strict; use warnings; use Module::CPANfile::Prereqs; use Carp (); my @bindings = qw( on requires recommends suggests conflicts feature osname mirror configure_requires build_requires test_requires author_requires ); my $file_id = 1; sub new { my($class, $file) = @_; bless { file => $file, phase => 'runtime', # default phase feature => undef, features => {}, prereqs => Module::CPANfile::Prereqs->new, mirrors => [], }, $class; } sub bind { my $self = shift; my $pkg = caller; for my $binding (@bindings) { no strict 'refs'; *{"$pkg\::$binding"} = sub { $self->$binding(@_) }; } } sub parse { my($self, $code) = @_; my $err; { local $@; $file_id++; $self->_evaluate(<bind } # line 1 "$self->{file}" $code; EVAL $err = $@; } if ($err) { die "Parsing $self->{file} failed: $err" }; return 1; } sub _evaluate { my $_environment = $_[0]; eval $_[1]; } sub prereqs { $_[0]->{prereqs} } sub mirrors { $_[0]->{mirrors} } # DSL goes from here sub on { my($self, $phase, $code) = @_; local $self->{phase} = $phase; $code->(); } sub feature { my($self, $identifier, $description, $code) = @_; # shortcut: feature identifier => sub { ... } if (@_ == 3 && ref($description) eq 'CODE') { $code = $description; $description = $identifier; } unless (ref $description eq '' && ref $code eq 'CODE') { Carp::croak("Usage: feature 'identifier', 'Description' => sub { ... }"); } local $self->{feature} = $identifier; $self->prereqs->add_feature($identifier, $description); $code->(); } sub osname { die "TODO" } sub mirror { my($self, $url) = @_; push @{$self->{mirrors}}, $url; } sub requirement_for { my($self, $module, @args) = @_; my $requirement = 0; $requirement = shift @args if @args % 2; return Module::CPANfile::Requirement->new( name => $module, version => $requirement, @args, ); } sub requires { my $self = shift; $self->add_prereq(requires => @_); } sub recommends { my $self = shift; $self->add_prereq(recommends => @_); } sub suggests { my $self = shift; $self->add_prereq(suggests => @_); } sub conflicts { my $self = shift; $self->add_prereq(conflicts => @_); } sub add_prereq { my($self, $type, $module, @args) = @_; $self->prereqs->add_prereq( feature => $self->{feature}, phase => $self->{phase}, type => $type, module => $module, requirement => $self->requirement_for($module, @args), ); } # Module::Install compatible shortcuts sub configure_requires { my($self, @args) = @_; $self->on(configure => sub { $self->requires(@args) }); } sub build_requires { my($self, @args) = @_; $self->on(build => sub { $self->requires(@args) }); } sub test_requires { my($self, @args) = @_; $self->on(test => sub { $self->requires(@args) }); } sub author_requires { my($self, @args) = @_; $self->on(develop => sub { $self->requires(@args) }); } 1; Hijk-0.27/inc/Module/Install.pm0000644000175000017500000002714513004630020015262 0ustar gugodgugod#line 1 package Module::Install; # For any maintainers: # The load order for Module::Install is a bit magic. # It goes something like this... # # IF ( host has Module::Install installed, creating author mode ) { # 1. Makefile.PL calls "use inc::Module::Install" # 2. $INC{inc/Module/Install.pm} set to installed version of inc::Module::Install # 3. The installed version of inc::Module::Install loads # 4. inc::Module::Install calls "require Module::Install" # 5. The ./inc/ version of Module::Install loads # } ELSE { # 1. Makefile.PL calls "use inc::Module::Install" # 2. $INC{inc/Module/Install.pm} set to ./inc/ version of Module::Install # 3. The ./inc/ version of Module::Install loads # } use 5.006; use strict 'vars'; use Cwd (); use File::Find (); use File::Path (); use vars qw{$VERSION $MAIN}; BEGIN { # All Module::Install core packages now require synchronised versions. # This will be used to ensure we don't accidentally load old or # different versions of modules. # This is not enforced yet, but will be some time in the next few # releases once we can make sure it won't clash with custom # Module::Install extensions. $VERSION = '1.17'; # Storage for the pseudo-singleton $MAIN = undef; *inc::Module::Install::VERSION = *VERSION; @inc::Module::Install::ISA = __PACKAGE__; } sub import { my $class = shift; my $self = $class->new(@_); my $who = $self->_caller; #------------------------------------------------------------- # all of the following checks should be included in import(), # to allow "eval 'require Module::Install; 1' to test # installation of Module::Install. (RT #51267) #------------------------------------------------------------- # Whether or not inc::Module::Install is actually loaded, the # $INC{inc/Module/Install.pm} is what will still get set as long as # the caller loaded module this in the documented manner. # If not set, the caller may NOT have loaded the bundled version, and thus # they may not have a MI version that works with the Makefile.PL. This would # result in false errors or unexpected behaviour. And we don't want that. my $file = join( '/', 'inc', split /::/, __PACKAGE__ ) . '.pm'; unless ( $INC{$file} ) { die <<"END_DIE" } Please invoke ${\__PACKAGE__} with: use inc::${\__PACKAGE__}; not: use ${\__PACKAGE__}; END_DIE # This reportedly fixes a rare Win32 UTC file time issue, but # as this is a non-cross-platform XS module not in the core, # we shouldn't really depend on it. See RT #24194 for detail. # (Also, this module only supports Perl 5.6 and above). eval "use Win32::UTCFileTime" if $^O eq 'MSWin32' && $] >= 5.006; # If the script that is loading Module::Install is from the future, # then make will detect this and cause it to re-run over and over # again. This is bad. Rather than taking action to touch it (which # is unreliable on some platforms and requires write permissions) # for now we should catch this and refuse to run. if ( -f $0 ) { my $s = (stat($0))[9]; # If the modification time is only slightly in the future, # sleep briefly to remove the problem. my $a = $s - time; if ( $a > 0 and $a < 5 ) { sleep 5 } # Too far in the future, throw an error. my $t = time; if ( $s > $t ) { die <<"END_DIE" } Your installer $0 has a modification time in the future ($s > $t). This is known to create infinite loops in make. Please correct this, then run $0 again. END_DIE } # Build.PL was formerly supported, but no longer is due to excessive # difficulty in implementing every single feature twice. if ( $0 =~ /Build.PL$/i ) { die <<"END_DIE" } Module::Install no longer supports Build.PL. It was impossible to maintain duel backends, and has been deprecated. Please remove all Build.PL files and only use the Makefile.PL installer. END_DIE #------------------------------------------------------------- # To save some more typing in Module::Install installers, every... # use inc::Module::Install # ...also acts as an implicit use strict. $^H |= strict::bits(qw(refs subs vars)); #------------------------------------------------------------- unless ( -f $self->{file} ) { foreach my $key (keys %INC) { delete $INC{$key} if $key =~ /Module\/Install/; } local $^W; require "$self->{path}/$self->{dispatch}.pm"; File::Path::mkpath("$self->{prefix}/$self->{author}"); $self->{admin} = "$self->{name}::$self->{dispatch}"->new( _top => $self ); $self->{admin}->init; @_ = ($class, _self => $self); goto &{"$self->{name}::import"}; } local $^W; *{"${who}::AUTOLOAD"} = $self->autoload; $self->preload; # Unregister loader and worker packages so subdirs can use them again delete $INC{'inc/Module/Install.pm'}; delete $INC{'Module/Install.pm'}; # Save to the singleton $MAIN = $self; return 1; } sub autoload { my $self = shift; my $who = $self->_caller; my $cwd = Cwd::getcwd(); my $sym = "${who}::AUTOLOAD"; $sym->{$cwd} = sub { my $pwd = Cwd::getcwd(); if ( my $code = $sym->{$pwd} ) { # Delegate back to parent dirs goto &$code unless $cwd eq $pwd; } unless ($$sym =~ s/([^:]+)$//) { # XXX: it looks like we can't retrieve the missing function # via $$sym (usually $main::AUTOLOAD) in this case. # I'm still wondering if we should slurp Makefile.PL to # get some context or not ... my ($package, $file, $line) = caller; die <<"EOT"; Unknown function is found at $file line $line. Execution of $file aborted due to runtime errors. If you're a contributor to a project, you may need to install some Module::Install extensions from CPAN (or other repository). If you're a user of a module, please contact the author. EOT } my $method = $1; if ( uc($method) eq $method ) { # Do nothing return; } elsif ( $method =~ /^_/ and $self->can($method) ) { # Dispatch to the root M:I class return $self->$method(@_); } # Dispatch to the appropriate plugin unshift @_, ( $self, $1 ); goto &{$self->can('call')}; }; } sub preload { my $self = shift; unless ( $self->{extensions} ) { $self->load_extensions( "$self->{prefix}/$self->{path}", $self ); } my @exts = @{$self->{extensions}}; unless ( @exts ) { @exts = $self->{admin}->load_all_extensions; } my %seen; foreach my $obj ( @exts ) { while (my ($method, $glob) = each %{ref($obj) . '::'}) { next unless $obj->can($method); next if $method =~ /^_/; next if $method eq uc($method); $seen{$method}++; } } my $who = $self->_caller; foreach my $name ( sort keys %seen ) { local $^W; *{"${who}::$name"} = sub { ${"${who}::AUTOLOAD"} = "${who}::$name"; goto &{"${who}::AUTOLOAD"}; }; } } sub new { my ($class, %args) = @_; delete $INC{'FindBin.pm'}; { # to suppress the redefine warning local $SIG{__WARN__} = sub {}; require FindBin; } # ignore the prefix on extension modules built from top level. my $base_path = Cwd::abs_path($FindBin::Bin); unless ( Cwd::abs_path(Cwd::getcwd()) eq $base_path ) { delete $args{prefix}; } return $args{_self} if $args{_self}; $base_path = VMS::Filespec::unixify($base_path) if $^O eq 'VMS'; $args{dispatch} ||= 'Admin'; $args{prefix} ||= 'inc'; $args{author} ||= ($^O eq 'VMS' ? '_author' : '.author'); $args{bundle} ||= 'inc/BUNDLES'; $args{base} ||= $base_path; $class =~ s/^\Q$args{prefix}\E:://; $args{name} ||= $class; $args{version} ||= $class->VERSION; unless ( $args{path} ) { $args{path} = $args{name}; $args{path} =~ s!::!/!g; } $args{file} ||= "$args{base}/$args{prefix}/$args{path}.pm"; $args{wrote} = 0; bless( \%args, $class ); } sub call { my ($self, $method) = @_; my $obj = $self->load($method) or return; splice(@_, 0, 2, $obj); goto &{$obj->can($method)}; } sub load { my ($self, $method) = @_; $self->load_extensions( "$self->{prefix}/$self->{path}", $self ) unless $self->{extensions}; foreach my $obj (@{$self->{extensions}}) { return $obj if $obj->can($method); } my $admin = $self->{admin} or die <<"END_DIE"; The '$method' method does not exist in the '$self->{prefix}' path! Please remove the '$self->{prefix}' directory and run $0 again to load it. END_DIE my $obj = $admin->load($method, 1); push @{$self->{extensions}}, $obj; $obj; } sub load_extensions { my ($self, $path, $top) = @_; my $should_reload = 0; unless ( grep { ! ref $_ and lc $_ eq lc $self->{prefix} } @INC ) { unshift @INC, $self->{prefix}; $should_reload = 1; } foreach my $rv ( $self->find_extensions($path) ) { my ($file, $pkg) = @{$rv}; next if $self->{pathnames}{$pkg}; local $@; my $new = eval { local $^W; require $file; $pkg->can('new') }; unless ( $new ) { warn $@ if $@; next; } $self->{pathnames}{$pkg} = $should_reload ? delete $INC{$file} : $INC{$file}; push @{$self->{extensions}}, &{$new}($pkg, _top => $top ); } $self->{extensions} ||= []; } sub find_extensions { my ($self, $path) = @_; my @found; File::Find::find( {no_chdir => 1, wanted => sub { my $file = $File::Find::name; return unless $file =~ m!^\Q$path\E/(.+)\.pm\Z!is; my $subpath = $1; return if lc($subpath) eq lc($self->{dispatch}); $file = "$self->{path}/$subpath.pm"; my $pkg = "$self->{name}::$subpath"; $pkg =~ s!/!::!g; # If we have a mixed-case package name, assume case has been preserved # correctly. Otherwise, root through the file to locate the case-preserved # version of the package name. if ( $subpath eq lc($subpath) || $subpath eq uc($subpath) ) { my $content = Module::Install::_read($File::Find::name); my $in_pod = 0; foreach ( split /\n/, $content ) { $in_pod = 1 if /^=\w/; $in_pod = 0 if /^=cut/; next if ($in_pod || /^=cut/); # skip pod text next if /^\s*#/; # and comments if ( m/^\s*package\s+($pkg)\s*;/i ) { $pkg = $1; last; } } } push @found, [ $file, $pkg ]; }}, $path ) if -d $path; @found; } ##################################################################### # Common Utility Functions sub _caller { my $depth = 0; my $call = caller($depth); while ( $call eq __PACKAGE__ ) { $depth++; $call = caller($depth); } return $call; } sub _read { local *FH; open( FH, '<', $_[0] ) or die "open($_[0]): $!"; binmode FH; my $string = do { local $/; }; close FH or die "close($_[0]): $!"; return $string; } sub _readperl { my $string = Module::Install::_read($_[0]); $string =~ s/(?:\015{1,2}\012|\015|\012)/\n/sg; $string =~ s/(\n)\n*__(?:DATA|END)__\b.*\z/$1/s; $string =~ s/\n\n=\w+.+?\n\n=cut\b.+?\n+/\n\n/sg; return $string; } sub _readpod { my $string = Module::Install::_read($_[0]); $string =~ s/(?:\015{1,2}\012|\015|\012)/\n/sg; return $string if $_[0] =~ /\.pod\z/; $string =~ s/(^|\n=cut\b.+?\n+)[^=\s].+?\n(\n=\w+|\z)/$1$2/sg; $string =~ s/\n*=pod\b[^\n]*\n+/\n\n/sg; $string =~ s/\n*=cut\b[^\n]*\n+/\n\n/sg; $string =~ s/^\n+//s; return $string; } sub _write { local *FH; open( FH, '>', $_[0] ) or die "open($_[0]): $!"; binmode FH; foreach ( 1 .. $#_ ) { print FH $_[$_] or die "print($_[0]): $!"; } close FH or die "close($_[0]): $!"; } # _version is for processing module versions (eg, 1.03_05) not # Perl versions (eg, 5.8.1). sub _version { my $s = shift || 0; my $d =()= $s =~ /(\.)/g; if ( $d >= 2 ) { # Normalise multipart versions $s =~ s/(\.)(\d{1,3})/sprintf("$1%03d",$2)/eg; } $s =~ s/^(\d+)\.?//; my $l = $1 || 0; my @v = map { $_ . '0' x (3 - length $_) } $s =~ /(\d{1,3})\D?/g; $l = $l . '.' . join '', @v if @v; return $l + 0; } sub _cmp { _version($_[1]) <=> _version($_[2]); } # Cloned from Params::Util::_CLASS sub _CLASS { ( defined $_[0] and ! ref $_[0] and $_[0] =~ m/^[^\W\d]\w*(?:::\w+)*\z/s ) ? $_[0] : undef; } 1; # Copyright 2008 - 2012 Adam Kennedy. Hijk-0.27/cpanfile0000644000175000017500000000027313004627225013032 0ustar gugodgugodrequires "Time::HiRes"; test_requires "Module::Install::CPANfile"; test_requires "Test::More"; test_requires "Test::Exception"; test_requires "Plack"; test_requires "Net::Ping", '2.41'; Hijk-0.27/MANIFEST0000644000175000017500000000215713004630023012450 0ustar gugodgugodChanges cpanfile examples/bench-chunked-response.pl examples/bench-elasticsearch.pl examples/bench-nginx.pl examples/dumbbench-thisurl.pl examples/hijkurl inc/Module/CPANfile.pm inc/Module/CPANfile/Environment.pm inc/Module/CPANfile/Prereq.pm inc/Module/CPANfile/Prereqs.pm inc/Module/CPANfile/Requirement.pm inc/Module/Install.pm inc/Module/Install/Base.pm inc/Module/Install/Can.pm inc/Module/Install/CPANfile.pm inc/Module/Install/Fetch.pm inc/Module/Install/Makefile.pm inc/Module/Install/Metadata.pm inc/Module/Install/Win32.pm inc/Module/Install/WriteAll.pm lib/Hijk.pm LICENSE Makefile.PL MANIFEST This list of files META.json META.yml README.md t/bin/head-request.psgi t/bin/it-takes-time.psgi t/bin/split-in-chunks.psgi t/build_http_message.t t/chunked-trailer-head-as-array.t t/chunked-trailer.t t/chunked.t t/live-connect-timeout.t t/live-couchdb.t t/live-elasticsearch.t t/live-google.t t/live-head-request.t t/live-invalid-domain.t t/live-plack.t t/live-unixis.t t/parse-http-connection-close-message.t t/parse-http-message-head-as-array.t t/parse-http-message.t t/parse-http-no-content-len-message.t t/select-timeout.t