This is an automated email from the git hooks/post-receive script. dlintott-guest pushed a commit to branch master in repository libhttp-server-simple-perl.
commit 83a3b9d2088e2c5880a085ba230a24474cc55216 Author: Daniel Lintott <dan...@serverb.co.uk> Date: Fri May 30 17:08:43 2014 +0100 Imported Upstream version 0.45.02 --- Changes | 7 +++ META.yml | 9 ++-- SIGNATURE | 37 ++++++++------- inc/Module/Install.pm | 6 +-- inc/Module/Install/Base.pm | 2 +- inc/Module/Install/Can.pm | 85 ++++++++++++++++++++++++++++++--- inc/Module/Install/Fetch.pm | 2 +- inc/Module/Install/Makefile.pm | 27 ++++++----- inc/Module/Install/Metadata.pm | 29 +++++++----- inc/Module/Install/Win32.pm | 2 +- inc/Module/Install/WriteAll.pm | 2 +- lib/HTTP/Server/Simple.pm | 105 ++++++++++++++++++++++++++++++++--------- t/01live.t | 65 +++++++++++++++---------- t/04cgi.t | 50 ++++++++++++++++++-- 14 files changed, 320 insertions(+), 108 deletions(-) diff --git a/Changes b/Changes index f37ad7a..a0bc54a 100644 --- a/Changes +++ b/Changes @@ -1,3 +1,10 @@ +0.45_02 +* Support for IPv6 - Daniel Kahn Gillmor [rt.cpan.org #61200] + +0.45_01 Thu Sep 22 10:10:41 EST 2011 + +* Support full URIs as required by RFC2616 - penfold [rt.cpan.org #69445] + 0.44 Mon Apr 4 16:59:59 EST 2011 * Fix tests to run in a FreeBSD Jail - Tom Hukins [rt.cpan.org #49807] diff --git a/META.yml b/META.yml index 16ece41..39c3494 100644 --- a/META.yml +++ b/META.yml @@ -1,10 +1,11 @@ --- build_requires: - ExtUtils::MakeMaker: 6.42 + ExtUtils::MakeMaker: 6.36 configure_requires: - ExtUtils::MakeMaker: 6.42 + ExtUtils::MakeMaker: 6.36 distribution_type: module -generated_by: 'Module::Install version 1.00' +dynamic_config: 1 +generated_by: 'Module::Install version 1.06' license: perl meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html @@ -20,4 +21,4 @@ requires: Test::More: 0 resources: license: http://dev.perl.org/licenses/ -version: 0.44 +version: 0.45_02 diff --git a/SIGNATURE b/SIGNATURE index d0fd25d..fded70e 100644 --- a/SIGNATURE +++ b/SIGNATURE @@ -1,5 +1,5 @@ This file contains message digests of all files listed in MANIFEST, -signed via the Module::Signature module, version 0.66. +signed via the Module::Signature module, version 0.68. To verify the content in this distribution, first make sure you have Module::Signature installed, then type: @@ -14,34 +14,35 @@ not run its Makefile.PL or Build.PL. -----BEGIN PGP SIGNED MESSAGE----- Hash: SHA1 -SHA1 f0ed9096f048f9291c7cccb64caeea6ae50ea031 Changes +SHA1 8d52a0e9520b359eaf44350a3262b1da5196dbc2 Changes SHA1 949066363c947341783f1fe4c949f02940e8fa73 MANIFEST SHA1 e476d8bd724d46eb9e255cc8afc98b92269e2255 MANIFEST.SKIP -SHA1 8b7f1c4cb0cf0a362479450cd1598f4a3be7237d META.yml +SHA1 fdcd67b644ab2780716928e7f1baedf4054419eb META.yml SHA1 bedda9fb5cb7922f391c7f039bc7eb8297e2c999 Makefile.PL SHA1 ed0c107672daac3bc9e266876666e1059dbe44b7 README SHA1 4ea1e9072ca87399184a46233df52a21e285604d ex/sample_server -SHA1 7305dbe2904416e28decb05396988a5d51d578be inc/Module/Install.pm -SHA1 129960509127732258570c122042bc48615222e1 inc/Module/Install/Base.pm -SHA1 cf3356ed9a5bd2f732527ef9e7bc5ef4458c8a93 inc/Module/Install/Can.pm -SHA1 bf0a3e1977effc2832d7a813a76dce3f31b437b6 inc/Module/Install/Fetch.pm -SHA1 b721c93ca5bc9a6aa863b49af15f1b1de6125935 inc/Module/Install/Makefile.pm -SHA1 026cc0551a0ad399d195e395b46bdf842e115192 inc/Module/Install/Metadata.pm -SHA1 5457015ea5a50e93465bf2dafa29feebd547f85b inc/Module/Install/Win32.pm -SHA1 051e7fa8063908befa3440508d0584a2497b97db inc/Module/Install/WriteAll.pm -SHA1 5fc5e574334c74ff4351fd47dcf2e9475aef4049 lib/HTTP/Server/Simple.pm +SHA1 8a924add836b60fb23b25c8506d45945e02f42f4 inc/Module/Install.pm +SHA1 2d0fad3bf255f8c1e7e1e34eafccc4f595603ddc inc/Module/Install/Base.pm +SHA1 f0e01fff7d73cd145fbf22331579918d4628ddb0 inc/Module/Install/Can.pm +SHA1 7328966e4fda0c8451a6d3850704da0b84ac1540 inc/Module/Install/Fetch.pm +SHA1 b62ca5e2d58fa66766ccf4d64574f9e1a2250b34 inc/Module/Install/Makefile.pm +SHA1 1aa925be410bb3bfcd84a16985921f66073cc1d2 inc/Module/Install/Metadata.pm +SHA1 e4196994fa75e98bdfa2be0bdeeffef66de88171 inc/Module/Install/Win32.pm +SHA1 c3a6d0d5b84feb3280622e9599e86247d58b0d18 inc/Module/Install/WriteAll.pm +SHA1 4d4d80e475b7601e383dc89f3ce25ab25236c36d lib/HTTP/Server/Simple.pm SHA1 c84b60c7ebdcc12d1814909f957bf3b385fa60c2 lib/HTTP/Server/Simple/CGI.pm SHA1 d052d3acc92e7f35ece4d195ce8b09d8105f063e lib/HTTP/Server/Simple/CGI/Environment.pm SHA1 41afe2c04bb573b40e283e2b210ed70a47a3f8ba t/00signature.t SHA1 db064af54cab345a71daec576e32e64b8fb1033d t/00smoke.t -SHA1 7afffea07d161f377bedff4669ab92e121d28e81 t/01live.t +SHA1 b0d8698aa39df666fbefc9e299eac6c730d83c61 t/01live.t SHA1 aca95653cfce68912e08c57b3a4566207e2f99b3 t/02pod.t SHA1 a7024d0d8e7b80d26f75a3551a1406a797b382f8 t/03podcoverage.t -SHA1 27975aef6518de7ef5916ea2dfd3747f134db841 t/04cgi.t +SHA1 3eaba5195954b05f63d343886877cf3dddea4469 t/04cgi.t -----BEGIN PGP SIGNATURE----- -Version: GnuPG v1.4.10 (GNU/Linux) +Version: GnuPG v1.4.11 (Darwin) +Comment: GPGTools - http://gpgtools.org -iEYEARECAAYFAk2ZbQMACgkQEi9d9xCOQEbBwQCgyXuXE0LzWdmw1+YfOY6EhueS -/7cAmQHI9MZmMMI+dSYf7v7UKsH5IfDw -=YyKL +iEYEARECAAYFAk+5bPUACgkQEi9d9xCOQEbOkwCgyIt31k3x9v8jxxDJaYwjrjsA +02wAoMGj3osxssOOTE/9UviS6+poLUUY +=ksmj -----END PGP SIGNATURE----- diff --git a/inc/Module/Install.pm b/inc/Module/Install.pm index 8ee839d..4ecf46b 100644 --- a/inc/Module/Install.pm +++ b/inc/Module/Install.pm @@ -31,7 +31,7 @@ BEGIN { # 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.00'; + $VERSION = '1.06'; # Storage for the pseudo-singleton $MAIN = undef; @@ -451,7 +451,7 @@ sub _version ($) { } sub _cmp ($$) { - _version($_[0]) <=> _version($_[1]); + _version($_[1]) <=> _version($_[2]); } # Cloned from Params::Util::_CLASS @@ -467,4 +467,4 @@ sub _CLASS ($) { 1; -# Copyright 2008 - 2010 Adam Kennedy. +# Copyright 2008 - 2012 Adam Kennedy. diff --git a/inc/Module/Install/Base.pm b/inc/Module/Install/Base.pm index b55bda3..802844a 100644 --- a/inc/Module/Install/Base.pm +++ b/inc/Module/Install/Base.pm @@ -4,7 +4,7 @@ package Module::Install::Base; use strict 'vars'; use vars qw{$VERSION}; BEGIN { - $VERSION = '1.00'; + $VERSION = '1.06'; } # Suspend handler for "redefined" warnings diff --git a/inc/Module/Install/Can.pm b/inc/Module/Install/Can.pm index 71ccc27..22167b8 100644 --- a/inc/Module/Install/Can.pm +++ b/inc/Module/Install/Can.pm @@ -3,13 +3,12 @@ package Module::Install::Can; use strict; use Config (); -use File::Spec (); use ExtUtils::MakeMaker (); use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { - $VERSION = '1.00'; + $VERSION = '1.06'; @ISA = 'Module::Install::Base'; $ISCORE = 1; } @@ -29,7 +28,7 @@ sub can_use { eval { require $mod; $pkg->VERSION($ver || 0); 1 }; } -# check if we can run some command +# Check if we can run some command sub can_run { my ($self, $cmd) = @_; @@ -38,14 +37,88 @@ sub can_run { for my $dir ((split /$Config::Config{path_sep}/, $ENV{PATH}), '.') { next if $dir eq ''; - my $abs = File::Spec->catfile($dir, $_[1]); + require File::Spec; + my $abs = File::Spec->catfile($dir, $cmd); return $abs if (-x $abs or $abs = MM->maybe_command($abs)); } return; } -# can we locate a (the) C compiler +# 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; @@ -78,4 +151,4 @@ if ( $^O eq 'cygwin' ) { __END__ -#line 156 +#line 236 diff --git a/inc/Module/Install/Fetch.pm b/inc/Module/Install/Fetch.pm index ec1f106..bee0c4f 100644 --- a/inc/Module/Install/Fetch.pm +++ b/inc/Module/Install/Fetch.pm @@ -6,7 +6,7 @@ use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { - $VERSION = '1.00'; + $VERSION = '1.06'; @ISA = 'Module::Install::Base'; $ISCORE = 1; } diff --git a/inc/Module/Install/Makefile.pm b/inc/Module/Install/Makefile.pm index 5dfd0e9..7052f36 100644 --- a/inc/Module/Install/Makefile.pm +++ b/inc/Module/Install/Makefile.pm @@ -8,7 +8,7 @@ use Fcntl qw/:flock :seek/; use vars qw{$VERSION @ISA $ISCORE}; BEGIN { - $VERSION = '1.00'; + $VERSION = '1.06'; @ISA = 'Module::Install::Base'; $ISCORE = 1; } @@ -215,18 +215,22 @@ sub write { require ExtUtils::MakeMaker; if ( $perl_version and $self->_cmp($perl_version, '5.006') >= 0 ) { - # MakeMaker can complain about module versions that include - # an underscore, even though its own version may contain one! - # Hence the funny regexp to get rid of it. See RT #35800 - # for details. - my $v = $ExtUtils::MakeMaker::VERSION =~ /^(\d+\.\d+)/; - $self->build_requires( 'ExtUtils::MakeMaker' => $v ); - $self->configure_requires( 'ExtUtils::MakeMaker' => $v ); + # 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.42 ); - $self->configure_requires( 'ExtUtils::MakeMaker' => 6.42 ); + $self->build_requires( 'ExtUtils::MakeMaker' => 6.36 ); + $self->configure_requires( 'ExtUtils::MakeMaker' => 6.36 ); } # Generate the MakeMaker params @@ -241,7 +245,6 @@ in a module, and provide its file path via 'version_from' (or 'all_from' if you prefer) in Makefile.PL. EOT - $DB::single = 1; if ( $self->tests ) { my @tests = split ' ', $self->tests; my %seen; @@ -412,4 +415,4 @@ sub postamble { __END__ -#line 541 +#line 544 diff --git a/inc/Module/Install/Metadata.pm b/inc/Module/Install/Metadata.pm index cfe45b3..58430f3 100644 --- a/inc/Module/Install/Metadata.pm +++ b/inc/Module/Install/Metadata.pm @@ -6,7 +6,7 @@ use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { - $VERSION = '1.00'; + $VERSION = '1.06'; @ISA = 'Module::Install::Base'; $ISCORE = 1; } @@ -151,15 +151,21 @@ sub install_as_site { $_[0]->installdirs('site') } sub install_as_vendor { $_[0]->installdirs('vendor') } sub dynamic_config { - my $self = shift; - unless ( @_ ) { - warn "You MUST provide an explicit true/false value to dynamic_config\n"; - return $self; + 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} = $_[0] ? 1 : 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 @_; @@ -170,7 +176,7 @@ sub perl_version { # Normalize the version $version = $self->_perl_version($version); - # We don't support the reall old versions + # 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"; } @@ -515,6 +521,7 @@ sub __extract_license { '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, @@ -550,9 +557,9 @@ sub license_from { sub _extract_bugtracker { my @links = $_[0] =~ m#L<( - \Qhttp://rt.cpan.org/\E[^>]+| - \Qhttp://github.com/\E[\w_]+/[\w_]+/issues| - \Qhttp://code.google.com/p/\E[\w_\-]+/issues/list + 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}=(); @@ -581,7 +588,7 @@ sub bugtracker_from { sub requires_from { my $self = shift; my $content = Module::Install::_readperl($_[0]); - my @requires = $content =~ m/^use\s+([^\W\d]\w*(?:::\w+)*)\s+([\d\.]+)/mg; + my @requires = $content =~ m/^use\s+([^\W\d]\w*(?:::\w+)*)\s+(v?[\d\.]+)/mg; while ( @requires ) { my $module = shift @requires; my $version = shift @requires; diff --git a/inc/Module/Install/Win32.pm b/inc/Module/Install/Win32.pm index edc18b4..eeaa3fe 100644 --- a/inc/Module/Install/Win32.pm +++ b/inc/Module/Install/Win32.pm @@ -6,7 +6,7 @@ use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { - $VERSION = '1.00'; + $VERSION = '1.06'; @ISA = 'Module::Install::Base'; $ISCORE = 1; } diff --git a/inc/Module/Install/WriteAll.pm b/inc/Module/Install/WriteAll.pm index d0f6599..85d8018 100644 --- a/inc/Module/Install/WriteAll.pm +++ b/inc/Module/Install/WriteAll.pm @@ -6,7 +6,7 @@ use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { - $VERSION = '1.00'; + $VERSION = '1.06'; @ISA = qw{Module::Install::Base}; $ISCORE = 1; } diff --git a/lib/HTTP/Server/Simple.pm b/lib/HTTP/Server/Simple.pm old mode 100755 new mode 100644 index 50479ae..db7d6f6 --- a/lib/HTTP/Server/Simple.pm +++ b/lib/HTTP/Server/Simple.pm @@ -7,7 +7,7 @@ use Socket; use Carp; use vars qw($VERSION $bad_request_doc); -$VERSION = '0.44'; +$VERSION = '0.45_02'; =head1 NAME @@ -124,15 +124,17 @@ could kill the server. =head1 METHODS -=head2 HTTP::Server::Simple->new($port) +=head2 HTTP::Server::Simple->new($port, $family) API call to start a new server. Does not actually start listening -until you call C<-E<gt>run()>. If omitted, C<$port> defaults to 8080. +until you call C<-E<gt>run()>. If omitted, C<$port> defaults to 8080, +and C<$family> defaults to L<Socket::AF_INET>. +The alternative domain is L<Socket::AF_INET6>. =cut sub new { - my ( $proto, $port ) = @_; + my ( $proto, $port, $family ) = @_; my $class = ref($proto) || $proto; if ( $class eq __PACKAGE__ ) { @@ -143,6 +145,7 @@ sub new { my $self = {}; bless( $self, $class ); $self->port( $port || '8080' ); + $self->family( $family || AF_INET ); return $self; } @@ -151,7 +154,7 @@ sub new { =head2 lookup_localhost Looks up the local host's IP address, and returns it. For most hosts, -this is C<127.0.0.1>. +this is C<127.0.0.1>, or possibly C<::1>. =cut @@ -159,9 +162,14 @@ sub lookup_localhost { my $self = shift; my $local_sockaddr = getsockname( $self->stdio_handle ); - my ( undef, $localiaddr ) = sockaddr_in($local_sockaddr); - $self->host( gethostbyaddr( $localiaddr, AF_INET ) || "localhost"); - $self->{'local_addr'} = inet_ntoa($localiaddr) || "127.0.0.1"; + my $local_family = sockaddr_family($local_sockaddr); + my ( undef, $localiaddr ) = + ($local_family == AF_INET6) ? sockaddr_in6($local_sockaddr) + : sockaddr_in($local_sockaddr); + + $self->host( gethostbyaddr( $localiaddr, $local_family ) || "localhost"); + $self->{'local_addr'} = Socket::inet_ntop($local_family, $localiaddr) + || (($local_family == AF_INET6) ? "::1" : "127.0.0.1"); } @@ -180,6 +188,31 @@ sub port { } +=head2 family [NUMBER] + +Takes an optional address family for this server to use. Valid values +are Socket::AF_INET and Socket::AF_INET6. All other values are silently +changed into Socket::AF_INET for backwards compatibility with previous +versions of the module. + +Returns the address family of the present listening socket. (Defaults to +Socket::AF_INET.) + +=cut + +sub family { + my $self = shift; + if (@_) { + if ($_[0] == AF_INET || $_[0] == AF_INET6) { + $self->{'family'} = shift; + } else { + $self->{'family'} = AF_INET; + } + } + return ( $self->{'family'} ); + +} + =head2 host [address] Takes an optional host address for this server to bind to. @@ -359,8 +392,15 @@ sub _process_request { # ( http://dev.catalyst.perl.org/changeset/5195, 5221 ) my $remote_sockaddr = getpeername( $self->stdio_handle ); - my ( $iport, $iaddr ) = $remote_sockaddr ? sockaddr_in($remote_sockaddr) : (undef,undef); - my $peeraddr = $iaddr ? ( inet_ntoa($iaddr) || "127.0.0.1" ) : '127.0.0.1'; + my $family = sockaddr_family($remote_sockaddr); + + my ( $iport, $iaddr ) = $remote_sockaddr + ? ( ($family == AF_INET6) ? sockaddr_in6($remote_sockaddr) + : sockaddr_in($remote_sockaddr) ) + : (undef,undef); + + my $loopback = ($family == AF_INET6) ? "::1" : "127.0.0.1"; + my $peeraddr = $iaddr ? ( Socket::inet_ntop($family, $iaddr) || $loopback ) : $loopback; my ( $method, $request_uri, $proto ) = $self->parse_request; @@ -608,6 +648,9 @@ sub parse_request { my $uri = $2 || ''; my $protocol = $3 || ''; + # strip <scheme>://<host:port> out of HTTP/1.1 requests + $uri =~ s{^\w+://[^/]+/}{/}; + return ( $method, $uri, $protocol ); } @@ -650,18 +693,34 @@ sub setup_listener { my $self = shift; my $tcp = getprotobyname('tcp'); - socket( HTTPDaemon, PF_INET, SOCK_STREAM, $tcp ) or croak "socket: $!"; + my $sockaddr; + socket( HTTPDaemon, $self->{'family'}, SOCK_STREAM, $tcp ) + or croak "socket: $!"; setsockopt( HTTPDaemon, SOL_SOCKET, SO_REUSEADDR, pack( "l", 1 ) ) or warn "setsockopt: $!"; - bind( HTTPDaemon, - sockaddr_in( - $self->port(), - ( $self->host - ? inet_aton( $self->host ) - : INADDR_ANY - ) - ) - ) + + if ($self->host) { # Explicit listening address + my ($err, @res) = Socket::getaddrinfo($self->host, $self->port, { family => $self->{'family'}, socktype => SOCK_STREAM } ); + warn "$err!" + if ($err); + # we're binding only to the first returned address in the requested family. + while ($a = shift(@res)) { + # Be certain on the address family. + # TODO Accept AF_UNSPEC, reject SITE-LOCAL + next unless ($self->{'family'} == $a->{'family'}); + + # Use the first plausible address. + $sockaddr = $a->{'addr'}; + last; + } + } + else { # Use the wildcard address + $sockaddr = ($self->{'family'} == AF_INET6) + ? sockaddr_in6($self->port(), Socket::IN6ADDR_ANY) + : sockaddr_in($self->port(), INADDR_ANY); + } + + bind( HTTPDaemon, $sockaddr) or croak "bind to @{[$self->host||'*']}:@{[$self->port]}: $!"; listen( HTTPDaemon, SOMAXCONN ) or croak "listen: $!"; } @@ -698,15 +757,15 @@ sub bad_request { Given a candidate HTTP method in $method, determine if it is valid. Override if, for example, you'd like to do some WebDAV. The default -implementation only accepts C<GET>, C<POST>, C<HEAD>, C<PUT>, and -C<DELETE>. +implementation only accepts C<GET>, C<POST>, C<HEAD>, C<PUT>, C<PATCH> +and C<DELETE>. =cut sub valid_http_method { my $self = shift; my $method = shift or return 0; - return $method =~ /^(?:GET|POST|HEAD|PUT|DELETE)$/; + return $method =~ /^(?:GET|POST|HEAD|PUT|PATCH|DELETE)$/; } =head1 AUTHOR diff --git a/t/01live.t b/t/01live.t index 4d0587d..cd58b98 100644 --- a/t/01live.t +++ b/t/01live.t @@ -1,7 +1,7 @@ # -*- perl -*- use Socket; -use Test::More tests => 14; +use Test::More tests => 34; use strict; # This script assumes that `localhost' will resolve to a local IP @@ -31,33 +31,34 @@ my $DEBUG = 1 if @ARGV; my @pids = (); my @classes = (qw(HTTP::Server::Simple SlowServer)); for my $class (@classes) { - run_server_tests($class); + run_server_tests($class, AF_INET); + run_server_tests($class, AF_INET6); $PORT++; # don't reuse the port incase your bogus os doesn't release in time } - -{ - my $s=HTTP::Server::Simple::CGI->new($PORT); +for my $fam ( AF_INET, AF_INET6 ) { + my $s=HTTP::Server::Simple::CGI->new($PORT, $fam); + is($fam, $s->family(), 'family OK'); $s->host("localhost"); my $pid=$s->background(); diag("started server PID='$pid'") if ($ENV{'TEST_VERBOSE'}); like($pid, '/^-?\d+$/', 'pid is numeric'); select(undef,undef,undef,0.2); # wait a sec - my $content=fetch("GET / HTTP/1.1", ""); + my $content=fetch($fam, "GET / HTTP/1.1", ""); like($content, '/Congratulations/', "Returns a page"); eval { - like(fetch("GET a bogus request"), + like(fetch($fam, "GET a bogus request"), '/bad request/i', "knows what a request isn't"); }; fail("got exception in client: $@") if $@; - like(fetch("GET / HTTP/1.1", ""), '/Congratulations/', + like(fetch($fam, "GET / HTTP/1.1", ""), '/Congratulations/', "HTTP/1.1 request"); - like(fetch("GET /"), '/Congratulations/', + like(fetch($fam, "GET /"), '/Congratulations/', "HTTP/0.9 request"); is(kill(9,$pid),1,'Signaled 1 process successfully'); @@ -68,29 +69,43 @@ is( kill( 9, $_ ), 1, "Killed PID: $_" ) for @pids; # this function may look excessive, but hopefully will be very useful # in identifying common problems sub fetch { + my $family = shift; my $hostname = "localhost"; my $port = $PORT; my $message = join "", map { "$_\015\012" } @_; - my $timeout = 5; - my $response; - + my $timeout = 5; + my $response; + my $proto = getprotobyname('tcp') || die "getprotobyname: $!"; + my $socktype = SOCK_STREAM; + eval { local $SIG{ALRM} = sub { die "early exit - SIGALRM caught" }; alarm $timeout*2; #twice longer than timeout used later by select() - - my $iaddr = inet_aton($hostname) || die "inet_aton: $!"; - my $paddr = sockaddr_in($port, $iaddr) || die "sockaddr_in: $!"; - my $proto = getprotobyname('tcp') || die "getprotobyname: $!"; - socket(SOCK, PF_INET, SOCK_STREAM, $proto) || die "socket: $!"; + + my $paddr; + my ($err, @res) = Socket::getaddrinfo($hostname, $port, { family => $family, + socktype => $socktype, + protocol => $proto }); + die "getaddrinfo: $err" + if ($err); + while ($a = shift(@res)) { + next unless ($family == $a->{'family'}); + next unless ($proto == $a->{'protocol'}); + next unless ($socktype == $a->{'socktype'}); + + $paddr = $a->{'addr'}; + last + } + socket(SOCK, $family, $socktype, $proto) || die "socket: $!"; connect(SOCK, $paddr) || die "connect: $!"; (send SOCK, $message, 0) || die "send: $!"; - + my $rvec = ''; vec($rvec, fileno(SOCK), 1) = 1; - die "vec(): $!" unless $rvec; + die "vec(): $!" unless $rvec; $response = ''; - for (;;) { + for (;;) { my $r = select($rvec, undef, undef, $timeout); die "select: timeout - no data to read from server" unless ($r > 0); my $l = sysread(SOCK, $response, 1024, length($response)); @@ -100,18 +115,20 @@ sub fetch { $response =~ s/\015\012/\n/g; (close SOCK) || die "close(): $!"; alarm 0; - }; + }; if ($@) { return "[ERROR] $@"; } else { return $response; - } + } } sub run_server_tests { my $class = shift; - my $s = $class->new($PORT); + my $fam = shift; + my $s = $class->new($PORT, $fam); + is($s->family(), $fam, 'constructor set family properly'); is($s->port(),$PORT,"Constructor set port correctly"); my $pid=$s->background(); @@ -119,7 +136,7 @@ sub run_server_tests { like($pid, '/^-?\d+$/', 'pid is numeric'); - my $content=fetch("GET / HTTP/1.1", ""); + my $content=fetch($fam, "GET / HTTP/1.1", ""); like($content, '/Congratulations/', "Returns a page"); push @pids, $pid; diff --git a/t/04cgi.t b/t/04cgi.t index 1b6a5e1..619cf29 100644 --- a/t/04cgi.t +++ b/t/04cgi.t @@ -1,3 +1,5 @@ +# -*- perl -*- + use Test::More; use Socket; use strict; @@ -32,10 +34,10 @@ my %envvars=( if ($^O eq 'freebsd' && `sysctl -n security.jail.jailed` == 1) { delete @methods{qw(url server_name)}; delete @envvars{qw(SERVER_URL SERVER_NAME REMOTE_ADDR)}; - plan tests => 18; + plan tests => 55; } else { - plan tests => 23; + plan tests => 60; } { @@ -48,7 +50,19 @@ else { like($pid, '/^-?\d+$/', 'pid is numeric'); select(undef,undef,undef,0.2); # wait a sec - like(fetch("GET / HTTP/1.1",""), '/NOFILE/', 'no file'); + my @message_tests = ( + [["GET / HTTP/1.1",""], '/NOFILE/', '[GET] no file'], + [["POST / HTTP/1.1","Content-Length: 0",""], '/NOFILE/', '[POST] no file'], + [["HEAD / HTTP/1.1",""], '/NOFILE/', '[HEAD] no file'], + [["PUT / HTTP/1.1","Content-Length: 0",""], '/NOFILE/', '[PUT] no file'], + [["DELETE / HTTP/1.1",""], '/NOFILE/', '[DELETE] no file'], + [["PATCH / HTTP/1.1","Content-Length: 0",""], '/NOFILE/', '[PATCH] no file'], + ); + foreach my $message_test (@message_tests) { + my ($message, $expected, $description) = @$message_test; + like(fetch(@$message), $expected, $description); + select(undef,undef,undef,0.2); # wait a sec + } foreach my $method (keys(%methods)) { next unless defined $methods{$method}; @@ -69,6 +83,36 @@ else { select(undef,undef,undef,0.2); # wait a sec } +# extra tests for HTTP/1.1 absolute URLs + + foreach my $verb ('GET', 'HEAD') { + foreach my $method (keys(%methods)) { + next unless defined $methods{$method}; + + my $method_value = $methods{$method}; + $method_value =~ s/\bGET\b/$verb/; + + like( + fetch("$verb http://localhost/cgitest/$method HTTP/1.1",""), + "/$method_value/", + "method (absolute URL) - $method" + ); + select(undef,undef,undef,0.2); # wait a sec + } + + foreach my $envvar (keys(%envvars)) { + (my $envvar_value = $envvars{$envvar}); + $envvar_value =~ s/\bGET\b/$verb/; + + like( + fetch("$verb http://localhost/cgitest/$envvar HTTP/1.1",""), + "/$envvar_value/", + "Environment (absolute URL) - $envvar" + ); + select(undef,undef,undef,0.2); # wait a sec + } + } + like( fetch("GET /cgitest/REQUEST_URI?foo%3Fbar HTTP/1.0",""), qr/foo%3Fbar/, -- Alioth's /usr/local/bin/git-commit-notice on /srv/git.debian.org/git/pkg-perl/packages/libhttp-server-simple-perl.git _______________________________________________ Pkg-perl-cvs-commits mailing list Pkg-perl-cvs-commits@lists.alioth.debian.org http://lists.alioth.debian.org/cgi-bin/mailman/listinfo/pkg-perl-cvs-commits