pax_global_header00006660000000000000000000000064134645310250014515gustar00rootroot0000000000000052 comment=77c6988c5db383944030194c8c07d6727fe5f11f libyahc-perl-0.035/000077500000000000000000000000001346453102500140775ustar00rootroot00000000000000libyahc-perl-0.035/Changes000066400000000000000000000116111346453102500153720ustar00rootroot00000000000000Revision history for Perl module YAHC 0.035 2017-11-13 IKRUGLOV - *change in behaivor* - lowercase header keys - provide ability to pass external eventlog in ->new() - include new tests 0.034 2017-06-20 IKRUGLOV - support of reposponses without Content-Length by joaquim.rovira@booking.com - check that Content-Length is numeric value by joaquim.rovira@booking.com - support of HEAD, 1xx, 204 and 304 responses by jeroen.vanwolffelaar@booking.com 0.033 2017-04-22 IKRUGLOV - yahc_conn_socket_cache_id(): return undef if conn is undef - when considering droping a socket take into account response protocol - socket_cache as callback - fix bug in yahc_terminal_error() - don't set backoff time when backoff callback returned 0 - support of HEAD method - can pass headers in ->new() - do not overwrite Host header when set by user - implement yahc_conn_user_data() - improved tests 0.032 2017-02-27 IKRUGLOV - socket cache support multiple file handles per destination - uniq connections ids 0.031 2017-01-17 IKRUGLOV - clarification of docs - yahc_retry_conn() can accept backoff_delay arg - fix double setting args in ->new() and ->request() - optimize internal timer creation 0.030 2016-10-13 IKRUGLOV - report sent body (cut to 1024 bytes) in timeline - more fare scheduling of retries - enrich error messages with numeric representation of $! or IO::Socket::SSL::SSL_ERROR - stop leaking connections once completed - drop() can force socket to be closed - new tests 0.029 2016-09-06 IKRUGLOV - fix problem with empty head param when building http request body - improved docs - lots of improvments in tests 0.028 2016-07-23 IKRUGLOV - new yahc_conn_register_error() - new yahc_conn_attempt() - *change in behaivor* - timeout errors are marked with new YAHC::Error::TIMEOUT() bit. So, direct comparation like $err == YAHC::Error::CONNECT_TIMEOUT() won't work anymore and should be done as bitmask check $err & YAHC::Error::CONNECT_TIMEOUT. - bugfix in backoff_delay logic - bugfix in user_callback calls, update EV internal time to avoid deviation. - added t/account_for_signal.t into MANIFEST - beter docs - more tests 0.027 2016-07-16 IKRUGLOV - new backoff_delay feature - new lifetime_timeout feature - *change in behaivor* - in case of internal error, exception in callback or expiration of lifetime_timeout callback is called with TERMINAL_ERROR bit set in $error. In this case all further attempt to retry or reinit connection are ignored and the connection goes to COMPLETED state unconditionally. Previous behaivor was that a connection silently terminates. - *change in behaivor* - give all timeouts the highest priorities in event loop. This provides stonger timeout guarantee but can cause timeouts in border cases which didn't happen before. - *change in behaivor* - when connection failed all retry attempts report error condition with new error YAHC::Error::RETRY_LIMIT instead of YAHC::Error::CONNECT_ERROR - rename YAHC::State::WAIT_SYNACK to YAHC::State::CONNECTING - improved tests - improved docs 0.026 2016-07-14 IKRUGLOV - improved docs - account_for_signals - experimental support of socket_cache - expose break() method - warn if UTF8 flagged payload detected - tests improvments 0.025 2015-12-04 IKRUGLOV - yahc_retry_conn() - move t/requests.t to live tests 0.024 2015-11-13 IKRUGLOV - fix failing tests 0.023 2015-11-12 IKRUGLOV - bug fix 0.022 2015-11-11 IKRUGLOV - new tests - minor performance optimizations 0.021 2015-11-06 IKRUGLOV - passing host to YAHC->new didn't work - ignore extention when parsing chunked encoding - minor improvments 0.019 2015-09-28 IKRUGLOV - chunked encoding support - $ENV{YAHC_DEBUG} and $ENV{YAHC_TIMELINE} 0.018 2015-07-03 IKRUGLOV - SSL support - update EV's time before setting a timer - compatibility fixes - other minor changes 0.017 2015-05-25 IKRUGLOV - registering a error includes a record in timeline - check stop condition after going into CONNECTED state - improve test - add test into build - remove active_connections() 0.016 2015-05-19 IKRUGLOV - add active_connections() - minor fixes - tests and benchmarks 0.015 2015-05-12 IKRUGLOV - yahc_conn_attempts_left - set the lowest priority to timers - compatibility fixes 0.014 2015-05-11 IKRUGLOV - move benchmark files into 'benchmark' directory - handle case where body is 0 (int) - change response interface to use same fields as Hijk uses (headers => head, status_code => status) - change format of error messages - new tests 0.013 2015-05-?? IKRUGLOV - Added github repo to the dist metadata and the doc - Added this Changes file libyahc-perl-0.035/LICENSE000066400000000000000000000020661346453102500151100ustar00rootroot00000000000000The 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. libyahc-perl-0.035/MANIFEST000066400000000000000000000014751346453102500152370ustar00rootroot00000000000000Changes inc/Module/Install.pm inc/Module/Install/Base.pm inc/Module/Install/Can.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/YAHC.pm LICENSE Makefile.PL MANIFEST This list of files META.yml README.md scripts/utf8_test.pl t/000_compile.t t/005_circular_references_check.t t/010_build_http_message.t t/015_parse_http_headers.t t/016_chunked.t t/017_content_length.t t/023_state_connected.t t/024_state_write.t t/025_state_read.t t/100_account_for_signal.t t/110_attempt.t t/120_selected_target.t t/130_yahc_functions.t t/140_yahc_loop.t t/200_live_google.t t/210_live_timeout_connected.t t/220_live_unixis.t t/230_live_requests.t t/240_live_socket_cache.t t/300_robust.t t/cert/server.crt t/cert/server.key t/Utils.pm libyahc-perl-0.035/META.yml000066400000000000000000000015731346453102500153560ustar00rootroot00000000000000--- abstract: 'Yet another HTTP client' author: - 'Ivan Kruglov ' build_requires: Data::Dumper: 0 ExtUtils::MakeMaker: 6.36 FindBin: 0 HTTP::Tiny: 0 IO::Socket::INET: 0 JSON: 0 List::Util: 0 Net::Ping: '2.41' Plack: 0 Plack::Handler::Starman: 0 Test::Exception: 0 Test::Memory::Cycle: 0 Test::More: '0.88' Time::HiRes: 0 configure_requires: ExtUtils::MakeMaker: 6.36 distribution_type: module dynamic_config: 1 generated_by: 'Module::Install version 1.16' license: perl meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: 1.4 name: YAHC no_index: directory: - inc - t requires: EV: 0 Fcntl: 0 IO::Socket::SSL: 0 POSIX: 0 Scalar::Util: 0 Socket: 0 Time::HiRes: 0 resources: license: http://dev.perl.org/licenses/ repository: https://github.com/ikruglov/YAHC version: '0.035' libyahc-perl-0.035/Makefile.PL000066400000000000000000000026431346453102500160560ustar00rootroot00000000000000use inc::Module::Install; # Define metadata name 'YAHC'; all_from 'lib/YAHC.pm'; license 'perl'; # Specific dependencies requires 'EV' => '0'; requires 'POSIX' => '0'; requires 'Fcntl' => '0'; requires 'Socket' => '0'; requires 'IO::Socket::SSL' => '0'; requires 'Scalar::Util' => '0'; requires 'Time::HiRes' => '0'; test_requires 'Test::More' => '0.88'; test_requires 'Test::Exception' => '0'; test_requires 'Test::Memory::Cycle' => '0'; test_requires 'Plack::Handler::Starman' => '0'; test_requires 'IO::Socket::INET' => '0'; test_requires 'Data::Dumper' => '0'; test_requires 'Time::HiRes' => '0'; test_requires 'HTTP::Tiny' => '0'; test_requires 'Net::Ping' => '2.41'; test_requires 'List::Util' => '0'; test_requires 'FindBin' => '0'; test_requires 'Plack' => '0'; test_requires 'JSON' => '0'; # metadata for the github repo repository 'https://github.com/ikruglov/YAHC'; WriteAll; libyahc-perl-0.035/README.md000066400000000000000000000007541346453102500153640ustar00rootroot00000000000000[![Tavis-CI Build Status](https://travis-ci.org/ikruglov/YAHC.png?branch=master)](https://travis-ci.org/ikruglov/YAHC) [YAHC on MetaCPAN](https://metacpan.org/pod/YAHC) YAHC - Yet another HTTP client Features: - minimalistic HTTP client - managing pool of HTTP requests - each connection is async - user controls connections behavior - support of various retry techincs - support backoff - support SSL The code is under development. Changes to the interfaces are possible without notice. libyahc-perl-0.035/inc/000077500000000000000000000000001346453102500146505ustar00rootroot00000000000000libyahc-perl-0.035/inc/Module/000077500000000000000000000000001346453102500160755ustar00rootroot00000000000000libyahc-perl-0.035/inc/Module/Install.pm000066400000000000000000000302171346453102500200440ustar00rootroot00000000000000#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.16'; # 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}; $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( 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($subpath . '.pm'); 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; } # Done in evals to avoid confusing Perl::MinimumVersion eval( $] >= 5.006 ? <<'END_NEW' : <<'END_OLD' ); die $@ if $@; 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; } END_NEW 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; } END_OLD 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; } # Done in evals to avoid confusing Perl::MinimumVersion eval( $] >= 5.006 ? <<'END_NEW' : <<'END_OLD' ); die $@ if $@; 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]): $!"; } END_NEW 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]): $!"; } END_OLD # _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. libyahc-perl-0.035/inc/Module/Install/000077500000000000000000000000001346453102500175035ustar00rootroot00000000000000libyahc-perl-0.035/inc/Module/Install/Base.pm000066400000000000000000000021471346453102500207170ustar00rootroot00000000000000#line 1 package Module::Install::Base; use strict 'vars'; use vars qw{$VERSION}; BEGIN { $VERSION = '1.16'; } # 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 libyahc-perl-0.035/inc/Module/Install/Can.pm000066400000000000000000000061571346453102500205530ustar00rootroot00000000000000#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.16'; @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; 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 236 libyahc-perl-0.035/inc/Module/Install/Fetch.pm000066400000000000000000000046271346453102500211030ustar00rootroot00000000000000#line 1 package Module::Install::Fetch; use strict; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.16'; @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; libyahc-perl-0.035/inc/Module/Install/Makefile.pm000066400000000000000000000274371346453102500215730ustar00rootroot00000000000000#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.16'; @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 libyahc-perl-0.035/inc/Module/Install/Metadata.pm000066400000000000000000000433021346453102500215630ustar00rootroot00000000000000#line 1 package Module::Install::Metadata; use strict 'vars'; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.16'; @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; libyahc-perl-0.035/inc/Module/Install/Win32.pm000066400000000000000000000034031346453102500207430ustar00rootroot00000000000000#line 1 package Module::Install::Win32; use strict; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.16'; @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; libyahc-perl-0.035/inc/Module/Install/WriteAll.pm000066400000000000000000000023761346453102500215740ustar00rootroot00000000000000#line 1 package Module::Install::WriteAll; use strict; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.16'; @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; libyahc-perl-0.035/lib/000077500000000000000000000000001346453102500146455ustar00rootroot00000000000000libyahc-perl-0.035/lib/YAHC.pm000066400000000000000000002221131346453102500157300ustar00rootroot00000000000000package YAHC; use strict; use warnings; our $VERSION = '0.035'; use EV; use Time::HiRes; use Exporter 'import'; use Scalar::Util qw/weaken/; use Fcntl qw/F_GETFL F_SETFL O_NONBLOCK/; use POSIX qw/EINPROGRESS EINTR EAGAIN EWOULDBLOCK strftime/; use Socket qw/PF_INET SOCK_STREAM $CRLF SOL_SOCKET SO_ERROR inet_aton inet_ntoa pack_sockaddr_in/; use constant SSL => $ENV{YAHC_NO_SSL} ? 0 : eval 'use IO::Socket::SSL 1.94 (); 1'; use constant SSL_WANT_READ => SSL ? IO::Socket::SSL::SSL_WANT_READ() : 0; use constant SSL_WANT_WRITE => SSL ? IO::Socket::SSL::SSL_WANT_WRITE() : 0; sub YAHC::Error::NO_ERROR () { 0 } sub YAHC::Error::REQUEST_TIMEOUT () { 1 << 0 } sub YAHC::Error::CONNECT_TIMEOUT () { 1 << 1 } sub YAHC::Error::DRAIN_TIMEOUT () { 1 << 2 } sub YAHC::Error::LIFETIME_TIMEOUT () { 1 << 3 } sub YAHC::Error::TIMEOUT () { 1 << 8 } sub YAHC::Error::RETRY_LIMIT () { 1 << 9 } sub YAHC::Error::CONNECT_ERROR () { 1 << 10 } sub YAHC::Error::READ_ERROR () { 1 << 11 } sub YAHC::Error::WRITE_ERROR () { 1 << 12 } sub YAHC::Error::REQUEST_ERROR () { 1 << 13 } sub YAHC::Error::RESPONSE_ERROR () { 1 << 14 } sub YAHC::Error::CALLBACK_ERROR () { 1 << 15 } sub YAHC::Error::SSL_ERROR () { 1 << 16 } sub YAHC::Error::TERMINAL_ERROR () { 1 << 30 } sub YAHC::Error::INTERNAL_ERROR () { 1 << 31 } sub YAHC::State::INITIALIZED () { 0 } sub YAHC::State::RESOLVE_DNS () { 5 } sub YAHC::State::CONNECTING () { 10 } sub YAHC::State::CONNECTED () { 15 } sub YAHC::State::SSL_HANDSHAKE () { 20 } sub YAHC::State::WRITING () { 25 } sub YAHC::State::READING () { 30 } sub YAHC::State::USER_ACTION () { 35 } sub YAHC::State::COMPLETED () { 100 } # terminal state sub YAHC::SocketCache::GET () { 1 } sub YAHC::SocketCache::STORE () { 2 } use constant { # TCP_READ_CHUNK should *NOT* be lower than 16KB because of SSL things. # https://metacpan.org/pod/distribution/IO-Socket-SSL/lib/IO/Socket/SSL.pod # Another way might be if you try to sysread at least 16kByte all the time. # 16kByte is the maximum size of an SSL frame and because sysread returns # data from only a single SSL frame you can guarantee that there are no # pending data. TCP_READ_CHUNK => 131072, CALLBACKS => [ qw/init_callback connecting_callback connected_callback writing_callback reading_callback callback/ ], }; our @EXPORT_OK = qw/ yahc_retry_conn yahc_reinit_conn yahc_terminal_error yahc_conn_last_error yahc_conn_id yahc_conn_url yahc_conn_target yahc_conn_state yahc_conn_errors yahc_conn_timeline yahc_conn_request yahc_conn_response yahc_conn_attempt yahc_conn_attempts_left yahc_conn_socket_cache_id yahc_conn_register_error yahc_conn_user_data /; our %EXPORT_TAGS = (all => \@EXPORT_OK); my $LAST_CONNECTION_ID; ################################################################################ # User facing functons ################################################################################ sub new { my ($class, $args) = @_; $LAST_CONNECTION_ID = $$ * 1000 unless defined $LAST_CONNECTION_ID; die 'YAHC: ->new() expect args to be a hashref' if defined $args and ref($args) ne 'HASH'; die 'YAHC: please do `my ($yahc, $yahc_storage) = YAHC::new()` and keep both these objects in the same scope' unless wantarray; # wrapping target selection here allows all client share same list # and more importantly to share index within the list $args->{_target} = _wrap_host(delete $args->{host}) if $args->{host}; $args->{_backoff} = _wrap_backoff(delete $args->{backoff_delay}) if $args->{backoff_delay}; $args->{_socket_cache} = _wrap_socket_cache(delete $args->{socket_cache}) if $args->{socket_cache}; my %storage; my $self = bless { loop => delete($args->{loop}) || new EV::Loop, pid => $$, # store pid to detect forks storage => \%storage, debug => delete $args->{debug} || $ENV{YAHC_DEBUG} || 0, keep_timeline => delete $args->{keep_timeline} || $ENV{YAHC_TIMELINE} || 0, pool_args => $args, }, $class; # this's a radical way of avoiding circular references. # let's see how it plays out in practise. weaken($self->{storage}); weaken($self->{$_} = $storage{$_} = {}) for qw/watchers callbacks connections/; if (delete $args->{account_for_signals}) { _log_message('YAHC: enable account_for_signals logic') if $self->{debug}; my $sigcheck = $self->{watchers}{_sigcheck} = $self->{loop}->check(sub {}); $sigcheck->keepalive(0); } return $self, \%storage; } sub request { my ($self, @args) = @_; die 'YAHC: new_request() expects arguments' unless @args; die 'YAHC: storage object is destroyed' unless $self->{storage}; my ($conn_id, $request) = (@args == 1 ? ('connection_' . $LAST_CONNECTION_ID++, $args[0]) : @args); die "YAHC: Connection with name '$conn_id' already exists\n" if exists $self->{connections}{$conn_id}; my $pool_args = $self->{pool_args}; do { $request->{$_} ||= $pool_args->{$_} if $pool_args->{$_} } foreach (qw/host port scheme head request_timeout connect_timeout drain_timeout lifetime_timeout/); if ($request->{host}) { $request->{_target} = _wrap_host($request->{host}); } elsif ($pool_args->{_target}) { $request->{_target} = $pool_args->{_target}; } else { die "YAHC: host must be defined in request() or in new()\n"; } if ($request->{backoff_delay}) { $request->{_backoff} = _wrap_backoff($request->{backoff_delay}); } elsif ($pool_args->{_backoff}) { $request->{_backoff} = $pool_args->{_backoff}; } if ($request->{socket_cache}) { $request->{_socket_cache} = _wrap_socket_cache($request->{socket_cache}); } elsif ($pool_args->{_socket_cache}) { $request->{_socket_cache} = $pool_args->{_socket_cache}; } my $scheme = $request->{scheme} ||= 'http'; my $debug = delete $request->{debug} || $self->{debug}; my $keep_timeline = delete $request->{keep_timeline} || $self->{keep_timeline}; my $user_data = delete $request->{user_data}; my $conn = { id => $conn_id, request => $request, response => { status => 0 }, attempt => 0, retries => $request->{retries} || 0, state => YAHC::State::INITIALIZED(), selected_target => [], ($debug ? (debug => $debug) : ()), ($keep_timeline ? (keep_timeline => $keep_timeline) : ()), ($debug || $keep_timeline ? (debug_or_timeline => 1) : ()), (defined $user_data ? (user_data => $user_data) : ()), pid => $$, }; my %callbacks; foreach (@{ CALLBACKS() }) { next unless exists $request->{$_}; my $cb = $callbacks{$_} = delete $request->{$_}; $conn->{"has_$_"} = !!$cb; } $self->{watchers}{$conn_id} = {}; $self->{callbacks}{$conn_id} = \%callbacks; $self->{connections}{$conn_id} = $conn; _set_lifetime_timer($self, $conn_id) if $request->{lifetime_timeout}; return $conn if $request->{_test}; # for testing purposes _set_init_state($self, $conn_id); # if user fire new request in a callback we need to update stop_condition my $stop_condition = $self->{stop_condition}; if ($stop_condition && $stop_condition->{all}) { $stop_condition->{connections}{$conn_id} = 1; } return $conn; } sub drop { my ($self, $c, $force_socket_close) = @_; my $conn_id = ref($c) eq 'HASH' ? $c->{id} : $c; my $conn = $self->{connections}{$conn_id} or return; _register_in_timeline($conn, "dropping connection from pool") if exists $conn->{debug_or_timeline}; _set_completed_state($self, $conn_id, $force_socket_close) unless $conn->{state} == YAHC::State::COMPLETED(); return $conn; } sub run { shift->_run(0, @_) } sub run_once { shift->_run(EV::RUN_ONCE) } sub run_tick { shift->_run(EV::RUN_NOWAIT) } sub is_running { !!shift->{loop}->depth } sub loop { shift->{loop} } sub break { my ($self, $reason) = @_; return unless $self->is_running; _log_message('YAHC: pid %d breaking event loop because %s', $$, ($reason || 'no reason')) if $self->{debug}; $self->{loop}->break(EV::BREAK_ONE) } ################################################################################ # Routines to manipulate connections (also user facing) ################################################################################ sub yahc_terminal_error { return (($_[0] & YAHC::Error::TERMINAL_ERROR()) == YAHC::Error::TERMINAL_ERROR()) ? 1 : 0; } sub yahc_reinit_conn { my ($conn, $args) = @_; die "YAHC: cannot reinit completed connection\n" if $conn->{state} >= YAHC::State::COMPLETED(); $conn->{attempt} = 0; $conn->{state} = YAHC::State::INITIALIZED(); return unless defined $args && ref($args) eq 'HASH'; my $request = $conn->{request}; $request->{_target} = _wrap_host(delete $args->{host}) if $args->{host}; $request->{_backoff} = _wrap_backoff(delete $args->{backoff_delay}) if $args->{backoff_delay}; do { $request->{$_} = $args->{$_} if $args->{$_} } foreach (keys %$args); } sub yahc_retry_conn { my ($conn, $args) = @_; die "YAHC: cannot retry completed connection\n" if $conn->{state} >= YAHC::State::COMPLETED(); return unless yahc_conn_attempts_left($conn) > 0; $conn->{state} = YAHC::State::INITIALIZED(); return unless defined $args && ref($args) eq 'HASH'; $conn->{request}{_backoff} = _wrap_backoff($args->{backoff_delay}) if $args->{backoff_delay}; } sub yahc_conn_last_error { my $conn = shift; return unless $conn->{errors} && @{ $conn->{errors} }; return wantarray ? @{ $conn->{errors}[-1] } : $conn->{errors}[-1]; } sub yahc_conn_id { $_[0]->{id} } sub yahc_conn_state { $_[0]->{state} } sub yahc_conn_errors { $_[0]->{errors} } sub yahc_conn_timeline { $_[0]->{timeline} } sub yahc_conn_request { $_[0]->{request} } sub yahc_conn_response { $_[0]->{response} } sub yahc_conn_attempt { $_[0]->{attempt} } sub yahc_conn_attempts_left { $_[0]->{attempt} > $_[0]->{retries} ? 0 : $_[0]->{retries} - $_[0]->{attempt} + 1 } sub yahc_conn_target { my $target = $_[0]->{selected_target}; return unless $target && scalar @{ $target }; my ($host, $ip, $port) = @{ $target }; return ($host || $ip) . ($port ne '80' && $port ne '443' ? ":$port" : ''); } sub yahc_conn_url { my $target = $_[0]->{selected_target}; my $request = $_[0]->{request}; return unless $target && @{ $target }; my ($host, $ip, $port, $scheme) = @{ $target }; return "$scheme://" . ($host || $ip) . ($port ne '80' && $port ne '443' ? ":$port" : '') . ($request->{path} || "/") . (defined $request->{query_string} ? ("?" . $request->{query_string}) : ""); } sub yahc_conn_user_data { my $conn = shift; $conn->{user_data} = $_[0] if @_; return $conn->{user_data}; } ################################################################################ # Internals ################################################################################ sub _run { my ($self, $how, $until_state, @cs) = @_; die "YAHC: storage object is destroyed\n" unless $self->{storage}; die "YAHC: reentering run\n" if $self->{loop}->depth; if ($self->{pid} != $$) { _log_message('YAHC: reinitializing event loop after forking') if $self->{debug}; $self->{pid} = $$; $self->{loop}->loop_fork; my $active_connections = grep { $$ != $_->{pid} } values %{ $self->{connections} }; warn "YAHC has $active_connections active connections after a fork, consider dropping them!" if $active_connections; } if (defined $until_state) { my $until_state_str = _strstate($until_state); die "YAHC: unknown until_state $until_state\n" if $until_state_str =~ m/unknown/; my $is_all = (@cs == 0); my @connections = $is_all ? values %{ $self->{connections} } : map { $self->{connections}{$_} || () } map { ref($_) eq 'HASH' ? $_->{id} : $_ } @cs; $self->{stop_condition} = { all => $is_all, expected_state => $until_state, connections => { map { $_->{id} => 1 } grep { $_->{state} < $until_state } @connections }, }; } else { delete $self->{stop_condition}; } my $loop = $self->{loop}; $loop->now_update; if ($self->{debug}) { my $iterations = $loop->iteration; _log_message('YAHC: pid %d entering event loop%s', $$, ($until_state ? " with until state " . _strstate($until_state) : '')); $loop->run($how || 0); _log_message('YAHC: pid %d exited from event loop after %d iterations', $$, $loop->iteration - $iterations); } else { $loop->run($how || 0); } } sub _check_stop_condition { my ($self, $conn) = @_; my $stop_condition = $self->{stop_condition}; return if !$stop_condition || $conn->{state} < $stop_condition->{expected_state}; delete $stop_condition->{connections}{$conn->{id}}; my $awaiting_connections = scalar keys %{ $stop_condition->{connections} }; my $expected_state = $stop_condition->{expected_state}; if ($awaiting_connections == 0) { $self->break(sprintf("until state '%s' is reached", _strstate($expected_state))); return 1; } _log_message("YAHC: still have %d connections awaiting state '%s'", $awaiting_connections, _strstate($expected_state)) if $self->{debug}; } ################################################################################ # IO routines ################################################################################ sub _set_init_state { my ($self, $conn_id) = @_; my $conn = $self->{connections}{$conn_id} or die "YAHC: unknown connection id $conn_id\n"; $conn->{response} = { status => 0 }; $conn->{state} = YAHC::State::INITIALIZED(); _register_in_timeline($conn, "new state %s", _strstate($conn->{state})) if exists $conn->{debug_or_timeline}; _call_state_callback($self, $conn, 'init_callback') if exists $conn->{has_init_callback}; _close_or_cache_socket($self, $conn, 1); # force connection close if any (likely not) my $watchers = _delete_watchers_but_lifetime_timer($self, $conn_id); # implicit stop of all watchers return _set_user_action_state($self, $conn_id, YAHC::Error::RETRY_LIMIT(), "retries limit reached") if $conn->{attempt} > $conn->{retries}; # don't move attempt increment before boundary check !!! # otherwise we can get off-by-one error in yahc_conn_attempts_left my $attempt = ++$conn->{attempt}; if ($attempt > 1 && exists $conn->{request}{_backoff}) { my $backoff_delay = eval { $conn->{request}{_backoff}->($conn) }; if (my $error = $@) { return _set_user_action_state($self, $conn_id, YAHC::Error::CALLBACK_ERROR() | YAHC::Error::TERMINAL_ERROR(), "exception in backoff callback (close connection): $error"); }; if ($backoff_delay) { $self->{loop}->now_update; _register_in_timeline($conn, "setting backoff_timer to %.3fs", $backoff_delay) if exists $conn->{debug_or_timeline}; $watchers->{backoff_timer} = $self->{loop}->timer($backoff_delay, 0, _get_safe_wrapper($self, $conn, sub { _register_in_timeline($conn, "backoff timer of %.3fs expired, time for new attempt", $backoff_delay) if exists $conn->{debug_or_timeline}; _set_init_state($self, $conn_id) if _init_helper($self, $conn_id) == 1; })); return; } } if (_init_helper($self, $conn_id) == 1) { _register_in_timeline($conn, "do attempt on next EV iteration, (iteration=%d)", $self->{loop}->iteration) if exists $conn->{debug_or_timeline}; # from EV docs: # idle watcher call the callback when there are no other pending # watchers of the same or higher priority. The idle watchers are # being called once per event loop iteration - until stopped. # # so, what we do is we start idle watcher with priority 1 which is # higher then 0 used by all IO watchers. As result, the callback # will be called at the end of this iteration. And others if neccessary. my $retry_watcher = $watchers->{retry} ||= $self->{loop}->idle_ns(_get_safe_wrapper($self, $conn, sub { shift->stop; # stop this watcher, _set_init_state will start if neccessary _register_in_timeline($conn, "time for new attempt (iteration=%d)", $self->{loop}->iteration) if exists $conn->{debug_or_timeline}; _set_init_state($self, $conn_id) })); $retry_watcher->priority(1); $retry_watcher->start; }; } sub _init_helper { my ($self, $conn_id) = @_; my $conn = $self->{connections}{$conn_id} or die "YAHC: unknown connection id $conn_id\n"; my $watchers = $self->{watchers}{$conn_id} or die "YAHC: no watchers for connection id $conn_id\n"; my $request = $conn->{request}; $self->{loop}->now_update; # update time for timers _set_until_state_timer($self, $conn_id, 'request_timeout', YAHC::State::USER_ACTION(), YAHC::Error::TIMEOUT() | YAHC::Error::REQUEST_TIMEOUT()) if $request->{request_timeout}; _set_until_state_timer($self, $conn_id, 'connect_timeout', YAHC::State::CONNECTED(), YAHC::Error::TIMEOUT() | YAHC::Error::CONNECT_TIMEOUT()) if $request->{connect_timeout}; _set_until_state_timer($self, $conn_id, 'drain_timeout', YAHC::State::READING(), YAHC::Error::TIMEOUT() | YAHC::Error::DRAIN_TIMEOUT()) if $request->{drain_timeout}; eval { my ($host, $ip, $port, $scheme) = _get_next_target($conn); _register_in_timeline($conn, "Target $scheme://$host:$port ($ip:$port) chosen for attempt #%d", $conn->{attempt}) if exists $conn->{debug_or_timeline}; my $sock; if (my $socket_cache = $request->{_socket_cache}) { $sock = $socket_cache->(YAHC::SocketCache::GET(), $conn); } if (defined $sock) { _register_in_timeline($conn, "reuse socket") if $conn->{debug_or_timeline}; $watchers->{_fh} = $sock; $watchers->{io} = $self->{loop}->io($sock, EV::WRITE, sub {}); _set_write_state($self, $conn_id); } else { _register_in_timeline($conn, "build new socket") if $conn->{debug_or_timeline}; $sock = _build_socket_and_connect($ip, $port); _set_connecting_state($self, $conn_id, $sock); } 1; } or do { my $error = $@ || 'zombie error'; $error =~ s/\s+$//o; yahc_conn_register_error($conn, YAHC::Error::CONNECT_ERROR(), "connection attempt %d failed: %s", $conn->{attempt}, $error); return 1; }; return 0; } sub _set_connecting_state { my ($self, $conn_id, $sock) = @_; my $conn = $self->{connections}{$conn_id} or die "YAHC: unknown connection id $conn_id\n"; my $watchers = $self->{watchers}{$conn_id} or die "YAHC: no watchers for connection id $conn_id\n"; $conn->{state} = YAHC::State::CONNECTING(); _register_in_timeline($conn, "new state %s", _strstate($conn->{state})) if exists $conn->{debug_or_timeline}; _call_state_callback($self, $conn, 'connecting_callback') if exists $conn->{has_connecting_callback}; my $connecting_cb = _get_safe_wrapper($self, $conn, sub { my $sockopt = getsockopt($sock, SOL_SOCKET, SO_ERROR); if (!$sockopt) { yahc_conn_register_error($conn, YAHC::Error::CONNECT_ERROR(), "Failed to do getsockopt(): '%s' errno=%d", "$!", $!+0); _set_init_state($self, $conn_id); return; } if (my $err = unpack("L", $sockopt)) { my $strerror = POSIX::strerror($err) || ''; yahc_conn_register_error($conn, YAHC::Error::CONNECT_ERROR(), "Failed to connect: $strerror"); _set_init_state($self, $conn_id); return; } _set_connected_state($self, $conn_id); }); $watchers->{_fh} = $sock; $watchers->{io} = $self->{loop}->io($sock, EV::WRITE, $connecting_cb); _check_stop_condition($self, $conn) if exists $self->{stop_condition}; } sub _set_connected_state { my ($self, $conn_id) = @_; my $conn = $self->{connections}{$conn_id} or die "YAHC: unknown connection id $conn_id\n"; my $watchers = $self->{watchers}{$conn_id} or die "YAHC: no watchers for connection id $conn_id\n"; $conn->{state} = YAHC::State::CONNECTED(); _register_in_timeline($conn, "new state %s", _strstate($conn->{state})) if exists $conn->{debug_or_timeline}; _call_state_callback($self, $conn, 'connected_callback') if exists $conn->{has_connected_callback}; my $connected_cb = _get_safe_wrapper($self, $conn, sub { if ($conn->{is_ssl}) { _set_ssl_handshake_state($self, $conn_id); } else { _set_write_state($self, $conn_id); } }); #$watcher->events(EV::WRITE); $watchers->{io}->cb($connected_cb); _check_stop_condition($self, $conn) if exists $self->{stop_condition}; } sub _set_ssl_handshake_state { my ($self, $conn_id) = @_; my $conn = $self->{connections}{$conn_id} or die "YAHC: unknown connection id $conn_id\n"; my $watchers = $self->{watchers}{$conn_id} or die "YAHC: no watchers for connection id $conn_id\n"; $conn->{state} = YAHC::State::SSL_HANDSHAKE(); _register_in_timeline($conn, "new state %s", _strstate($conn->{state})) if exists $conn->{debug_or_timeline}; #_call_state_callback($self, $conn, 'writing_callback') if $conn->{has_writing_callback}; TODO my $fh = $watchers->{_fh}; my $hostname = $conn->{selected_target}[0]; my %options = ( SSL_verifycn_name => $hostname, IO::Socket::SSL->can_client_sni ? ( SSL_hostname => $hostname ) : (), %{ $conn->{request}{ssl_options} || {} }, ); if ($conn->{debug_or_timeline}) { my $options_msg = join(', ', map { "$_=" . ($options{$_} || '') } keys %options); _register_in_timeline($conn, "start SSL handshake with options: $options_msg"); } if (!IO::Socket::SSL->start_SSL($fh, %options, SSL_startHandshake => 0)) { return _set_user_action_state($self, $conn_id, YAHC::Error::SSL_ERROR() | YAHC::Error::TERMINAL_ERROR(), sprintf("failed to start SSL session: %s", _format_ssl_error())); } my $handshake_cb = _get_safe_wrapper($self, $conn, sub { my $w = shift; if ($fh->connect_SSL) { _register_in_timeline($conn, "SSL handshake successfully completed") if exists $conn->{debug_or_timeline}; return _set_write_state($self, $conn_id); } if ($! == EWOULDBLOCK) { return $w->events(EV::READ) if $IO::Socket::SSL::SSL_ERROR == SSL_WANT_READ; return $w->events(EV::WRITE) if $IO::Socket::SSL::SSL_ERROR == SSL_WANT_WRITE; } yahc_conn_register_error($conn, YAHC::Error::SSL_ERROR(), "Failed to complete SSL handshake: %s", _format_ssl_error()); _set_init_state($self, $conn_id); }); my $watcher = $watchers->{io}; $watcher->cb($handshake_cb); $watcher->events(EV::WRITE | EV::READ); _check_stop_condition($self, $conn) if exists $self->{stop_condition}; } sub _set_write_state { my ($self, $conn_id) = @_; my $conn = $self->{connections}{$conn_id} or die "YAHC: unknown connection id $conn_id\n"; my $watchers = $self->{watchers}{$conn_id} or die "YAHC: no watchers for connection id $conn_id\n"; $conn->{state} = YAHC::State::WRITING(); _register_in_timeline($conn, "new state %s", _strstate($conn->{state})) if exists $conn->{debug_or_timeline}; _call_state_callback($self, $conn, 'writing_callback') if exists $conn->{has_writing_callback}; my $fh = $watchers->{_fh}; my $buf = _build_http_message($conn); my $length = length($buf); warn "YAHC: HTTP message has UTF8 flag set! This will result in poor performance, see docs for details!" if utf8::is_utf8($buf); _register_in_timeline($conn, "writing body of %d bytes\n%s", $length, ($length > 1024? substr($buf, 0, 1024) . '... (cut to 1024 bytes)' : $buf)) if exists $conn->{debug_or_timeline}; my $write_cb = _get_safe_wrapper($self, $conn, sub { my $w = shift; my $wlen = syswrite($fh, $buf, $length); if (!defined $wlen) { if ($conn->{is_ssl}) { if ($! == EWOULDBLOCK) { return $w->events(EV::READ) if $IO::Socket::SSL::SSL_ERROR == SSL_WANT_READ; return $w->events(EV::WRITE) if $IO::Socket::SSL::SSL_ERROR == SSL_WANT_WRITE; } yahc_conn_register_error($conn, YAHC::Error::WRITE_ERROR() | YAHC::Error::SSL_ERROR(), "Failed to send HTTPS data: %s", _format_ssl_error()); return _set_init_state($self, $conn_id); } return if $! == EWOULDBLOCK || $! == EINTR || $! == EAGAIN; yahc_conn_register_error($conn, YAHC::Error::WRITE_ERROR(), "Failed to send HTTP data: '%s' errno=%d", "$!", $!+0); _set_init_state($self, $conn_id); } elsif ($wlen == 0) { yahc_conn_register_error($conn, YAHC::Error::WRITE_ERROR(), "syswrite returned 0"); _set_init_state($self, $conn_id); } else { substr($buf, 0, $wlen, ''); $length -= $wlen; _set_read_state($self, $conn_id) if $length == 0; } }); my $watcher = $watchers->{io}; $watcher->cb($write_cb); $watcher->events(EV::WRITE); _check_stop_condition($self, $conn) if exists $self->{stop_condition}; } sub _set_read_state { my ($self, $conn_id) = @_; my $conn = $self->{connections}{$conn_id} or die "YAHC: unknown connection id $conn_id\n"; my $watchers = $self->{watchers}{$conn_id} or die "YAHC: no watchers for connection id $conn_id\n"; $conn->{state} = YAHC::State::READING(); _register_in_timeline($conn, "new state %s", _strstate($conn->{state})) if exists $conn->{debug_or_timeline}; _call_state_callback($self, $conn, 'reading_callback') if exists $conn->{has_reading_callback}; my $buf = ''; my $neck_pos = 0; my $decapitated = 0; my $content_length = 0; my $no_content_length = 0; my $is_chunked = 0; my $fh = $watchers->{_fh}; my $chunk_size = 0; my $body = ''; # used for chunked encoding my $read_cb = _get_safe_wrapper($self, $conn, sub { my $w = shift; my $rlen = sysread($fh, my $b = '', TCP_READ_CHUNK); if (!defined $rlen) { if ($conn->{is_ssl}) { if ($! == EWOULDBLOCK) { return $w->events(EV::READ) if $IO::Socket::SSL::SSL_ERROR == SSL_WANT_READ; return $w->events(EV::WRITE) if $IO::Socket::SSL::SSL_ERROR == SSL_WANT_WRITE; } yahc_conn_register_error($conn, YAHC::Error::READ_ERROR() | YAHC::Error::SSL_ERROR(), "Failed to receive HTTPS data: %s", _format_ssl_error()); return _set_init_state($self, $conn_id); } return if $! == EWOULDBLOCK || $! == EINTR || $! == EAGAIN; yahc_conn_register_error($conn, YAHC::Error::READ_ERROR(), "Failed to receive HTTP data: '%s' errno=%d", "$!", $!+0); _set_init_state($self, $conn_id); } elsif ($rlen == 0) { if ($no_content_length) { $conn->{response}{body} = $buf.$b; _set_user_action_state($self, $conn_id); return; } if ($content_length > 0) { yahc_conn_register_error($conn, YAHC::Error::READ_ERROR(), "Premature EOF, expect %d bytes more", $content_length - length($buf)); } else { yahc_conn_register_error($conn, YAHC::Error::READ_ERROR(), "Premature EOF"); } _set_init_state($self, $conn_id); } else { $buf .= $b; if (!$decapitated && ($neck_pos = index($buf, "${CRLF}${CRLF}")) > 0) { my $headers = _parse_http_headers($conn, substr($buf, 0, $neck_pos, '')); # $headers are always defined but might be empty, maybe fix later $is_chunked = ($headers->{'transfer-encoding'} || '') eq 'chunked'; if ($is_chunked && exists $headers->{'trailer'}) { _set_user_action_state($self, $conn_id, YAHC::Error::RESPONSE_ERROR(), "Chunked HTTP response with Trailer header"); return; } $decapitated = 1; substr($buf, 0, 4, ''); # 4 = length("$CRLF$CRLF") # Attempt to correctly determine content length, see RFC 2616 section 4.4 if (($conn->{request}->{method} || '') eq 'HEAD' || $conn->{response}->{status} =~ /^(1..|204|304)$/) { # 1. $content_length = 0; } elsif ($is_chunked) { # 2. (sort of, should actually also care for non-chunked transfer encodings) # No content length, use chunked transfer encoding instead } elsif (exists $headers->{'content-length'}) { # 3. $content_length = $headers->{'content-length'}; if ($content_length !~ m#\A[0-9]+\z#) { _set_user_action_state($self, $conn_id, YAHC::Error::RESPONSE_ERROR(), "Not-numeric Content-Length received on the response"); return; } } else { # byteranges (point .4 on the spec) not supported $no_content_length = 1; } } if ($decapitated && $is_chunked) { # in order to get the smallest chunk size we need # at least 4 bytes (2xCLRF), and there *MUST* be # last chunk which is at least 5 bytes (0\r\n\r\n) # so we can safely ignore $bufs that have less than 5 bytes while (length($buf) > ($chunk_size + 4)) { my $neck_pos = index($buf, ${CRLF}); if ($neck_pos > 0) { # http://www.w3.org/Protocols/rfc2616/rfc2616-sec3.html # All HTTP/1.1 applications MUST be able to receive and # decode the "chunked" transfer-coding, and MUST ignore # chunk-extension extensions they do not understand. my ($s) = split(';', substr($buf, 0, $neck_pos), 1); $chunk_size = hex($s); _register_in_timeline($conn, "parsing chunk of size $chunk_size bytes") if exists $conn->{debug_or_timeline}; if ($chunk_size == 0) { # end with, but as soon as we see 0\r\n\r\n we just mark it as done $conn->{response}{body} = $body; _set_user_action_state($self, $conn_id); return; } else { if (length($buf) >= $chunk_size + $neck_pos + 2 + 2) { $body .= substr($buf, $neck_pos + 2, $chunk_size); substr($buf, 0, $neck_pos + 2 + $chunk_size + 2, ''); $chunk_size = 0; } else { last; # dont have enough data in this pass, wait for one more read } } } else { last if $neck_pos < 0 && $chunk_size == 0; # in case we couldnt get the chunk size in one go, we must concat until we have something _set_user_action_state($self, $conn_id, YAHC::Error::RESPONSE_ERROR(), "error processing chunked data, couldnt find CLRF[index:$neck_pos] in buf"); return; } } } elsif ($decapitated && !$no_content_length && length($buf) >= $content_length) { $conn->{response}{body} = (length($buf) > $content_length ? substr($buf, 0, $content_length) : $buf); _set_user_action_state($self, $conn_id); } } }); my $watcher = $watchers->{io}; $watcher->cb($read_cb); $watcher->events(EV::READ); _check_stop_condition($self, $conn) if exists $self->{stop_condition}; } sub _set_user_action_state { my ($self, $conn_id, $error, $strerror) = @_; $error ||= YAHC::Error::NO_ERROR(); $strerror ||= ''; # this state may be used in critical places, # so it should *NEVER* throw exception my $conn = $self->{connections}{$conn_id} or warn "YAHC: try to _set_user_action_state() for unknown connection $conn_id", return; $conn->{state} = YAHC::State::USER_ACTION(); _register_in_timeline($conn, "new state %s", _strstate($conn->{state})) if exists $conn->{debug_or_timeline}; yahc_conn_register_error($conn, $error, $strerror) if $error != YAHC::Error::NO_ERROR; _close_or_cache_socket($self, $conn, $error != YAHC::Error::NO_ERROR); return _set_completed_state($self, $conn_id) unless exists $conn->{has_callback}; eval { _register_in_timeline($conn, "call callback%s", $error ? " error=$error, strerror='$strerror'" : '') if exists $conn->{debug_or_timeline}; my $cb = $self->{callbacks}{$conn_id}{callback}; $cb->($conn, $error, $strerror); 1; } or do { my $error = $@ || 'zombie error'; yahc_conn_register_error($conn, YAHC::Error::CALLBACK_ERROR() | YAHC::Error::TERMINAL_ERROR(), "Exception in user action callback (close connection): $error"); $self->{state} = YAHC::State::COMPLETED(); }; $self->{loop}->now_update; my $state = $conn->{state}; if (yahc_terminal_error($error)) { yahc_conn_register_error($conn, YAHC::Error::CALLBACK_ERROR() | YAHC::Error::TERMINAL_ERROR(), "ignoring changed state due to terminal error") unless $state == YAHC::State::USER_ACTION() || $state == YAHC::State::COMPLETED(); _set_completed_state($self, $conn_id, 1); return } _register_in_timeline($conn, "after invoking callback state is %s", _strstate($state)) if exists $conn->{debug_or_timeline}; if ($state == YAHC::State::INITIALIZED()) { _set_init_state($self, $conn_id); } elsif ($state == YAHC::State::USER_ACTION() || $state == YAHC::State::COMPLETED()) { _set_completed_state($self, $conn_id); } else { yahc_conn_register_error($conn, YAHC::Error::CALLBACK_ERROR() | YAHC::Error::TERMINAL_ERROR(), "callback set unsupported state"); _set_completed_state($self, $conn_id); } } sub _set_completed_state { my ($self, $conn_id, $force_socket_close) = @_; # this's a terminal state, # so setting this state should *NEVER* fail delete $self->{callbacks}{$conn_id}; my $conn = delete $self->{connections}{$conn_id}; if (!defined $conn) { delete($self->{watchers}{$conn_id}), # implicit stop of all watchers return; } $conn->{state} = YAHC::State::COMPLETED(); _register_in_timeline($conn, "new state %s", _strstate($conn->{state})) if exists $conn->{debug_or_timeline}; _close_or_cache_socket($self, $conn, $force_socket_close); delete $self->{watchers}{$conn_id}; # implicit stop of all watchers _check_stop_condition($self, $conn) if exists $self->{stop_condition}; } sub _build_socket_and_connect { my ($ip, $port) = @_; my $sock; socket($sock, PF_INET, SOCK_STREAM, 0) or die sprintf("Failed to construct TCP socket: '%s' errno=%d\n", "$!", $!+0); my $flags = fcntl($sock, F_GETFL, 0) or die sprintf("Failed to get fcntl F_GETFL flag: '%s' errno=%d\n", "$!", $!+0); fcntl($sock, F_SETFL, $flags | O_NONBLOCK) or die sprintf("Failed to set fcntl O_NONBLOCK flag: '%s' errno=%d\n", "$!", $!+0); my $ip_addr = inet_aton($ip) or die "Invalid IP address"; my $addr = pack_sockaddr_in($port, $ip_addr); if (!connect($sock, $addr) && $! != EINPROGRESS) { die sprintf("Failed to connect: '%s' errno=%d\n", "$!", $!+0); } return $sock; } sub _get_next_target { my $conn = shift; my ($host, $ip, $port, $scheme) = $conn->{request}{_target}->($conn); # TODO STATE_RESOLVE_DNS ($host, $port) = ($1, $2) if !$port && $host =~ m/^(.+):([0-9]+)$/o; $ip = $host if !$ip && $host =~ m/^[0-9]+\.[0-9]+\.[0-9]+\.[0-9]+$/o; $ip ||= inet_ntoa(gethostbyname($host) or die "Failed to resolve $host\n"); $scheme ||= $conn->{request}{scheme} || 'http'; $port ||= $conn->{request}{port} || ($scheme eq 'https' ? 443 : 80); $conn->{is_ssl} = $scheme eq 'https'; return @{ $conn->{selected_target} = [ $host, $ip, $port, $scheme ] }; } # this and following functions are used in terminal state # so they should *NEVER* fail sub _close_or_cache_socket { my ($self, $conn, $force_close) = @_; my $watchers = $self->{watchers}{$conn->{id}} or return; my $fh = delete $watchers->{_fh} or return; delete $watchers->{io}; # implicit stop my $socket_cache = $conn->{request}{_socket_cache}; # Stolen from Hijk. Thanks guys!!! # 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! if ( $force_close || !defined $socket_cache || (($conn->{request}{proto} || '') eq 'HTTP/1.0') || (($conn->{response}{proto} || '') eq 'HTTP/1.0') || (($conn->{response}{head}{connection} || '') eq 'close')) { _register_in_timeline($conn, "drop socket") if $conn->{debug_or_timeline}; close($fh) if ref($fh) eq 'GLOB'; # checking ref to avoid exception return; } _register_in_timeline($conn, "storing socket for later use") if $conn->{debug_or_timeline}; eval { $socket_cache->(YAHC::SocketCache::STORE(), $conn, $fh); 1; } or do { yahc_conn_register_error($conn, YAHC::Error::CALLBACK_ERROR(), "Exception in socket_cache callback (ignore error): $@"); }; } sub yahc_conn_socket_cache_id { my $conn = shift; return unless defined $conn; my ($host, undef, $port, $scheme) = @{ $conn->{selected_target} || [] }; return unless $host && $port && $scheme; # Use $; so we can use the $socket_cache->{$$, $host, $port} idiom to access the cache. return join($;, $$, $host, $port, $scheme); } ################################################################################ # Timers ################################################################################ sub _set_until_state_timer { my ($self, $conn_id, $timeout_name, $state, $error_to_report) = @_; my $timer_name = $timeout_name . '_timer'; my $conn = $self->{connections}{$conn_id} or die "YAHC: unknown connection id $conn_id\n"; my $watchers = $self->{watchers}{$conn_id} or die "YAHC: no watchers for connection id $conn_id\n"; delete $watchers->{$timer_name}; # implicit stop my $timeout = $conn->{request}{$timeout_name}; return unless $timeout; my $timer_cb = sub { # there is nothing what can throw exception if ($conn->{state} < $state) { yahc_conn_register_error($conn, $error_to_report, "$timeout_name of %.3fs expired", $timeout); _set_init_state($self, $conn_id); } else { _register_in_timeline($conn, "delete $timer_name") if exists $conn->{debug_or_timeline}; } }; _register_in_timeline($conn, "setting $timeout_name to %.3fs", $timeout) if exists $conn->{debug_or_timeline}; # caller should call now_update my $w = $watchers->{$timer_name} = $self->{loop}->timer_ns($timeout, 0, $timer_cb); $w->priority(2); # set highest priority $w->start; } sub _set_lifetime_timer { my ($self, $conn_id) = @_; my $conn = $self->{connections}{$conn_id} or die "YAHC: unknown connection id $conn_id\n"; my $watchers = $self->{watchers}{$conn_id} or die "YAHC: no watchers for connection id $conn_id\n"; delete $watchers->{lifetime_timer}; # implicit stop my $timeout = $conn->{request}{lifetime_timeout}; return unless $timeout; _register_in_timeline($conn, "setting lifetime timer to %.3fs", $timeout) if exists $conn->{debug_or_timeline}; $self->{loop}->now_update; my $w = $watchers->{lifetime_timer} = $self->{loop}->timer_ns($timeout, 0, sub { _set_user_action_state($self, $conn_id, YAHC::Error::TIMEOUT() | YAHC::Error::LIFETIME_TIMEOUT() | YAHC::Error::TERMINAL_ERROR(), sprintf("lifetime_timeout of %.3fs expired", $timeout)) if $conn->{state} < YAHC::State::COMPLETED(); }); $w->priority(2); # set highest priority $w->start; } ################################################################################ # HTTP functions ################################################################################ # copy-paste from Hijk sub _build_http_message { my $conn = shift; my $request = $conn->{request}; my $path_and_qs = ($request->{path} || "/") . (defined $request->{query_string} ? ("?" . $request->{query_string}) : ""); my $has_host = 0; return join( $CRLF, ($request->{method} || "GET") . " $path_and_qs " . ($request->{protocol} || "HTTP/1.1"), defined($request->{body}) ? ("Content-Length: " . length($request->{body})) : (), defined($request->{head}) && @{ $request->{head} } ? ( map { $has_host ||= lc($request->{head}[2*$_]) eq 'host'; $request->{head}[2*$_] . ": " . $request->{head}[2*$_+1] } 0..$#{$request->{head}}/2 ) : (), !$has_host ? ("Host: " . $conn->{selected_target}[0]) : (), "", defined($request->{body}) ? $request->{body} : "" ); } sub _parse_http_headers { my $conn = shift; my $proto = substr($_[0], 0, 8); my $status_code = substr($_[0], 9, 3); substr($_[0], 0, index($_[0], $CRLF) + 2, ''); # 2 = length($CRLF) my %headers; for (split /${CRLF}/o, $_[0]) { my ($key, $value) = split(/: /, $_, 2); $headers{lc $key} = $value; } $conn->{response} = { proto => $proto, status => $status_code, head => \%headers, }; if ($conn->{debug_or_timeline}) { my $headers_str = join(' ', map { "$_='$headers{$_}'" } keys %headers); _register_in_timeline($conn, "headers parsed: $status_code $proto headers=$headers_str"); } return \%headers; } ################################################################################ # Helpers ################################################################################ sub _delete_watchers_but_lifetime_timer { my ($self, $conn_id) = @_; my $watchers = $self->{watchers}{$conn_id}; if (defined $watchers && (my $w = $watchers->{lifetime_timer})) { return $self->{watchers}{$conn_id} = { lifetime_timer => $w }; } return $self->{watchers}{$conn_id} = {}; } sub _wrap_host { my ($value) = @_; my $ref = ref($value); return sub { $value } if $ref eq ''; return $value if $ref eq 'CODE'; my $idx = 0; return sub { $value->[$idx++ % @$value]; } if $ref eq 'ARRAY' && @$value > 0; die "YAHC: unsupported host format\n"; } sub _wrap_backoff { my ($value) = @_; my $ref = ref($value); return sub { $value } if $ref eq ''; return $value if $ref eq 'CODE'; die "YAHC: unsupported backoff format\n"; } sub _wrap_socket_cache { my ($value) = @_; my $ref = ref($value); return $value if $ref eq 'CODE'; return sub { my ($operation, $conn, $sock) = @_; if ($operation == YAHC::SocketCache::GET()) { my $socket_cache_id = yahc_conn_socket_cache_id($conn) or return; return delete $value->{$socket_cache_id}; } if ($operation == YAHC::SocketCache::STORE()) { my $socket_cache_id = yahc_conn_socket_cache_id($conn) or return; close(delete $value->{$socket_cache_id}) if exists $value->{$socket_cache_id}; $value->{$socket_cache_id} = $sock; return; } } if $ref eq 'HASH'; die "YAHC: unsupported socket_cache format\n"; } sub _call_state_callback { my ($self, $conn, $cb_name) = @_; my $cb = $self->{callbacks}{$conn->{id}}{$cb_name}; return unless $cb; _register_in_timeline($conn, "calling $cb_name callback") if exists $conn->{debug_or_timeline}; eval { $cb->($conn); 1; } or do { my $error = $@ || 'zombie error'; yahc_conn_register_error($conn, YAHC::Error::CALLBACK_ERROR(), "exception in state callback (ignore error): $error"); }; $self->{loop}->now_update; } sub _get_safe_wrapper { my ($self, $conn, $sub) = @_; return sub { eval { $sub->(@_); 1; } or do { my $error = $@ || 'zombie error'; _set_user_action_state($self, $conn->{id}, YAHC::Error::INTERNAL_ERROR() | YAHC::Error::TERMINAL_ERROR(), "exception in internal callback: $error"); }}; } sub _register_in_timeline { my ($conn, $format, @arguments) = @_; my $event = sprintf("$format", @arguments); _log_message("YAHC connection '%s': %s", $conn->{id}, $event) if exists $conn->{debug}; push @{ $conn->{timeline} ||= [] }, [ $event, $conn->{state}, Time::HiRes::time ] if exists $conn->{keep_timeline}; } sub yahc_conn_register_error { my ($conn, $error, $format, @arguments) = @_; my $strerror = sprintf("$format", @arguments); _register_in_timeline($conn, "strerror='$strerror' error=$error") if exists $conn->{debug_or_timeline}; push @{ $conn->{errors} ||= [] }, [ $error, $strerror, [ @{ $conn->{selected_target} } ], Time::HiRes::time, $conn->{attempt} ]; } sub _strstate { my $state = shift; return 'STATE_INIT' if $state eq YAHC::State::INITIALIZED(); return 'STATE_RESOLVE_DNS' if $state eq YAHC::State::RESOLVE_DNS(); return 'STATE_CONNECTING' if $state eq YAHC::State::CONNECTING(); return 'STATE_CONNECTED' if $state eq YAHC::State::CONNECTED(); return 'STATE_WRITING' if $state eq YAHC::State::WRITING(); return 'STATE_READING' if $state eq YAHC::State::READING(); return 'STATE_SSL_HANDSHAKE'if $state eq YAHC::State::SSL_HANDSHAKE(); return 'STATE_USER_ACTION' if $state eq YAHC::State::USER_ACTION(); return 'STATE_COMPLETED' if $state eq YAHC::State::COMPLETED(); return ""; } sub _log_message { my $format = shift; my $now = Time::HiRes::time; my ($sec, $ms) = split(/[.]/, $now); printf STDERR "[%s.%-5d] [$$] $format\n", POSIX::strftime('%F %T', localtime($now)), $ms || 0, @_; } sub _format_ssl_error { return sprintf("'%s' errno=%d ssl_error='%s' ssl_errno=%d", "$!", 0+$!, "$IO::Socket::SSL::SSL_ERROR", 0+$IO::Socket::SSL::SSL_ERROR); } 1; __END__ =encoding utf8 =head1 NAME YAHC - Yet another HTTP client =head1 SYNOPSIS use YAHC qw/yahc_reinit_conn/; my @hosts = ('www.booking.com', 'www.google.com:80'); my ($yahc, $yahc_storage) = YAHC->new({ host => \@hosts }); $yahc->request({ path => '/', host => 'www.reddit.com' }); $yahc->request({ path => '/', host => sub { 'www.reddit.com' } }); $yahc->request({ path => '/', host => \@hosts }); $yahc->request({ path => '/', callback => sub { ... } }); $yahc->request({ path => '/' }); $yahc->request({ path => '/', callback => sub { yahc_reinit_conn($_[0], { host => 'www.newtarget.com' }) if $_[0]->{response}{status} == 301; } }); $yahc->run; =head1 DESCRIPTION YAHC is fast & minimal low-level asynchronous HTTP client intended to be used where you control both the client and the server. Is especially suits cases where set of requests need to be executed against group of machines. It is B a general HTTP user agent, it doesn't support redirects, proxies 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. YAHC supports SSL and socket reuse (latter is in experimental mode). =head1 STATE MACHINE Each YAHC connection goes through following list of states in its lifetime: +-----------------+ +<<-| INITALIZED <-<<+ v +-----------------+ ^ v | ^ v +-------v---------+ ^ +<<-+ RESOLVE DNS +->>+ v +-----------------+ ^ v | ^ v +-------v---------+ ^ +<<-+ CONNECTING +->>+ v +-----------------+ ^ v | ^ Path in v +-------v---------+ ^ Retry case of +<<-+ CONNECTED +->>+ logic failure v +-----------------+ ^ path v | ^ v +-------v---------+ ^ +<<-+ WRITING +->>+ v +-----------------+ ^ v | ^ v +-------v---------+ ^ +<<-+ READING +->>+ v +-----------------+ ^ v | ^ v +-------v---------+ ^ +>>-> USER ACTION +->>+ +-----------------+ | +-------v---------+ | COMPLETED | +-----------------+ There are three paths of workflow: =over 4 =item 1) Normal execution (central line). In normal situation a connection after being initialized goes through state: - RESOLVE DNS (not implemented) - CONNECTING - wait finishing of handshake - CONNECTED - WRITING - sending request body - READING - awaiting and reading response - USER ACTION - see below - COMPLETED - all done, this is terminal state SSL connection has extra state SSL_HANDSHAKE after CONNECTED state. State 'RESOLVE DNS' is not implemented yet. =item 2) Retry path (right line). In case of IO error during normal execution YAHC retries connection C times. In practice this means that connection goes back to INITIALIZED state. =item 3) Failure path (left line). If all retry attempts did not succeeded a connection goes to state 'USER ACTION' (see below). =back =head2 State 'USER ACTION' 'USER ACTION' state is called right before connection if going to enter 'COMPLETED' state (with either failed or successful results) and is meant to give a chance to user to interrupt the workflow. 'USER ACTION' state is entered in these circumstances: =over 4 =item * HTTP response received. Note that non-200 responses are NOT treated as error. =item * unsupported HTTP response is received (such as response without Content-Length header) =item * retries limit reached =item * lifetime timeout has expired =item * provided callback has thrown exception =item * internal error has occured =back When a connection enters this state C CodeRef is called: $yahc->request({ ... callback => sub { my ( $conn, # connection 'object' $error, # one of YAHC::Error::* constants $strerror # string representation of error ) = @_; # Note that fields in $conn->{response} are not reliable # if $error != YAHC::Error::NO_ERROR() # HTTP response is stored in $conn->{response}. # It can be also accessed via yahc_conn_response(). my $response = $conn->{response}; my $status = $response->{status}; my $body = $response->{body}; } }); If there was no IO error C return C representing response. It contains the following key-value pairs. proto => :Str status => :StatusCode body => :Str head => :HashRef In case of a error or non-200 HTTP response C or C may be called to give the request more chances to complete successfully (for example by following redirects or providing new target hosts). Also, note that in case of a error data returned by C cannot be trusted. For example, if an IO error happened during receiving HTTP body headers would state 200 response code. YAHC lowercases headers names returned in C. This is done to comply with RFC which identify HTTP headers as case-insensitive. In some cases connection cannot be retried anymore and callback is called for information purposes only. This case can be distinguished by C<$error> having YAHC::Error::TERMINAL_ERROR() bit set. One can use C helper to detect such case. Note that C should NOT throw exception. If so the connection will be immediately closed. =head1 METHODS =head2 new This method creates YAHC object and accompanying storage object: my ($yahc, $yahc_storage) = YAHC->new(); This is a radical way of solving all possible memleak because of cyclic references in callbacks. Since all references of callbacks are kept in $yahc_storage object it's fine to use YAHC object inside request callback: my $yahc->request({ callback => sub { $yahc->stop; # this is fine!!! }, }); However, user has to guarantee that both $yahc and $yahc_storage objects are kept in the same scope. So, they will be destroyed at the same time. C can be passed with all parameters supported by C. They will be inherited by all requests. Additionally, C supports three parameters: C, C, and C. =head3 socket_cache C option controls socket reuse logic. By default socket cache is disabled. If user wants YAHC reuse sockets he should set C to a HashRef. my ($yahc, $yahc_storage) = YAHC->new({ socket_cache => {} }); In this case YAHC maintains unused sockets keyed on C. We use C<$;> so we can use the C<< $socket_cache->{$$, $host, $port, $scheme} >> idiom to access the cache. It's up to user to control the cache. It's also up to user to set necessary request headers for keep-alive. YAHC does not cache socket in cases of an error, HTTP/1.0 and when server explicitly instructs to close connection (i.e. header 'Connection' = 'close'). =head3 loop By default, each YAHC object will use its own EV eventloop. This is normally preferred since it allows for more accurate timing metrics. However, if the process is already using an eventloop, having an inner loop means the outer one stays waiting until the inner one is done. To get around this, one can specify the eventloop that YAHC will use: my ($yahc, $storage) = YAHC->new({ loop => EV::default_loop(), # use the default EV eventloop }); Using the above, YAHC will be sharing the same eventloop as everyone else, so some operations are now riskier and should be avoided; For example, in most scenarios C should not be used alongside C, as only whatever is entering the eventloop should set the signal handlers. =head3 account_for_signals Another parameter C requires special attention! Here is why: =over 4 excerpt from EV documentation L While Perl signal handling (%SIG) is not affected by EV, the behaviour with EV is as the same as any other C library: Perl-signals will only be handled when Perl runs, which means your signal handler might be invoked only the next time an event callback is invoked. =back In practise this means that none of set %SIG handlers will be called until EV calls one of perl callbacks. Which, in some cases, may take a long time. By setting C YAHC adds C watcher with empty callback effectively making EV calling the callback on every iteration. The trickery comes at some performance cost. This is what EV documentation says about it: =over 4 ... you can also force a watcher to be called on every event loop iteration by installing a EV::check watcher. This ensures that perl gets into control for a short time to handle any pending signals, and also ensures (slightly) slower overall operation. =back So, if your code or the codes surrounding your code use %SIG handlers it's wise to set C. =head2 request protocol => "HTTP/1.1", # (or "HTTP/1.0") scheme => "http" or "https" host => see below, port => ..., method => "GET", path => "/", query_string => "", head => [], body => "", # timeouts connect_timeout => undef, request_timeout => undef, drain_timeout => undef, lifetime_timeout => undef, # burst control backoff_delay => undef, # callbacks init_callback => undef, connecting_callback => undef, connected_callback => undef, writing_callback => undef, reading_callback => undef, callback => undef, # SSL options ssl_options => {}, Notice how YAHC 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. For example, to send a request to C, pass the following parameters: $yach->request({ host => "example.com", port => "80", path => "/flower", query_string => "color=red" }); =head3 request building YAHC 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. 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. 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" => "YAHC", ] Will produce these request headers: Content-Type: application/json X-Requested-With: YAHC =head3 host C parameter can accept one of following values: =over 4 1) string - represents target host. String may have following formats: hostname:port, ip:port. 2) ArrayRef of strings - YAHC will cycle through items selecting new host for each attempt. 3) CodeRef. The subroutine is invoked for each attempt and should at least return a string (hostname or IP address). It can also return array containing: ($host, $ip, $port, $scheme). This option effectively give a user control over host selection for retries. The CodeRef is passed with connection "object" which can be fed to yahc_conn_* family of functions. =back =head3 timeouts The value of C, C and C is in floating point seconds, and is used as the time limit for connecting to the host (reaching CONNECTED state), full request time (reaching COMPLETED state) and sending request to remote site (reaching READING state) respectively. C has special purpose. Its task is to provide upper bound timeout for a request lifetime. In other words, if a request comes with multiple retries C, C and C are per attempt. C covers all attempts. If by the time C expires a connection is not in COMPLETED state a error is generated. Note that after this error the connection cannot be retried anymore. So, it's forced to go to COMPLETED state. The default value for all is C, meaning no timeout limit. =head3 backoff_delay C can be used to introduce delay between retries. This is a great way to avoid load spikes on server side. Following example creates new request which would be retried twice doing three attempts in total. Second and third attempts will be delay by one second each. $yach->request({ host => "example.com", retries => 2, backoff_delay => 1, }); C can be set in two ways: =over 4 1) floating point seconds - define constant delay between retires. 2) CodeRef. The subroutine is invoked on each retry and should return floating point seconds. This option is useful for having exponentially growing delay or, for instance, jitted delays. =back The default value is C, meaning no delay. =head3 callbacks The value of C, C, C, C, C is a reference to a subroutine which is called upon reaching corresponding state. Any exception thrown in the subroutine will be ignored. The value of C defines main request callback which is called when a connection enters 'USER ACTION' state (see 'USER ACTION' state above). Also see L =head3 ssl_options Performing HTTPS requires the value of C extended by two parameters set to current hostname: SSL_verifycn_name => $hostname, IO::Socket::SSL->can_client_sni ? ( SSL_hostname => $hostname ) : (), Apart of this changes, the value is directly passed to C. For more details refer to IO::Socket::SSL documentation L. =head2 drop Given connection HashRef or conn_id move connection to COMPLETED state (avoiding 'USER ACTION' state) and drop it from internal pool. The function takes two parameters: first is either a connection id or connection HashRef. Second one is a boolean flag indicating whether connection's socket should closed or it might be reused. =head2 run Start YAHC's loop. The loop stops when all connection complete. Note that C can accept two extra parameters: until_state and list of connections. These two parameters tell YAHC to break the loop once specified connections reach desired state. For example: $yahc->run(YAHC::State::READING(), $conn_id); Will loop until connection '$conn_id' move to state READING meaning that the data has been sent to remote side. In order to gather response one should later call: $yahc->run(YAHC::State::COMPLETED(), $conn_id); or simply: $yahc->run(); Leaving list of connection empty makes YAHC waiting for all connection reaching needed until_state. Note that waiting one particular connection to finish doesn't mean that others are not executed. Instead, all active connections are looped at the same time, but YAHC breaks the loop once waited connection reaches needed state. =head2 run_once Same as run but with EV::RUN_ONCE set. For more details check L =head2 run_tick Same as run but with EV::RUN_NOWAIT set. For more details check L =head2 is_running Return true if YAHC is running, false otherwise. =head2 loop Return underlying EV loop object. =head2 break Break running EV loop if any. =head1 EXPORTED FUNCTIONS =head2 yahc_reinit_conn C reinitialize given connection. The attempt counter is reset to 0. The function accepts HashRef as second argument. By passing it one can change host, port, scheme, body, head and others parameters. The format and meaning of these parameters is same as in C method. One of use cases of C, for example, is to handle redirects: use YAHC qw/yahc_reinit_conn/; my ($yahc, $yahc_storage) = YAHC->new(); $yahc->request({ host => 'domain_which_returns_301.com', callback => sub { ... my $conn = $_[0]; yahc_reinit_conn($conn, { host => 'www.newtarget.com' }) if $_[0]->{response}{status} == 301; ... } }); $yahc->run; C is meant to be called inside C i.e. when connection is in 'USER ACTION' state. =head2 yahc_retry_conn Retries given connection. C should be called only if C returns positive value. Otherwise, it exits silently. The function accepts HashRef as second argument. By passing it one can change C parameter. See docs for C for more details about C. Intended usage is to retry transient failures or to try different host: use YAHC qw/ yahc_retry_conn yahc_conn_attempts_left /; my ($yahc, $yahc_storage) = YAHC->new(); $yahc->request({ retries => 2, host => [ 'host1', 'host2' ], callback => sub { ... my $conn = $_[0]; if ($_[0]->{response}{status} == 503 && yahc_conn_attempts_left($conn)) { yahc_retry_conn($conn); return; } ... } }); $yahc->run; C is meant to be called inside C similarly to C. =head2 yahc_conn_id Return id of given connection. =head2 yahc_conn_state Return state of given connection. =head2 yahc_conn_target Return selected host and port for current attempt for given connection. Format "host:port". Default port values are omitted. =head2 yahc_conn_url Same as C but return full URL =head2 yahc_conn_user_data Let user assosiate arbitrary data with a connection. Be aware of not creating cyclic reference! =head2 yahc_conn_errors Return errors appeared in given connection. Note that the function returns all errors, not only ones happened during current attempt. Returned value is ArrayRef of ArrayRefs. Later one represents a error and contains following items: =over 4 error number (see YAHC::Error constants) error string ArrayRef of host, ip, port, scheme time when the error happened attempt when the error happened =back =head2 yahc_conn_register_error C adds new record in connection's error list. This functions is used internally for keeping track of all low-level errors during connection's lifetime. It can be also used by users for high-level errors such as 50x responses. The function takes C<$conn>, C<$error> which is one of C constants and error description. Error description can be passed in sprintf manner. For example: $yahc->request({ ... callback => sub { ... my $conn = $_[0]; my $status = $conn->{response}{status} || 0; if ($status == 503 || $status == 504) { yahc_conn_register_error( $conn, YAHC::Error::RESPONSE_ERROR(), "server returned %d", $status ); yahc_retry_conn($conn); return; } ... } }); =head2 yahc_conn_last_error Return last error appeared in connection. See C. =head2 yahc_terminal_error Given a error return 1 if the error has YAHC::Error::TERMINAL_ERROR() bit set. Otherwise return 0. =head2 yahc_conn_timeline Return timeline of given connection. See more about timeline in description of C method. =head2 yahc_conn_request Return request of given connection. See C. =head2 yahc_conn_response Return response of given connection. See C. =head2 yahc_conn_attempt Return current attempt starting from 1. The function can also return 0 if no attempts were made yet. =head2 yahc_conn_attempts_left Return number of attempts left. =head2 yahc_conn_socket_cache_id Return socket_cache id for given connection. Should be used to generate key for C. If connection is not initialized yet C is returned. =head1 ERRORS YAHC provides set of constants for errors. Each constant returns bitmask which can be used to detect presence of a particular error, for example, in C. There is one exception: YAHC::Error::NO_ERROR() return 0 indicating no error during request execution. Error handling code can look like following: $yahc->request({ ... callback => sub { my ( $conn, # connection 'object' $error, # one of YAHC::Error::* constants $strerror # string representation of error ) = @_; if ($error & YAHC::Error::TIMEOUT()) { # A timeout has happend. Use one of YAHC::Error::*_TIMEOUT() # constants for more clarification } elsif ($error & YAHC::Error::SSL_ERROR()) { # We had some issues with SSL. $error might have # YAHC::Error::READ_ERROR() or YAHC::Error::WRITE_ERROR() # indicating whether is was read or write error. } elsif (...) { # etc } } }); The list of error constants. The names are self-explanatory in many cases: =over 4 =item C Return value 0 (not a bitmask)> meaning no error =item C =item C =item C =item C =item C =item C The connection has exhausted all available retries. This error is usually returned to C. Check connection's errors via C to inspect the reasons of failures for each individual attempt. =item C =item C =item C =item C =item C not used =item C Server returned unparsable response =item C Usually represents exception in one of the callbacks =item C This bit is set when connection cannot be retried anymore and is forced to complete =item C =back =head1 REPOSITORY L =head1 NOTES =head2 UTF8 flag Note that YAHC has astonishing reduction in performance if any parameters participating in building HTTP message has UTF8 flag set. Those fields are C, C, C, C, C, C, C, C and maybe others. Just one example (check scripts/utf8_test.pl for code). Simple HTTP request with 10MB of payload: elapsed without utf8 flag: 0.039s elapsed with utf8 flag: 0.540s Because of this YAHC warns if detected UTF8-flagged payload. The user needs to make sure that *all* data passed to YAHC is unflagged binary strings. =head2 LIMITATIONS =over 4 =item * State 'RESOLVE DNS' is not implemented yet. =back =head1 AUTHORS Ivan Kruglov =head1 COPYRIGHT Copyright (c) 2013-2017 Ivan Kruglov C<< >>. =head1 ACKNOWLEDGMENT This module derived lots of ideas, code and docs from Hijk L. This module was originally developed for Booking.com. =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 libyahc-perl-0.035/scripts/000077500000000000000000000000001346453102500155665ustar00rootroot00000000000000libyahc-perl-0.035/scripts/utf8_test.pl000077500000000000000000000012651346453102500200570ustar00rootroot00000000000000#!/bin/env perl # nc -l -k 6000 > /dev/null use strict; use warnings; use YAHC; use Time::HiRes qw/time/; $SIG{PIPE} = 'IGNORE'; my ($yahc, $yahc_storage) = YAHC->new({ # debug => 1, # keep_timeline => 1, }); my $body = 'a' x (10 * 1024 * 1024); my $conn1 = $yahc->request({ host => '127.0.0.1:6000', body => $body, }); my $start = time; $yahc->run(YAHC::State::READING); printf "elapsed without utf8 flag: %.3fs\n", time - $start; $yahc->drop($conn1); utf8::upgrade($body); $yahc->request({ host => '127.0.0.1:6000', body => $body, }); $start = time; $yahc->run(YAHC::State::READING); printf "elapsed with utf8 flag: %.3fs\n", time - $start; exit 0; libyahc-perl-0.035/t/000077500000000000000000000000001346453102500143425ustar00rootroot00000000000000libyahc-perl-0.035/t/000_compile.t000066400000000000000000000001551346453102500165370ustar00rootroot00000000000000use strict; use Test::More tests => 1; BEGIN { use_ok 'YAHC' } diag "Perl/$^V"; diag "YAHC/$YAHC::VERSION"; libyahc-perl-0.035/t/005_circular_references_check.t000066400000000000000000000006111346453102500222530ustar00rootroot00000000000000#!/usr/bin/env perl use strict; use warnings; use YAHC; use Test::More; use Test::Memory::Cycle; my $conn; my ($yahc, $yahc_storage) = YAHC->new(); $yahc->request({ host => 'localhost', callback => sub { $yahc->request({ host => 'localhost' }); $conn->{state} = YAHC::State::INITIALIZED(); } }); memory_cycle_ok($yahc); memory_cycle_ok($conn); done_testing(); libyahc-perl-0.035/t/010_build_http_message.t000066400000000000000000000104451346453102500207550ustar00rootroot00000000000000#!/usr/bin/env perl use strict; use warnings; use Test::More; use YAHC; my $CRLF = "\x0d\x0a"; sub _build_conn_object { my $args = shift; my $host = delete $args->{host}; return { request => $args, selected_target => [ $host ], }; } for my $protocol ("HTTP/1.0", "HTTP/1.1") { is YAHC::_build_http_message(_build_conn_object({ protocol => $protocol, host => "www.example.com" })), "GET / $protocol${CRLF}". "Host: www.example.com${CRLF}". "${CRLF}"; is YAHC::_build_http_message(_build_conn_object({ protocol => $protocol, host => "example.com" })), "GET / $protocol${CRLF}". "Host: example.com${CRLF}". "${CRLF}"; is YAHC::_build_http_message(_build_conn_object({ method => "HEAD", protocol => $protocol, host => "example.com" })), "HEAD / $protocol${CRLF}". "Host: example.com${CRLF}". "${CRLF}"; is YAHC::_build_http_message(_build_conn_object({ protocol => $protocol, host => "www.example.com", port => "8080" })), "GET / $protocol${CRLF}". "Host: www.example.com${CRLF}". "${CRLF}"; is YAHC::_build_http_message(_build_conn_object({ protocol => $protocol, host => "www.example.com", query_string => "a=b" })), "GET /?a=b $protocol${CRLF}". "Host: www.example.com${CRLF}". "${CRLF}"; is YAHC::_build_http_message(_build_conn_object({ protocol => $protocol, host => "www.example.com", path => "/flower" })), "GET /flower $protocol${CRLF}". "Host: www.example.com${CRLF}". "${CRLF}"; is YAHC::_build_http_message(_build_conn_object({ 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 YAHC::_build_http_message(_build_conn_object({ protocol => $protocol, host => "www.example.com", body => "morning" })), "GET / $protocol${CRLF}". "Content-Length: 7${CRLF}". "Host: www.example.com${CRLF}". "${CRLF}". "morning"; is YAHC::_build_http_message(_build_conn_object({ protocol => $protocol, host => "www.example.com", body => "0" })), "GET / $protocol${CRLF}". "Content-Length: 1${CRLF}". "Host: www.example.com${CRLF}". "${CRLF}". "0"; is YAHC::_build_http_message(_build_conn_object({ protocol => $protocol, host => "www.example.com", body => undef })), "GET / $protocol${CRLF}". "Host: www.example.com${CRLF}". "${CRLF}"; is YAHC::_build_http_message(_build_conn_object({ protocol => $protocol, host => "www.example.com", body => "" })), "GET / $protocol${CRLF}". "Content-Length: 0${CRLF}". "Host: www.example.com${CRLF}". "${CRLF}"; is YAHC::_build_http_message(_build_conn_object({ protocol => $protocol, host => "www.example.com", head => undef, body => "OHAI" })), "GET / $protocol${CRLF}". "Content-Length: 4${CRLF}". "Host: www.example.com${CRLF}". "${CRLF}". "OHAI"; is YAHC::_build_http_message(_build_conn_object({ protocol => $protocol, host => "www.example.com", head => [], body => "OHAI" })), "GET / $protocol${CRLF}". "Content-Length: 4${CRLF}". "Host: www.example.com${CRLF}". "${CRLF}". "OHAI"; is YAHC::_build_http_message(_build_conn_object({ protocol => $protocol, host => "www.example.com", head => ["X-Head" => "extra stuff"] })), "GET / $protocol${CRLF}". "X-Head: extra stuff${CRLF}". "Host: www.example.com${CRLF}". "${CRLF}"; is YAHC::_build_http_message(_build_conn_object({ protocol => $protocol, host => "www.example.com", head => ["X-Head" => "extra stuff", "X-Hat" => "ditto"] })), "GET / $protocol${CRLF}". "X-Head: extra stuff${CRLF}". "X-Hat: ditto${CRLF}". "Host: www.example.com${CRLF}". "${CRLF}"; is YAHC::_build_http_message(_build_conn_object({ protocol => $protocol, host => "www.example.com", head => ["X-Head" => "extra stuff"], body => "OHAI" })), "GET / $protocol${CRLF}". "Content-Length: 4${CRLF}". "X-Head: extra stuff${CRLF}". "Host: www.example.com${CRLF}". "${CRLF}". "OHAI"; } done_testing; libyahc-perl-0.035/t/015_parse_http_headers.t000066400000000000000000000015561346453102500207670ustar00rootroot00000000000000#!/usr/bin/env perl use strict; use warnings; use Test::More; use YAHC; my $CRLF = "\x0d\x0a"; my @test_cases = ( [ join($CRLF, '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' ), { "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", }, ] ); is_deeply( YAHC::_parse_http_headers({}, $_->[0]), $_->[1]) foreach @test_cases; done_testing; libyahc-perl-0.035/t/016_chunked.t000066400000000000000000000033451346453102500165430ustar00rootroot00000000000000#!/usr/bin/env perl use strict; use warnings; use Test::More; use File::Temp (); use File::Temp qw/ :seekable /; use Data::Dumper; use YAHC; use EV; my ($yahc, $yahc_storage) = YAHC->new; my $conn = $yahc->request({ host => 'DUMMY', keep_timeline => 1, _test => 1, }); my $f = File::Temp->new(); my $fh= 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 $f $msg; $f->flush; $f->seek(0, 0); $f; }; $yahc->{watchers}{$conn->{id}} = { _fh => $fh, io => $yahc->loop->io($fh, EV::READ, sub {}) }; $conn->{state} = YAHC::State::CONNECTED(); $yahc->_set_read_state($conn->{id}); $yahc->run; ok($conn->{state} == YAHC::State::COMPLETED(), "check state") or diag("got:\n" . YAHC::_strstate($conn->{state}) . "\nexpected:\nSTATE_COMPLETED\ntimeline: " . Dumper($conn->{timeline})); my $response = $conn->{response}; is $response->{proto}, "HTTP/1.1"; is $response->{status}, 200; is $response->{body}, "Wikipedia in\r\n\r\nchunks."; is_deeply $response->{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" }; done_testing; libyahc-perl-0.035/t/017_content_length.t000066400000000000000000000104061346453102500201320ustar00rootroot00000000000000#!/usr/bin/env perl use strict; use warnings; use Test::More; use File::Temp (); use File::Temp qw/ :seekable /; use Data::Dumper; use YAHC qw/ yahc_conn_last_error /; use EV; my ($yahc, $yahc_storage) = YAHC->new; my $default_tests = sub { my ($conn, $t) = @_; my $response = $conn->{response}; is $response->{proto}, $t->{proto}, "$t->{name} - Protocol match"; is $response->{status}, $t->{status}, "$t->{name} - Status code"; is_deeply $response->{head}, $t->{headers}, "$t->{name} - Headers"; is $response->{body}, $t->{body}, "$t->{name} - Body/content"; }; my @TESTS = ( { name => "Simple request with content-length", proto => 'HTTP/1.1', status => '200', status_msg => 'OK', headers => { 'server' => 'mock', 'content-type' => 'text/plain', 'content-length' => '230', }, body => 'a' x 230, tests => $default_tests, }, { name => "Simple request with smaller content-length", proto => 'HTTP/1.1', status => '200', status_msg => 'OK', headers => { 'server' => 'mock', 'content-type' => 'text/plain', 'content-length' => '220', }, body => 'a' x 230, tests => sub { my ($conn, $t) = @_; my $response = $conn->{response}; is $response->{proto}, $t->{proto}, "$t->{name} - Protocol match"; is $response->{status}, $t->{status}, "$t->{name} - Status code"; is_deeply $response->{head}, $t->{headers}, "$t->{name} - Headers"; is $response->{body}, 'a' x 220, "$t->{name} - Body/content"; }, }, { name => "Simple request without content-length", proto => 'HTTP/1.1', status => '200', status_msg => 'OK', headers => { 'server' => 'mock', 'content-type' => 'text/plain', }, body => 'a' x 230, tests => $default_tests, }, { name => "Big request without content-length", proto => 'HTTP/1.1', status => '200', status_msg => 'OK', headers => { 'server' => 'mock', 'content-type' => 'text/plain', }, body => 'big' x 23000, tests => $default_tests, }, { name => "Request with a non-numeric content length", proto => 'HTTP/1.1', status => '200', status_msg => 'OK', headers => { 'server' => 'mock', 'content-type' => 'text/plain', 'content-length' => 'fourty-two', }, body => 'a' x 42, tests => sub { my ($conn, $t) = @_; my $response = $conn->{response}; is $response->{proto}, $t->{proto}, "$t->{name} - Protocol match"; is $response->{status}, $t->{status}, "$t->{name} - Status code"; is_deeply $response->{head}, $t->{headers}, "$t->{name} - Headers"; is $response->{body}, undef, "$t->{name} - Body/content (undef)"; my ($err, $msg) = yahc_conn_last_error($conn); cmp_ok($err & YAHC::Error::RESPONSE_ERROR(), '==', YAHC::Error::RESPONSE_ERROR(), "$t->{name} - We got response error"); }, }, ); foreach my $t (@TESTS) { my $conn = $yahc->request({ host => 'DUMMY', keep_timeline => 1, _test => 1, }); my $f = File::Temp->new(); my $fh= do { local $/ = undef; my $msg = join( "\x0d\x0a", join( " ", $t->{proto}, $t->{status}, $t->{status_msg} ), ( map "$_: $t->{headers}{$_}", keys %{ $t->{headers} } ), '', $t->{body} ); print $f $msg; $f->flush; $f->seek(0, 0); $f; }; $yahc->{watchers}{$conn->{id}} = { _fh => $fh, io => $yahc->loop->io($fh, EV::READ, sub {}) }; $conn->{state} = YAHC::State::CONNECTED(); $yahc->_set_read_state($conn->{id}); $yahc->run; ok($conn->{state} == YAHC::State::COMPLETED(), "$t->{name} - YAHC state == completed") or diag("got:\n" . YAHC::_strstate($conn->{state}) . "\nexpected:\nSTATE_COMPLETED\ntimeline: " . Dumper($conn->{timeline})); $t->{tests}->($conn, $t); } done_testing; libyahc-perl-0.035/t/023_state_connected.t000066400000000000000000000034571346453102500202660ustar00rootroot00000000000000#!/usr/bin/env perl use strict; use warnings; use Test::More; use Data::Dumper; use IO::Socket::INET; use YAHC; use EV; my $host = 'localhost', my $port = '5000'; my $message = 'TEST'; pipe(my $rh, my $wh) or die "failed to pipe: $!"; my $pid = fork; defined $pid or die "failed to fork: $!"; if ($pid == 0) { my $sock = IO::Socket::INET->new( Proto => 'tcp', LocalHost => '0.0.0.0', LocalPort => $port, ReuseAddr => 1, Blocking => 1, Listen => 1, ) or die "failed to create socket in child: $!"; local $SIG{ALRM} = sub { exit 0 }; alarm(20); # 20 sec of timeout close($wh); # signal parent process close($rh); my $client = $sock->accept or die "failed to accept connection in child: $!"; $client && $client->send($message); exit 0; } # wait for child process close($wh); sysread($rh, my $b = '', 1); close($rh); my ($yahc, $yahc_storage) = YAHC->new; my $conn = $yahc->request({ host => $host, port => $port, keep_timeline => 1, _test => 1, }); $yahc->_set_init_state($conn->{id}); $yahc->run(YAHC::State::CONNECTED(), $conn->{id}); ok($conn->{state} == YAHC::State::CONNECTED(), "check state") or diag("got:\n" . YAHC::_strstate($conn->{state}) . "\nexpected:\nSTATE_CONNECTED\ntimeline: " . Dumper($conn->{timeline})); my $fh = $yahc->{watchers}{$conn->{id}}{_fh}; ok(defined $fh, "socket is defined"); if (defined $fh) { my $buf = ''; while (1) { my $rlen = sysread($fh, $buf, length($message)); next if !defined($rlen) && ($! == POSIX::EAGAIN || $! == POSIX::EWOULDBLOCK || $! == POSIX::EINTR); last; } ok($buf eq $message, "received expected message") or diag("got:\n$buf\nexpected:\n$message"); } END { kill 'KILL', $pid if $pid } done_testing; libyahc-perl-0.035/t/024_state_write.t000066400000000000000000000021521346453102500174460ustar00rootroot00000000000000#!/usr/bin/env perl use strict; use warnings; use Test::More; use File::Temp (); use File::Temp qw/ :seekable /; use Data::Dumper; use YAHC; use EV; my $CRLF = "\x0d\x0a"; my ($yahc, $yahc_storage) = YAHC->new; my $conn = $yahc->request({ host => 'www.example.com', method => 'GET', head => [ 'User-Agent' => 'YAHC' ], keep_timeline => 1, _test => 1 }); my $fh = File::Temp->new(); $yahc->{watchers}{$conn->{id}} = { _fh => $fh, io => $yahc->loop->io($fh, EV::WRITE, sub {}) }; $conn->{state} = YAHC::State::CONNECTED(); $conn->{selected_target}[0] = 'www.example.com'; $yahc->_set_write_state($conn->{id}); $yahc->run(YAHC::State::READING(), $conn->{id}); ok($conn->{state} == YAHC::State::READING(), "check state") or diag("got:\n" . YAHC::_strstate($conn->{state}) . "\nexpected:\nSTATE_READING\ntimeline: " . Dumper($conn->{timeline})); $fh->flush; $fh->seek(0, 0); $fh->read(my $content, 1024); is $content, join($CRLF, 'GET / HTTP/1.1', 'User-Agent: YAHC', 'Host: www.example.com', '', ''); done_testing; libyahc-perl-0.035/t/025_state_read.t000066400000000000000000000030471346453102500172340ustar00rootroot00000000000000#!/usr/bin/env perl use strict; use warnings; use Test::More; use File::Temp (); use File::Temp qw/ :seekable /; use Data::Dumper; use YAHC; use EV; my ($yahc, $yahc_storage) = YAHC->new; my $conn = $yahc->request({ host => 'DUMMY', keep_timeline => 1, _test => 1, }); my $f = File::Temp->new(); my $fh = 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 $f $msg; $f->flush; $f->seek(0, 0); $f; }; $yahc->{watchers}{$conn->{id}} = { _fh => $fh, io => $yahc->loop->io($fh, EV::READ, sub {}) }; $conn->{state} = YAHC::State::CONNECTED(); $yahc->_set_read_state($conn->{id}); $yahc->run; ok($conn->{state} == YAHC::State::COMPLETED(), "check state") or diag("got:\n" . YAHC::_strstate($conn->{state}) . "\nexpected:\nSTATE_COMPLETED\ntimeline: " . Dumper($conn->{timeline})); my $response = $conn->{response}; is $response->{proto}, "HTTP/1.1"; is $response->{status}, 200; is $response->{body}, "OHAI"; is_deeply $response->{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; libyahc-perl-0.035/t/100_account_for_signal.t000066400000000000000000000015301346453102500207450ustar00rootroot00000000000000#!/usr/bin/env perl use strict; use warnings; use YAHC; use Test::More; use Time::HiRes qw/time/; my ($yahc, $yahc_storage) = YAHC->new({ account_for_signals => 1 }); my $alrm = 2; my $timeout = 3; my $timer_called = 0; $yahc->loop->now_update(); my $w = $yahc->loop->timer($timeout, 0, sub { $timer_called = 1; $yahc->break('break because of timeout'); }); my $sigalrm_called = 0; $SIG{ALRM} = sub { $sigalrm_called = 1; $yahc->break('break becuase of SIGALRM'); }; alarm($alrm); my $start = time; $yahc->run; my $elapsed = time - $start; ok($sigalrm_called == 1, 'SIGALRM handler has been called'); ok($timer_called == 0, 'timer handler has not been called'); cmp_ok($elapsed, '>=', $alrm, "SIGALRM was called at >= $alrm seconds"); cmp_ok($elapsed, '<', $timeout, "SIGALRM was called at < $timeout seconds"); done_testing; libyahc-perl-0.035/t/110_attempt.t000066400000000000000000000022321346453102500165650ustar00rootroot00000000000000#!/usr/bin/env perl use strict; use warnings; use YAHC qw/yahc_conn_attempt yahc_conn_attempts_left/; use Test::More; my ($yahc, $yahc_storage) = YAHC->new; # here we tell YAHC to do do accual work, that's why we should get 11 attempts my $c = $yahc->request({ host => "localhost:1000", retries => 10, _test => 1 }); cmp_ok(yahc_conn_attempts_left($c), "==", 11, "got expected amount of attempts left"); cmp_ok(yahc_conn_attempt($c), "==", 0, "got expected attempt"); # here we tell YAHC to work as usual, so it does first attempt immideatly my $c1 = $yahc->request({ host => [ "localhost:1000" ], retries => 10, callback => sub { cmp_ok(yahc_conn_attempt($_[0]), "==", 11, "got expected attempt in callback"); cmp_ok(yahc_conn_attempts_left($_[0]), "==", 0, "got 0 attempts left in callback") } }); cmp_ok(yahc_conn_attempt($c1), "==", 1, "got expected attempt"); cmp_ok(yahc_conn_attempts_left($c1), "==", 10, "got expected amount of attempts left"); $yahc->run; cmp_ok(yahc_conn_attempt($c1), "==", 11, "got expected attempt in the end"); cmp_ok(yahc_conn_attempts_left($c1), "==", 0, "got 0 attempts left in the end"); done_testing; libyahc-perl-0.035/t/120_selected_target.t000066400000000000000000000015071346453102500202520ustar00rootroot00000000000000#!/usr/bin/env perl use strict; use warnings; use Test::More; use YAHC qw/yahc_conn_target/; my ($yahc, $yahc_storage) = YAHC->new({ host => [ '127.0.0.1', '127.0.0.2' ] }); my $conn = $yahc->request({ path => '/', _test => 1 }); YAHC::_get_next_target($conn); ok(yahc_conn_target($conn) eq '127.0.0.1', 'target is 127.0.0.1'); YAHC::_get_next_target($conn); ok(yahc_conn_target($conn) eq '127.0.0.2', 'target is 127.0.0.2'); $conn = $yahc->request({ host => '127.0.0.3', path => '/', _test => 1 }); YAHC::_get_next_target($conn); ok(yahc_conn_target($conn) eq '127.0.0.3', 'target is 127.0.0.3'); ($yahc, $yahc_storage) = YAHC->new({ host => sub { '127.0.0.4' } }); $conn = $yahc->request({ path => '/', _test => 1 }); YAHC::_get_next_target($conn); ok(yahc_conn_target($conn) eq '127.0.0.4', 'target is 127.0.0.4'); done_testing; libyahc-perl-0.035/t/130_yahc_functions.t000066400000000000000000000022661346453102500201340ustar00rootroot00000000000000#!/usr/bin/env perl use strict; use warnings; use Test::More; use YAHC; subtest "yahc_terminal_error" => sub { cmp_ok(YAHC::yahc_terminal_error(0), '==', 0, '0 value is not terminal error'); cmp_ok( YAHC::yahc_terminal_error( YAHC::Error::INTERNAL_ERROR() ), '==', 0, 'YAHC::Error::INTERNAL_ERROR() is not terminal error' ); cmp_ok( YAHC::yahc_terminal_error( YAHC::Error::TERMINAL_ERROR() ), '==', 1, 'YAHC::Error::TERMINAL_ERROR() is terminal error' ); cmp_ok( YAHC::yahc_terminal_error( YAHC::Error::TERMINAL_ERROR() | YAHC::Error::TERMINAL_ERROR() ), '==', 1, 'YAHC::Error::TERMINAL_ERROR() | YAHC::Error::TERMINAL_ERROR() is terminal error' ); }; subtest "yahc_conn_user_data" => sub { my $conn = {}; is(YAHC::yahc_conn_user_data($conn), undef, 'user_data is undef at start'); is(YAHC::yahc_conn_user_data($conn, 'test'), 'test', 'user_data contains "test"'); YAHC::yahc_conn_user_data($conn, undef); is(YAHC::yahc_conn_user_data($conn), undef, 'user_data contains undef'); }; done_testing; libyahc-perl-0.035/t/140_yahc_loop.t000066400000000000000000000011101346453102500170610ustar00rootroot00000000000000#!/usr/bin/env perl use strict; use warnings; use EV; use YAHC; use Test::More; use Time::HiRes qw/time/; use Scalar::Util qw/weaken/; my $loop = EV::default_loop(); my ($yahc, $yahc_storage) = YAHC->new({ loop => $loop }); my $called = 0; my $weakloop = $loop; weaken($weakloop); my $c1 = $yahc->request({ host => [ "localhost:1000" ], callback => sub { $called++; $weakloop->break; }, }); my $iterations = 0; $loop->run(EV::RUN_ONCE) until $called || $iterations++ > 1000; is($called, 1, "Running the default eventloop ran YAHC"); done_testing; libyahc-perl-0.035/t/200_live_google.t000066400000000000000000000030011346453102500173750ustar00rootroot00000000000000#!/usr/bin/env perl use strict; use warnings; use Test::More; use Test::Exception; use YAHC qw/yahc_conn_last_error yahc_conn_errors/; 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 "with 10 microseconds timeout limit, expect an exception." => sub { lives_ok { my ($yahc, $yahc_storage) = YAHC->new(); my $c= $yahc->request({ %args, connect_timeout => 0.00001 }); $yahc->run; ok yahc_conn_last_error($c); my @found_error = grep { $_->[0] & YAHC::Error::CONNECT_TIMEOUT() } @{ yahc_conn_errors($c) || [] }; ok @found_error > 0; }; }; subtest "with 10s timeout limit, do not expect an exception." => sub { lives_ok { my ($yahc, $yahc_storage) = YAHC->new(); my $c = $yahc->request({ %args, connect_timeout => 10 }); $yahc->run; ok !yahc_conn_last_error($c); ok $c->{response}{body}; } 'google.com send back something within 10s'; }; subtest "without timeout, do not expect an exception." => sub { lives_ok { my ($yahc, $yahc_storage) = YAHC->new(); my $c = $yahc->request({ %args }); $yahc->run; ok !yahc_conn_last_error($c); } 'google.com send back something without timeout'; }; done_testing(); libyahc-perl-0.035/t/210_live_timeout_connected.t000066400000000000000000000032261346453102500216430ustar00rootroot00000000000000#!/usr/bin/env perl use strict; use warnings; use YAHC qw/yahc_conn_errors/; use Net::Ping; use Test::More; use Data::Dumper; use Time::HiRes qw/time/; unless ($ENV{TEST_LIVE}) { plan skip_all => "Enable live testing by setting env: TEST_LIVE=1"; } my @errors; my @elapsed; my $generated = 0; my $timeout = 0.5; for my $attempt (1..10) { # 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)); next if $iter == 0; $generated = 1; pass "attempt $attempt ip generated = $ip"; local $SIG{ALRM} = sub { BAIL_OUT('ALARM') }; alarm(10); # 10 sec of timeout my ($yahc, $yahc_storage) = YAHC->new({ account_for_signals => 1 }); my $start = time; my $conn = $yahc->request({ host => $ip, connect_timeout => $timeout, }); $yahc->run(YAHC::State::CONNECTED); my $elps = time - $start; push @elapsed, $elps; pass("attempt $attempt elapsed " . sprintf("%.3fs", $elps)); push @errors, grep { $_->[0] & YAHC::Error::CONNECT_TIMEOUT() } @{ yahc_conn_errors($conn) || [] }; last if @errors; } plan skip_all => "Cannot randomly generate an unreachable IP." unless $generated; ok($_ <= $timeout * 2, "elapsed is roughly same as timeout") for @elapsed; ok(@errors > 0, < "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 ($yahc, $yahc_storage) = YAHC->new(); subtest "sequential requests" => sub { for my $i (1..100) { lives_ok { my $c = $yahc->request({ host => 'u.nix.is', port => 80, request_timeout => 3, path => "/?YAHC_test_nr=$i", head => [ "X-Request-Nr" => $i, "Referer" => "YAHC (file:" . __FILE__ . "; iteration: $i)", ], }); $yahc->run; ok !yahc_conn_last_error($c), 'yahc_conn_last_error($conn) return undef, because we do not expect connect timeout to happen'; cmp_ok($c->{response}{status}, '==', 200, "We got a 200 OK response"); cmp_ok(yahc_conn_state($c), '==', YAHC::State::COMPLETED(), "We got COMPLETED state"); } "We could make request number $i"; } }; subtest "parallel requests" => sub { for my $attempt (1..10) { lives_ok { my @cs; for my $i (1..10) { push @cs, $yahc->request({ host => 'u.nix.is', port => 80, request_timeout => 3, path => "/?YAHC_test_nr=$i", head => [ "X-Request-Nr" => $i, "Referer" => "YAHC (file:" . __FILE__ . "; iteration: $i)", ], }); } $yahc->run; foreach my $c (@cs) { ok !yahc_conn_last_error($c), 'yahc_conn_last_error($conn) return undef, because we do not expect connect timeout to happen'; cmp_ok($c->{response}{status}, '==', 200, "We got a 200 OK response"); cmp_ok(yahc_conn_state($c), '==', YAHC::State::COMPLETED(), "We got COMPLETED state"); } } "We could make attempt #$attempt"; } }; done_testing(); libyahc-perl-0.035/t/230_live_requests.t000066400000000000000000000253331346453102500200130ustar00rootroot00000000000000#!/usr/bin/env perl use strict; use warnings; use YAHC qw/ yahc_conn_state yahc_retry_conn yahc_reinit_conn yahc_conn_errors yahc_conn_attempt yahc_conn_last_error yahc_conn_attempts_left /; use FindBin; use Test::More; use Data::Dumper; use Time::HiRes qw/time sleep/; use lib "$FindBin::Bin/.."; use t::Utils; unless ($ENV{TEST_LIVE}) { plan skip_all => "Enable live testing by setting env: TEST_LIVE=1"; } my (undef, $host, $port) = t::Utils::_start_plack_server_on_random_port(); my (undef, $ch_host, $ch_port) = t::Utils::_start_plack_server_on_random_port({ chunked => 1 }); my ($yahc, $yahc_storage) = YAHC->new; for my $len (0, 1, 2, 8, 23, 345, 1024, 65535, 131072, 9812, 19874, 1473451, 10000000) { my $body = t::Utils::_generate_sequence($len); subtest "content_length_$len" => sub { my $c = $yahc->request({ host => $host, port => $port, path => '/record', body => $body, head => [ 'Content-Type' => 'raw' ] }); $yahc->run; cmp_ok($c->{response}{body}, 'eq', $body, "We got expected body"); cmp_ok($c->{response}{head}{'content-length'}, '==', $len, "We got expected content-length"); cmp_ok($c->{response}{head}{'content-type'}, 'eq', 'raw', "We got expected content-type"); }; subtest "chunked_content_length_$len" => sub { my $c = $yahc->request({ host => $ch_host, port => $ch_port, path => '/record', body => $body, head => [ 'Content-Type' => 'raw' ] }); $yahc->run; cmp_ok($c->{response}{body}, 'eq', $body, "We got expected body"); cmp_ok($c->{response}{head}{'content-type'}, 'eq', 'raw', "We got expected content-type"); }; } subtest "callbacks" => sub { my $init_callback; my $connecting_callback; my $connected_callback; my $writing_callback; my $reading_callback; my $callback; my $c = $yahc->request({ host => $host, port => $port, retries => 5, request_timeout => 1, init_callback => sub { $init_callback = 1 }, connecting_callback => sub { $connecting_callback = 1 }, connected_callback => sub { $connected_callback = 1 }, writing_callback => sub { $writing_callback = 1 }, reading_callback => sub { $reading_callback = 1 }, callback => sub { $callback = 1 }, }); $yahc->run; ok !yahc_conn_last_error($c), "no errors"; if (yahc_conn_last_error($c)) { diag Dumper(yahc_conn_errors($c)); } ok $init_callback, "init_callback is called"; ok $connecting_callback, "connecting_callback is called"; ok $connected_callback, "connected_callback is called"; ok $writing_callback, "writing_callback is called"; ok $reading_callback, "reading_callback is called"; ok $callback, "callback is called"; }; subtest "connect_timeout" => sub { my $c = $yahc->request({ host => $host, port => $port, connect_timeout => 0.1, connecting_callback => sub { sleep 0.2 }, }); $yahc->run; my $has_timeout = grep { $_->[0] & YAHC::Error::CONNECT_TIMEOUT() } @{ yahc_conn_errors($c) || []}; is($has_timeout, 1, "We got YAHC::Error::CONNECT_TIMEOUT()"); cmp_ok($c->{response}{status}, '!=', 200, "We didn't get a 200 OK response"); }; subtest "drain_timeout" => sub { my $c = $yahc->request({ host => $host, port => $port, drain_timeout => 0.1, writing_callback => sub { sleep 0.2 }, }); $yahc->run; my $has_timeout = grep { $_->[0] & YAHC::Error::DRAIN_TIMEOUT() } @{ yahc_conn_errors($c) || []}; is($has_timeout, 1, "We got YAHC::Error::DRAIN_TIMEOUT()"); cmp_ok($c->{response}{status}, '!=', 200, "We didn't get a 200 OK response"); }; subtest "request_timeout" => sub { my $c = $yahc->request({ host => $host, port => $port, request_timeout => 0.1, reading_callback => sub { sleep 0.2 }, }); $yahc->run; my $has_timeout = grep { $_->[0] & YAHC::Error::REQUEST_TIMEOUT() } @{ yahc_conn_errors($c) || [] }; is($has_timeout, 1, "We got YAHC::Error::REQUEST_TIMEOUT()"); cmp_ok($c->{response}{status}, '!=', 200, "We didn't get a 200 OK response"); }; subtest "lifetime_timeout" => sub { my $c = $yahc->request({ host => $host, port => $port, lifetime_timeout => 0.1, writing_callback => sub { sleep 0.2 }, }); $yahc->run; my $has_timeout = grep { $_->[0] & YAHC::Error::LIFETIME_TIMEOUT() } @{ yahc_conn_errors($c) || [] }; is($has_timeout, 1, "We got YAHC::Error::LIFETIME_TIMEOUT()"); cmp_ok($c->{response}{status}, '!=', 200, "We didn't get a 200 OK response"); }; subtest "retry due to DNS error and connection error" => sub { my $rnd_port = t::Utils::_generaete_random_port(); my $c = $yahc->request({ host => [ $host . "_non_existent:$port", $host . "_non_existent:$port", "127.0.0.1:$rnd_port", "127.0.0.1:$rnd_port", "$host:$port" ], retries => 4, }); $yahc->run; cmp_ok($c->{response}{status}, '==', 200, "We got a 200 OK response"); cmp_ok(yahc_conn_state($c), '==', YAHC::State::COMPLETED(), "We got COMPLETED state"); cmp_ok(yahc_conn_attempt($c), '==', 5, "We did 5 attempts"); }; subtest "retry two connections due to DNS error" => sub { my $c1 = $yahc->request({ host => [ $host . "_non_existent", $host . "_non_existent", $host ], port => $port, retries => 2, }); my $c2 = $yahc->request({ host => [ $host . "_non_existent", $host ], port => $port, retries => 1, }); $yahc->run; cmp_ok($c1->{response}{status}, '==', 200, "first request got a 200 OK response"); cmp_ok(yahc_conn_state($c1), '==', YAHC::State::COMPLETED(), "first request got COMPLETED state"); cmp_ok(yahc_conn_attempt($c1), '==', 3, "first request did 3 attempts"); cmp_ok($c2->{response}{status}, '==', 200, "second request got a 200 OK response"); cmp_ok(yahc_conn_state($c2), '==', YAHC::State::COMPLETED(), "second request got COMPLETED state"); cmp_ok(yahc_conn_attempt($c2), '==', 2, "second request did 2 attempts"); }; subtest "retry with backoff delay" => sub { my $c = $yahc->request({ host => [ $host . "_non_existent", $host . "_non_existent_1", $host ], port => $port, retries => 2, backoff_delay => 2, request_timeout => 1, }); my $start = time; $yahc->run; my $elapsed = time - $start; cmp_ok($c->{response}{status}, '==', 200, "We got a 200 OK response"); cmp_ok(yahc_conn_state($c), '==', YAHC::State::COMPLETED(), "We got COMPLETED state"); cmp_ok($elapsed, '>=', 4, "elapsed is greater than backoff_delay * retries") }; subtest "manual retry with backoff delay" => sub { my $c = $yahc->request({ host => [ $host, $host ], port => $port, retries => 1, request_timeout => 1, callback => sub { my ($conn, $err) = @_; yahc_retry_conn($conn, { backoff_delay => 2 }) if yahc_conn_attempts_left($conn) > 0; } }); my $start = time; $yahc->run; my $elapsed = time - $start; cmp_ok($c->{response}{status}, '==', 200, "We got a 200 OK response"); cmp_ok(yahc_conn_state($c), '==', YAHC::State::COMPLETED(), "We got COMPLETED state"); cmp_ok(yahc_conn_attempt($c), '==', 2, "request did two attempts"); cmp_ok($elapsed, '>=', 2, "elapsed is greater than 2 seconds") }; subtest "retry with backoff delay due to timeout" => sub { my $start = time; my $c = $yahc->request({ host => [ $host, $host . '_non_existent', $host ], port => $port, retries => 2, backoff_delay => 4, connect_timeout => 0.5, connecting_callback => sub { sleep 1 if yahc_conn_attempt($_[0]) <= 1; # fail 1st and and 2nd attempts }, }); $yahc->run; my $elapsed = time - $start; cmp_ok($c->{response}{status}, '==', 200, "We got a 200 OK response"); cmp_ok(yahc_conn_state($c), '==', YAHC::State::COMPLETED(), "We got COMPLETED state"); cmp_ok($elapsed, '>=', 4, "elapsed is greater than backoff_delay"); my @errors = @{ yahc_conn_errors($c) || [] }; ok(@errors == 2, "We got two errors"); if (@errors == 2) { ok($errors[0][0] & YAHC::Error::CONNECT_TIMEOUT(), "First error is CONNECT_TIMEOUT"); ok($errors[1][0] & YAHC::Error::CONNECT_ERROR(), "Second error is CONNECT_ERROR"); } }; subtest "retry with backoff delay and lifetime timeout" => sub { my $c = $yahc->request({ host => [ $host . "_non_existent", $host . "_non_existent_1", $host ], port => $port, retries => 2, backoff_delay => 1, request_timeout => 1, lifetime_timeout => 4, }); my $start = time; $yahc->run; my $elapsed = time - $start; cmp_ok(int($elapsed), '<=', 4, "elapsed is smaller than lifetime"); cmp_ok($c->{response}{status}, '==', 200, "We didn't get 200 OK response"); cmp_ok(yahc_conn_state($c), '==', YAHC::State::COMPLETED(), "We got COMPLETED state"); }; subtest "retry with backoff delay and lifetime timeout triggering lifetime timeout" => sub { my $c = $yahc->request({ host => [ $host . "_non_existent", $host . "_non_existent_1", $host ], port => $port, retries => 2, backoff_delay => 2, request_timeout => 1, lifetime_timeout => 4, }); my $start = time; $yahc->run; my $elapsed = time - $start; my ($err) = yahc_conn_last_error($c); cmp_ok($err & YAHC::Error::LIFETIME_TIMEOUT(), '==', YAHC::Error::LIFETIME_TIMEOUT(), "We got lifetime timeout"); cmp_ok(int($elapsed), '<=', 4, "elapsed is smaller than lifetime"); cmp_ok($c->{response}{status}, '!=', 200, "We didn't get 200 OK response"); cmp_ok(yahc_conn_state($c), '==', YAHC::State::COMPLETED(), "We got COMPLETED state"); }; subtest "reinitiaize connection" => sub { my $first_attempt = 1; my $c = $yahc->request({ host => $host . "_non_existent", port => $port, request_timeout => 1, callback => sub { my ($conn, $err) = @_; yahc_reinit_conn($conn, { host => $host }) if $err && $first_attempt; $first_attempt = 0; }, }); $yahc->run; ok !$first_attempt; cmp_ok($c->{response}{status}, '==', 200, "We got a 200 OK response"); cmp_ok(yahc_conn_state($c), '==', YAHC::State::COMPLETED(), "We got COMPLETED state"); }; END { kill 'KILL', $_ foreach keys %{ t::Utils::_pids() } } done_testing; libyahc-perl-0.035/t/240_live_socket_cache.t000066400000000000000000000050241346453102500205470ustar00rootroot00000000000000#!/usr/bin/env perl use strict; use warnings; use YAHC qw/ yahc_conn_state yahc_retry_conn yahc_reinit_conn yahc_conn_errors yahc_conn_attempt yahc_conn_last_error yahc_conn_attempts_left /; use FindBin; use Test::More; use Data::Dumper; use Time::HiRes qw/time sleep/; use lib "$FindBin::Bin/.."; use t::Utils; unless ($ENV{TEST_LIVE}) { plan skip_all => "Enable live testing by setting env: TEST_LIVE=1"; } my (undef, $host, $port) = t::Utils::_start_plack_server_on_random_port({ keep_alive => 1, server => 'Starman', # for HTTP/1.1 }); subtest "no cache" => sub { my %socket_cache; my ($yahc, $yahc_storage) = YAHC->new(); my $c1 = $yahc->request({ host => $host, port => $port, }); $yahc->run; ok !yahc_conn_last_error($c1), 'We expect no errors'; cmp_ok($c1->{response}{status}, '==', 200, "We got 200 OK response"); cmp_ok(keys %socket_cache, '==', 0, "No caching unless set"); }; subtest "request with socket cache" => sub { my %socket_cache; my ($yahc, $yahc_storage) = YAHC->new({ socket_cache => \%socket_cache }); my $c1 = $yahc->request({ host => $host, port => $port, }); $yahc->run; ok !yahc_conn_last_error($c1), 'We expect no errors'; cmp_ok($c1->{response}{status}, '==', 200, "We got 200 OK response"); cmp_ok(keys %socket_cache, '==', 1, "We got one entry in socket cache"); }; subtest "reuse connection from socket cache" => sub { my %socket_cache; my ($yahc, $yahc_storage) = YAHC->new({ socket_cache => \%socket_cache }); my $num_of_connections = 0; my $c1 = $yahc->request({ host => $host, port => $port, connected_callback => sub { $num_of_connections++ }, }); $yahc->run; ok !yahc_conn_last_error($c1), 'We expect no errors'; cmp_ok($c1->{response}{status}, '==', 200, "We got 200 OK response"); cmp_ok(keys %socket_cache, '==', 1, "We got one entry in socket cache"); my $c2 = $yahc->request({ host => $host, port => $port, connected_callback => sub { $num_of_connections++ }, }); $yahc->run; ok !yahc_conn_last_error($c2), 'We expect no errors'; cmp_ok($c2->{response}{status}, '==', 200, "We got 200 OK response"); cmp_ok(keys %socket_cache, '==', 1, "We got one entry in socket cache"); cmp_ok $num_of_connections, '==', 1, "Also connection_callback should be called only once"; }; END { kill 'INT', $_ foreach keys %{ t::Utils::_pids() } } done_testing; libyahc-perl-0.035/t/300_robust.t000066400000000000000000000164701346453102500164370ustar00rootroot00000000000000#!/usr/bin/env perl use strict; use warnings; use YAHC; use POSIX; use FindBin; use HTTP::Tiny; use Test::More; use Data::Dumper; use JSON qw/decode_json/; use Time::HiRes qw/time sleep nanosleep/; use List::Util qw/shuffle/; use lib "$FindBin::Bin/.."; use t::Utils; unless ($ENV{TEST_ROBUST}) { plan skip_all => "Enable robust testing by setting env: TEST_ROBUST=1"; } unless (YAHC::SSL) { plan skip_all => 'IO::Socket::SSL 1.94+ required for this test!' } unless (t::Utils::_check_toxyproxy_and_reset()) { plan skip_all => 'Toxyproxy is not responsive, use $ENV{TOXYPROXY} to specify its address'; } my $len = 50; my $nrequests = 16; note("generating $nrequests requests structures"); my @requests = map { $len *= 2; { path => '/record', body => t::Utils::_generate_sequence(int($len / 2) + int(rand($len))), ssl_options => { SSL_cert_file => t::Utils::SSL_CRT, SSL_key_file => t::Utils::SSL_KEY, SSL_verify_mode => 0, # SSL_VERIFY_NONE }, } } (1..$nrequests); # [ $latency_ms, jitter_ms ] # final latency = $latency +- rand($jitter) my @latencies = ([10, 5], [50, 20], [100, 50], [500, 250]); push @latencies, ([1000, 500], [10000, 5000]) if $ENV{TEST_ROBUST_LONG}; foreach my $proto ('http', 'https') { my $ssl = $proto eq 'https' ? 1 : 0; my ($spid, $chost, $cport) = t::Utils::_start_plack_server_on_random_port({ ssl => $ssl }); my $caddr = "${chost}:${cport}"; foreach my $settings (@latencies) { my ($latency, $jitter) = @{ $settings }; subtest "robustness of $proto in case of latency $latency ms" => sub { my $addr = t::Utils::new_toxic( "yahc_robust_${proto}_latency_${latency}_jitter_${jitter}", $caddr, { type => 'latency', attributes => { latency => int($latency), jitter => int($jitter), }, }, ); _do_requests_and_verify($addr, $ssl, @requests); } } note("killing web server $spid"); delete t::Utils::_pids->{$spid}; kill 'KILL', $spid; } # rate in kilobytes per second my @rates = (100000, 10000, 1000); push @rates, 100 if $ENV{TEST_ROBUST_LONG}; foreach my $proto ('http', 'https') { my $ssl = $proto eq 'https' ? 1 : 0; my ($spid, $chost, $cport) = t::Utils::_start_plack_server_on_random_port({ ssl => $ssl }); my $caddr = "${chost}:${cport}"; foreach my $rate (@rates) { subtest "robustness of $proto in case of $rate kilobytes per second bandwidth" => sub { my $addr = t::Utils::new_toxic( "yahc_robust_${proto}_bandwidth_${rate}", $caddr, { type => 'bandwidth', attributes => { rate => int($rate) }, }, ); _do_requests_and_verify($addr, $ssl, @requests); } } note("killing web server $spid"); delete t::Utils::_pids->{$spid}; kill 'KILL', $spid; } my @signal_requests = shuffle (@requests, @requests, @requests, @requests, @requests, @requests, @requests, @requests, @requests); my $nsignal_requests = scalar @signal_requests; foreach my $proto ('http', 'https') { my $ssl = $proto eq 'https' ? 1 : 0; my ($spid, $chost, $cport) = t::Utils::_start_plack_server_on_random_port({ ssl => $ssl }); my $caddr = "${chost}:${cport}"; subtest "robustness of $proto in case of storm of signals" => sub { pipe(my $rh, my $wh) or die "failed to pipe: $!"; my $ht = t::Utils::_get_http_tiny(); ok($ht->get("$proto://$caddr/reset")->{success}, "reset server counters") or return; my $pid = t::Utils::_fork(sub { my $sigcnt = 0; local $SIG{HUP} = 'IGNORE'; local $SIG{USR1} = sub { $sigcnt++ }; local $SIG{USR2} = sub { $sigcnt++ }; my ($yahc, $yahc_storage) = YAHC->new({ account_for_signals => 1 }); syswrite($wh, '1', 1); close($wh); # signal parent process close($rh); note("$$ client process start sending requests to $proto://$caddr"); foreach my $request (@signal_requests) { my $c = $yahc->request({ host => $caddr, scheme => $proto, query_string => "sigcnt=$sigcnt", %{ $request } }); $yahc->run; die "we didn't get 200\n" unless ($c->{response}{status} || 0) == 200; die "body didn't match\n" unless ($c->{response}{body} || '') eq $request->{body}; } note("$$ client process is done"); }); note("waiting for client to be ready"); sysread($rh, my $b = '', 1); close($wh); close($rh); my $exit_code = 1024; my @signals = ('HUP', 'USR1', 'USR2', 'USR1', 'USR2' ); note("start spaming client with signals " . join(',', @signals)); my $t0 = time; while ($t0 + 10 >= time) { for (my $t1 = time; $t1 + 0.1 >= time;) { my $sig = $signals[int(rand(scalar @signals))]; # note("send $sig to $pid"); kill $sig, $pid; nanosleep 100000; # 100 microseconds } if (waitpid($pid, WNOHANG) != 0) { $exit_code = ($? >> 8); last; } } cmp_ok($exit_code, '==', 0, "client process exited with success") or return; note("analizing report"); my $resp = $ht->get("$proto://$caddr/report"); my @report = @{ decode_json($resp->{content} || '{}') }; cmp_ok(scalar @report, '==', $nsignal_requests , "got $nsignal_requests reports"); my $total_sigcnt = 0; my @report_body_lengths; my @body_length = map { length $_->{body} } @signal_requests; my $i = 1; foreach my $r (@report) { my $len = $r->{body_length} || 0; push @report_body_lengths, $len; my (undef, $sigcnt) = split(/=/, $r->{query_string} || ''); $sigcnt ||= 0; note("client received $sigcnt signals during #$i request of $len bytes"); $total_sigcnt += $sigcnt; $i++; } cmp_ok($total_sigcnt, '>', 0, "client process received signals"); is_deeply(\@report_body_lengths, \@body_length, "bodies' length match"); }; note("killing web server $spid"); delete t::Utils::_pids->{$spid}; kill 'KILL', $spid; } sub _do_requests_and_verify { my ($addr, $ssl, @requests) = @_; my ($yahc, $yahc_storage) = YAHC->new; foreach my $request (@requests) { note(sprintf("request with body of %s bytes", length($request->{body}))); my $c = $yahc->request({ host => $addr, scheme => $ssl ? 'https' : 'http', %{ $request } }); $yahc->run; cmp_ok($c->{response}{status}, '==', 200, "We got 200 OK response"); ok($c->{response}{body} eq $request->{body}, "Bodies match"); } } END { kill 'KILL', $_ foreach keys %{ t::Utils::_pids() }; } done_testing; libyahc-perl-0.035/t/Utils.pm000066400000000000000000000130271346453102500160030ustar00rootroot00000000000000package t::Utils; use POSIX; use Test::More; use HTTP::Tiny; use Data::Dumper; use JSON qw/encode_json/; use Time::HiRes qw/time sleep/; use Plack::Middleware::Chunked; use constant { SSL_CRT => 't/cert/server.crt', SSL_KEY => 't/cert/server.key', }; my $chars = 'qwertyuiop[]asdfghjkl;\'zxcvbnm,./QWERTYUIOP{}":LKJHGFDSAZXCVBNM<>?1234567890-=+_)(*&^%$#@!\\ ' . "\n\t\r"; sub _generate_sequence { my $len = shift; my $lc = length($chars); my $out = ''; while ($len-- > 0) { $out .= substr($chars, rand($lc), 1); } return $out; } my %PIDS; sub _pids { return \%PIDS; } sub _fork { my ($cb, $lifetime) = @_; $lifetime ||= 60; my $pid = fork; defined $pid or die "failed to fork: $!"; if ($pid != 0) { # return in parent $PIDS{$pid} = 1; return $pid; } local $SIG{ALRM} = sub { POSIX::_exit(1) }; alarm($lifetime); # 60 sec of timeout eval { $cb->(); 1; } or do { warn "$@\n"; POSIX::_exit(1); # avoid running END block }; POSIX::_exit(0); # avoid running END block } sub _generaete_random_port { return 10000 + int(rand(2000)); } sub _start_plack_server_on_random_port { my $opts = shift; my $port = _generaete_random_port(); # I pass 127.0.0.1 to all server instances to make sure that we use IPv4 stack. # I still want to use "localhost" to test DNS lookup for clients return _start_plack_server({ host => '127.0.0.1', port => $port, %{ $opts || {} } }), "localhost", $port; } sub _start_plack_server { my $args = shift; my $host = $args->{host}; my $port = $args->{port}; my $ssl = $args->{ssl}; my $chunked = $args->{chunked}; my $keep_alive = $args->{keep_alive}; my $server = $args->{server}; my $pid = _fork(sub { note(sprintf("starting plack server %s", Dumper($args))); require Plack::Runner; my $runner = Plack::Runner->new(defined $server ? (server => $server) : ()); my @opts = ("--host", $host, "--port", $port, "--no-default-middleware", "--max-requests", 1000000, "--workers", 1); push @opts, ("--enable-ssl", '--ssl-key-file', SSL_KEY, '--ssl-cert-file', SSL_CRT) if $ssl; push @opts, ("--keepalive-timeout", 300) if $keep_alive; $runner->parse_options(@opts); my @stats; my $app = sub { my $req = shift; my $path = $req->{PATH_INFO}; if ($path eq '/') { return [200, [], []]; } elsif ($path eq '/ping' ) { return [200, [], ['pong']]; } elsif ($path eq '/reset') { @stats = (); return [200, [], []]; } elsif ($path eq '/report') { return [200, [], [ encode_json(\@stats) ]]; } elsif ($path eq '/record') { my $body = ''; read($req->{'psgi.input'}, $body, $req->{CONTENT_LENGTH} || 0); push @stats, { query_string => $req->{QUERY_STRING}, body_length => length($body), time => time, }; return [200, [ 'Content-Type' => $req->{CONTENT_TYPE} || '' ], [$body]]; } else { die "invalid request $path\n"; } }; $app = Plack::Middleware::Chunked->wrap($app) if $chunked; $runner->run($app); }, 300); note("waiting for plack to be up"); my $ht = _get_http_tiny(); my $scheme = $ssl ? "https" : "http"; foreach (1..50) { last if $ht->get("$scheme://$host:$port/ping")->{success}; sleep(0.1); } $ht->get("$scheme://$host:$port/ping")->{success} or die "plack is not up"; note("plack is up"); return $pid; } sub _get_http_tiny { return HTTP::Tiny->new(SSL_options => { SSL_cert_file => SSL_CRT, SSL_key_file => SSL_KEY, SSL_verify_mode => 0, # SSL_VERIFY_NONE }); } sub _get_toxyproxy_addr { return $ENV{TOXYPROXY} || "localhost:8474"; } sub _check_toxyproxy_and_reset { my $ht = HTTP::Tiny->new(); my $addr = _get_toxyproxy_addr(); return $ht->get("http://$addr/version")->{success} } sub new_toxic { my ($name, $upstream, $toxic) = @_; my $port = 13000 + int(rand(2000)); my $listen = "127.0.0.1:$port"; note("creating new proxy '$name' listening on $listen on upstreaming to $upstream"); my $ht = HTTP::Tiny->new(); my $addr = _get_toxyproxy_addr(); $ht->delete("http://$addr/proxies/$name"); my $result = $ht->post("http://$addr/proxies", { content => encode_json({ name => $name, listen => $listen, upstream => $upstream, })}); $result->{success} or die "failed to create new proxy '$name' in toxyproxy: " . $result->{reason}; my $upstream_toxic_name = "upstream_toxic_$name"; $result = $ht->post("http://$addr/proxies/$name/toxics", { content => encode_json({ name => $upstream_toxic_name, stream => "upstream", %{ $toxic }, })}); $result->{success} or die "failed to create new toxic '$upstream_toxic_name': " . $result->{reason}; my $downstream_toxic_name = "downstream_toxic_$name"; $result = $ht->post("http://$addr/proxies/$name/toxics", { content => encode_json({ name => $downstream_toxic_name, stream => "downstream", %{ $toxic }, })}); $result->{success} or die "failed to create new toxic '$downstream_toxic_name': " . $result->{reason}; return $listen; } 1; libyahc-perl-0.035/t/cert/000077500000000000000000000000001346453102500152775ustar00rootroot00000000000000libyahc-perl-0.035/t/cert/server.crt000066400000000000000000000020761346453102500173240ustar00rootroot00000000000000-----BEGIN CERTIFICATE----- MIIC9DCCAdwCCQDsJMjBZqCxrjANBgkqhkiG9w0BAQUFADA8MQswCQYDVQQGEwJB VTESMBAGA1UECBMJU29tZVN0YXRlMRkwFwYDVQQKExBTb21lT3JnYW5pemF0aW9u MB4XDTE2MDcyNDE4MjkxNVoXDTI2MDgwMTE4MjkxNVowPDELMAkGA1UEBhMCQVUx EjAQBgNVBAgTCVNvbWVTdGF0ZTEZMBcGA1UEChMQU29tZU9yZ2FuaXphdGlvbjCC ASIwDQYJKoZIhvcNAQEBBQADggEPADCCAQoCggEBANE9deQRw2S/ZYhjehw4PR7A +z8g+lx5luuV/jO8zsoC5fftayRCvNNYxGjAFOc754iWFGz9vyvcECSmv1m8Fda8 pU7K29UgbpUbClb0/X9lIHmQpN8BPaVhxRorD1x21f1FMQzyv5Vr0uxmKMi2dXxJ Mg1ySCe1IPKnFSJfXK0+bRuDLvWAU6uqQ36Y2M9HbcE6s4D16qsN3080yaVbs4Ma ZxXySFUWKD9XtOhFIlskPll8fXkr6HZvHXVYbGDIBJr/4277M9C4jocreT1oeMJ1 +FJFdu1w7nqFL4iv6/yOXWqnenVve1iBSN5GiUXCsSSd6tcbul3W1Z7lBvTWolEC AwEAATANBgkqhkiG9w0BAQUFAAOCAQEAz+TzzfY8iuVOocygsskPByEMXaO0cgwO +18GjPDGJIwsUEish0b4D4B1hr8nSS/oRKpgOGvuHx1FT+xwcKBCT5o0alcYXs9C Wm99iUJTxZi0smUH6QdxBrpIghMe6zlG5fRDo+G9GhI67BQgo9iRCpUJMve22qJh hUg/4gQuyVRNg74ZhXhRNINVgrihpm08CLl5N6IRQvJY9lcgvKhvrGblgNvGxVhu bXCW6EvhBA5Rj5UoQ4d0wBXJAz1ZiN/uumoC2kq31snJ6Vn6fq/JxyYQM9N0HWwd JYDjjxKh/VYN664gX13pVnGwdLyXxZ57lgt1nzGDXZpgiC7sNoF9SA== -----END CERTIFICATE----- libyahc-perl-0.035/t/cert/server.key000066400000000000000000000032171346453102500173220ustar00rootroot00000000000000-----BEGIN RSA PRIVATE KEY----- MIIEpAIBAAKCAQEA0T115BHDZL9liGN6HDg9HsD7PyD6XHmW65X+M7zOygLl9+1r JEK801jEaMAU5zvniJYUbP2/K9wQJKa/WbwV1rylTsrb1SBulRsKVvT9f2UgeZCk 3wE9pWHFGisPXHbV/UUxDPK/lWvS7GYoyLZ1fEkyDXJIJ7Ug8qcVIl9crT5tG4Mu 9YBTq6pDfpjYz0dtwTqzgPXqqw3fTzTJpVuzgxpnFfJIVRYoP1e06EUiWyQ+WXx9 eSvodm8ddVhsYMgEmv/jbvsz0LiOhyt5PWh4wnX4UkV27XDueoUviK/r/I5daqd6 dW97WIFI3kaJRcKxJJ3q1xu6XdbVnuUG9NaiUQIDAQABAoIBADHry/jCFDAxSfQk Z7nb4Rk5SbhiEdmGWO+UNbX6Ugv4bQ2d43YfRhXWk+W6DkKtFCyOQglO8RFxy5gz AGxUZ5F4KKiH1bMfrcJ9VRYyFVkTs4/NZsid7ytKDFCV/XA+Ggf3PiCsufDYbNZh +VEJ1zXz8LEslvKCUH4URwKQZfgfAgsRB8Yy5tNcR7Xn17HwZrSX+YcGP26j9sR3 f7VpGRnbHrmpnhJ6/KsCFDkihzA1plpWFrSwh7XSiexDo6brk0HreTCyUEMB+dsk nH8gVjjSLAXE/KTJAsNLRdqMlqePaib/Lk8XKvNSIXL80YWyh/Ir535oSSuuZ5MB cO5GhBECgYEA+EyueQHOCxhNSArdAqJ/853fJXsqmFzLi7Uc0nxCGPavdhEIOv43 1aFH5RDeV2itvoNpTSMWZ+8HkbafUOwd/mLX+JsO//znKV8S5uPHLPUa6KaFu/oq 3z1dRAZhAm07X2Vk7ogdQ5dMr4gT9PeeHTWI/ntOMQuM++W5VkiCg7sCgYEA17qs 2KyYmD1jvi7pQqmZ83l/muACnsiJ4kwfn/qGA4vCXGjpZswDNR1DfvlpRq2eiYdq E6v0KUIDjAbNR43TLoliWU52XtUoFvGApBooHiMCkg/ulN8kJKYrHDQjic+quH8M oITn9bM9CNkCXtMFYLWVhKZ3B/q8RgVA2CsPg2MCgYEA6xWm5tinnOeQW9I1OAZk gGILYPBA/up0qLx8ImkVJ49/xpgPo9MHSBMf/6e96yInxcWjkC3VS+gK0ZIHOtWi /DPXaQBd7k4jCo+CVOp5rH4P0Q/AdJ5BswTlZb9oX6TN3t8f9ZsXoeQA7fw3cOp0 YBFMuCxEdrkJ7YCtvhx+vXsCgYBV3HKW+nrxfN2KAFnOsnoXsa/cEHR6hg57Bxk/ LxLPrnx5EzhyNZjBNxh6HQKNouSKkF7j3XicQy3uOXbSl9wJlZyTNutd6zC9kPlG VzLIa97GC5lFn1pfS9O0sfvDCehE7iw0ZzF7VQ9hyh1raEmnqB4OYcLWZjExHT4l y12tSQKBgQDYXoq9WmxGoZRTDs5lLIHkzAmvDbdLp0fYYcBj2rA/Q0tlIol5Ly/8 PAUqYL5O37trxg7TvWMlfZbcznwKiaYHi5E56FeS9GfVaQdbXpaYwzuPzURy32Vh UGzfoXZvnc/+aUFjHDO8UrvTBUEJazcf5EzyCLJKEMvZ9FLbXLMnnw== -----END RSA PRIVATE KEY-----