summaryrefslogtreecommitdiff
path: root/systems/texlive/tlnet/tlpkg/tlperl/site/lib/Test
diff options
context:
space:
mode:
authorNorbert Preining <norbert@preining.info>2019-09-02 13:46:59 +0900
committerNorbert Preining <norbert@preining.info>2019-09-02 13:46:59 +0900
commite0c6872cf40896c7be36b11dcc744620f10adf1d (patch)
tree60335e10d2f4354b0674ec22d7b53f0f8abee672 /systems/texlive/tlnet/tlpkg/tlperl/site/lib/Test
Initial commit
Diffstat (limited to 'systems/texlive/tlnet/tlpkg/tlperl/site/lib/Test')
-rw-r--r--systems/texlive/tlnet/tlpkg/tlperl/site/lib/Test/Fatal.pm364
-rw-r--r--systems/texlive/tlnet/tlpkg/tlperl/site/lib/Test/Needs.pm315
-rw-r--r--systems/texlive/tlnet/tlpkg/tlperl/site/lib/Test/RequiresInternet.pm131
3 files changed, 810 insertions, 0 deletions
diff --git a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/Test/Fatal.pm b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/Test/Fatal.pm
new file mode 100644
index 0000000000..29aa6629fb
--- /dev/null
+++ b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/Test/Fatal.pm
@@ -0,0 +1,364 @@
+use strict;
+use warnings;
+package Test::Fatal;
+# ABSTRACT: incredibly simple helpers for testing code with exceptions
+$Test::Fatal::VERSION = '0.014';
+#pod =head1 SYNOPSIS
+#pod
+#pod use Test::More;
+#pod use Test::Fatal;
+#pod
+#pod use System::Under::Test qw(might_die);
+#pod
+#pod is(
+#pod exception { might_die; },
+#pod undef,
+#pod "the code lived",
+#pod );
+#pod
+#pod like(
+#pod exception { might_die; },
+#pod qr/turns out it died/,
+#pod "the code died as expected",
+#pod );
+#pod
+#pod isa_ok(
+#pod exception { might_die; },
+#pod 'Exception::Whatever',
+#pod 'the thrown exception',
+#pod );
+#pod
+#pod =head1 DESCRIPTION
+#pod
+#pod Test::Fatal is an alternative to the popular L<Test::Exception>. It does much
+#pod less, but should allow greater flexibility in testing exception-throwing code
+#pod with about the same amount of typing.
+#pod
+#pod It exports one routine by default: C<exception>.
+#pod
+#pod =cut
+
+use Carp ();
+use Try::Tiny 0.07;
+
+use Exporter 5.57 'import';
+
+our @EXPORT = qw(exception);
+our @EXPORT_OK = qw(exception success dies_ok lives_ok);
+
+#pod =func exception
+#pod
+#pod my $exception = exception { ... };
+#pod
+#pod C<exception> takes a bare block of code and returns the exception thrown by
+#pod that block. If no exception was thrown, it returns undef.
+#pod
+#pod B<Achtung!> If the block results in a I<false> exception, such as 0 or the
+#pod empty string, Test::Fatal itself will die. Since either of these cases
+#pod indicates a serious problem with the system under testing, this behavior is
+#pod considered a I<feature>. If you must test for these conditions, you should use
+#pod L<Try::Tiny>'s try/catch mechanism. (Try::Tiny is the underlying exception
+#pod handling system of Test::Fatal.)
+#pod
+#pod Note that there is no TAP assert being performed. In other words, no "ok" or
+#pod "not ok" line is emitted. It's up to you to use the rest of C<exception> in an
+#pod existing test like C<ok>, C<isa_ok>, C<is>, et cetera. Or you may wish to use
+#pod the C<dies_ok> and C<lives_ok> wrappers, which do provide TAP output.
+#pod
+#pod C<exception> does I<not> alter the stack presented to the called block, meaning
+#pod that if the exception returned has a stack trace, it will include some frames
+#pod between the code calling C<exception> and the thing throwing the exception.
+#pod This is considered a I<feature> because it avoids the occasionally twitchy
+#pod C<Sub::Uplevel> mechanism.
+#pod
+#pod B<Achtung!> This is not a great idea:
+#pod
+#pod sub exception_like(&$;$) {
+#pod my ($code, $pattern, $name) = @_;
+#pod like( &exception($code), $pattern, $name );
+#pod }
+#pod
+#pod exception_like(sub { }, qr/foo/, 'foo appears in the exception');
+#pod
+#pod If the code in the C<...> is going to throw a stack trace with the arguments to
+#pod each subroutine in its call stack (for example via C<Carp::confess>,
+#pod the test name, "foo appears in the exception" will itself be matched by the
+#pod regex. Instead, write this:
+#pod
+#pod like( exception { ... }, qr/foo/, 'foo appears in the exception' );
+#pod
+#pod B<Achtung>: One final bad idea:
+#pod
+#pod isnt( exception { ... }, undef, "my code died!");
+#pod
+#pod It's true that this tests that your code died, but you should really test that
+#pod it died I<for the right reason>. For example, if you make an unrelated mistake
+#pod in the block, like using the wrong dereference, your test will pass even though
+#pod the code to be tested isn't really run at all. If you're expecting an
+#pod inspectable exception with an identifier or class, test that. If you're
+#pod expecting a string exception, consider using C<like>.
+#pod
+#pod =cut
+
+our ($REAL_TBL, $REAL_CALCULATED_TBL) = (1, 1);
+
+sub exception (&) {
+ my $code = shift;
+
+ return try {
+ my $incremented = $Test::Builder::Level - $REAL_CALCULATED_TBL;
+ local $Test::Builder::Level = $REAL_CALCULATED_TBL;
+ if ($incremented) {
+ # each call to exception adds 5 stack frames
+ $Test::Builder::Level += 5;
+ for my $i (1..$incremented) {
+ # -2 because we want to see it from the perspective of the call to
+ # is() within the call to $code->()
+ my $caller = caller($Test::Builder::Level - 2);
+ if ($caller eq __PACKAGE__) {
+ # each call to exception adds 5 stack frames
+ $Test::Builder::Level = $Test::Builder::Level + 5;
+ }
+ else {
+ $Test::Builder::Level = $Test::Builder::Level + 1;
+ }
+ }
+ }
+
+ local $REAL_CALCULATED_TBL = $Test::Builder::Level;
+ $code->();
+ return undef;
+ } catch {
+ return $_ if $_;
+
+ my $problem = defined $_ ? 'false' : 'undef';
+ Carp::confess("$problem exception caught by Test::Fatal::exception");
+ };
+}
+
+#pod =func success
+#pod
+#pod try {
+#pod should_live;
+#pod } catch {
+#pod fail("boo, we died");
+#pod } success {
+#pod pass("hooray, we lived");
+#pod };
+#pod
+#pod C<success>, exported only by request, is a L<Try::Tiny> helper with semantics
+#pod identical to L<C<finally>|Try::Tiny/finally>, but the body of the block will
+#pod only be run if the C<try> block ran without error.
+#pod
+#pod Although almost any needed exception tests can be performed with C<exception>,
+#pod success blocks may sometimes help organize complex testing.
+#pod
+#pod =cut
+
+sub success (&;@) {
+ my $code = shift;
+ return finally( sub {
+ return if @_; # <-- only run on success
+ $code->();
+ }, @_ );
+}
+
+#pod =func dies_ok
+#pod
+#pod =func lives_ok
+#pod
+#pod Exported only by request, these two functions run a given block of code, and
+#pod provide TAP output indicating if it did, or did not throw an exception.
+#pod These provide an easy upgrade path for replacing existing unit tests based on
+#pod C<Test::Exception>.
+#pod
+#pod RJBS does not suggest using this except as a convenience while porting tests to
+#pod use Test::Fatal's C<exception> routine.
+#pod
+#pod use Test::More tests => 2;
+#pod use Test::Fatal qw(dies_ok lives_ok);
+#pod
+#pod dies_ok { die "I failed" } 'code that fails';
+#pod
+#pod lives_ok { return "I'm still alive" } 'code that does not fail';
+#pod
+#pod =cut
+
+my $Tester;
+
+# Signature should match that of Test::Exception
+sub dies_ok (&;$) {
+ my $code = shift;
+ my $name = shift;
+
+ require Test::Builder;
+ $Tester ||= Test::Builder->new;
+
+ my $ok = $Tester->ok( exception( \&$code ), $name );
+ $ok or $Tester->diag( "expected an exception but none was raised" );
+ return $ok;
+}
+
+sub lives_ok (&;$) {
+ my $code = shift;
+ my $name = shift;
+
+ require Test::Builder;
+ $Tester ||= Test::Builder->new;
+
+ my $ok = $Tester->ok( !exception( \&$code ), $name );
+ $ok or $Tester->diag( "expected return but an exception was raised" );
+ return $ok;
+}
+
+1;
+
+__END__
+
+=pod
+
+=encoding UTF-8
+
+=head1 NAME
+
+Test::Fatal - incredibly simple helpers for testing code with exceptions
+
+=head1 VERSION
+
+version 0.014
+
+=head1 SYNOPSIS
+
+ use Test::More;
+ use Test::Fatal;
+
+ use System::Under::Test qw(might_die);
+
+ is(
+ exception { might_die; },
+ undef,
+ "the code lived",
+ );
+
+ like(
+ exception { might_die; },
+ qr/turns out it died/,
+ "the code died as expected",
+ );
+
+ isa_ok(
+ exception { might_die; },
+ 'Exception::Whatever',
+ 'the thrown exception',
+ );
+
+=head1 DESCRIPTION
+
+Test::Fatal is an alternative to the popular L<Test::Exception>. It does much
+less, but should allow greater flexibility in testing exception-throwing code
+with about the same amount of typing.
+
+It exports one routine by default: C<exception>.
+
+=head1 FUNCTIONS
+
+=head2 exception
+
+ my $exception = exception { ... };
+
+C<exception> takes a bare block of code and returns the exception thrown by
+that block. If no exception was thrown, it returns undef.
+
+B<Achtung!> If the block results in a I<false> exception, such as 0 or the
+empty string, Test::Fatal itself will die. Since either of these cases
+indicates a serious problem with the system under testing, this behavior is
+considered a I<feature>. If you must test for these conditions, you should use
+L<Try::Tiny>'s try/catch mechanism. (Try::Tiny is the underlying exception
+handling system of Test::Fatal.)
+
+Note that there is no TAP assert being performed. In other words, no "ok" or
+"not ok" line is emitted. It's up to you to use the rest of C<exception> in an
+existing test like C<ok>, C<isa_ok>, C<is>, et cetera. Or you may wish to use
+the C<dies_ok> and C<lives_ok> wrappers, which do provide TAP output.
+
+C<exception> does I<not> alter the stack presented to the called block, meaning
+that if the exception returned has a stack trace, it will include some frames
+between the code calling C<exception> and the thing throwing the exception.
+This is considered a I<feature> because it avoids the occasionally twitchy
+C<Sub::Uplevel> mechanism.
+
+B<Achtung!> This is not a great idea:
+
+ sub exception_like(&$;$) {
+ my ($code, $pattern, $name) = @_;
+ like( &exception($code), $pattern, $name );
+ }
+
+ exception_like(sub { }, qr/foo/, 'foo appears in the exception');
+
+If the code in the C<...> is going to throw a stack trace with the arguments to
+each subroutine in its call stack (for example via C<Carp::confess>,
+the test name, "foo appears in the exception" will itself be matched by the
+regex. Instead, write this:
+
+ like( exception { ... }, qr/foo/, 'foo appears in the exception' );
+
+B<Achtung>: One final bad idea:
+
+ isnt( exception { ... }, undef, "my code died!");
+
+It's true that this tests that your code died, but you should really test that
+it died I<for the right reason>. For example, if you make an unrelated mistake
+in the block, like using the wrong dereference, your test will pass even though
+the code to be tested isn't really run at all. If you're expecting an
+inspectable exception with an identifier or class, test that. If you're
+expecting a string exception, consider using C<like>.
+
+=head2 success
+
+ try {
+ should_live;
+ } catch {
+ fail("boo, we died");
+ } success {
+ pass("hooray, we lived");
+ };
+
+C<success>, exported only by request, is a L<Try::Tiny> helper with semantics
+identical to L<C<finally>|Try::Tiny/finally>, but the body of the block will
+only be run if the C<try> block ran without error.
+
+Although almost any needed exception tests can be performed with C<exception>,
+success blocks may sometimes help organize complex testing.
+
+=head2 dies_ok
+
+=head2 lives_ok
+
+Exported only by request, these two functions run a given block of code, and
+provide TAP output indicating if it did, or did not throw an exception.
+These provide an easy upgrade path for replacing existing unit tests based on
+C<Test::Exception>.
+
+RJBS does not suggest using this except as a convenience while porting tests to
+use Test::Fatal's C<exception> routine.
+
+ use Test::More tests => 2;
+ use Test::Fatal qw(dies_ok lives_ok);
+
+ dies_ok { die "I failed" } 'code that fails';
+
+ lives_ok { return "I'm still alive" } 'code that does not fail';
+
+=head1 AUTHOR
+
+Ricardo Signes <rjbs@cpan.org>
+
+=head1 COPYRIGHT AND LICENSE
+
+This software is copyright (c) 2010 by Ricardo Signes.
+
+This is free software; you can redistribute it and/or modify it under
+the same terms as the Perl 5 programming language system itself.
+
+=cut
diff --git a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/Test/Needs.pm b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/Test/Needs.pm
new file mode 100644
index 0000000000..f3db264d31
--- /dev/null
+++ b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/Test/Needs.pm
@@ -0,0 +1,315 @@
+package Test::Needs;
+use strict;
+use warnings;
+no warnings 'once';
+our $VERSION = '0.002005';
+$VERSION =~ tr/_//d;
+
+BEGIN {
+ *_WORK_AROUND_HINT_LEAKAGE
+ = "$]" < 5.011 && !("$]" >= 5.009004 && "$]" < 5.010001)
+ ? sub(){1} : sub(){0};
+ *_WORK_AROUND_BROKEN_MODULE_STATE
+ = "$]" < 5.009
+ ? sub(){1} : sub(){0};
+}
+
+sub _try_require {
+ local %^H
+ if _WORK_AROUND_HINT_LEAKAGE;
+ my ($module) = @_;
+ (my $file = "$module.pm") =~ s{::|'}{/}g;
+ my $err;
+ {
+ local $@;
+ eval { require $file }
+ or $err = $@;
+ }
+ if (defined $err) {
+ delete $INC{$file}
+ if _WORK_AROUND_BROKEN_MODULE_STATE;
+ die $err
+ unless $err =~ /\ACan't locate \Q$file\E/;
+ return !1;
+ }
+ !0;
+}
+
+sub _find_missing {
+ my @bad = map {
+ my ($module, $version) = @$_;
+ if ($module eq 'perl') {
+ $version
+ = !$version ? 0
+ : $version =~ /^[0-9]+\.[0-9]+$/ ? sprintf('%.6f', $version)
+ : $version =~ /^v?([0-9]+(?:\.[0-9]+)+)$/ ? do {
+ my @p = split /\./, $1;
+ push @p, 0
+ until @p >= 3;
+ sprintf '%d.%03d%03d', @p;
+ }
+ : $version =~ /^\x05..?$/s ? do {
+ my @p = map ord, split //, $version;
+ push @p, 0
+ until @p >= 3;
+ sprintf '%d.%03d%03d', @p;
+ }
+ : do {
+ use warnings FATAL => 'numeric';
+ no warnings 'void';
+ eval { 0 + $version; 1 } ? $version
+ : die sprintf qq{version "%s" for perl does not look like a number at %s line %s.\n},
+ $version, (caller( 1 + ($Test::Builder::Level||0) ))[1,2];
+ };
+ if ("$]" < $version) {
+ sprintf "perl %s (have %.6f)", $version, $];
+ }
+ else {
+ ();
+ }
+ }
+ elsif ($module =~ /^\d|[^\w:]|:::|[^:]:[^:]|^:|:$/) {
+ die sprintf qq{"%s" does not look like a module name at %s line %s.\n},
+ $module, (caller( 1 + ($Test::Builder::Level||0) ))[1,2];
+ die
+ }
+ elsif (_try_require($module)) {
+ local $@;
+ if (defined $version && !eval { $module->VERSION($version); 1 }) {
+ "$module $version (have ".$module->VERSION.')';
+ }
+ else {
+ ();
+ }
+ }
+ else {
+ $version ? "$module $version" : $module;
+ }
+ }
+ map {
+ if (ref eq 'HASH') {
+ my $arg = $_;
+ map [ $_ => $arg->{$_} ], sort keys %$arg;
+ }
+ elsif (ref eq 'ARRAY') {
+ my $arg = $_;
+ map [ @{$arg}[$_*2,$_*2+1] ], 0 .. int($#$arg / 2);
+ }
+ else {
+ [ $_ => undef ];
+ }
+ } @_;
+ @bad ? "Need " . join(', ', @bad) : undef;
+}
+
+sub import {
+ my $class = shift;
+ my $target = caller;
+ if (@_) {
+ local $Test::Builder::Level = ($Test::Builder::Level||0) + 1;
+ test_needs(@_);
+ }
+ no strict 'refs';
+ *{"${target}::test_needs"} = \&test_needs;
+}
+
+sub test_needs {
+ my $missing = _find_missing(@_);
+ local $Test::Builder::Level = ($Test::Builder::Level||0) + 1;
+ _fail_or_skip($missing, $ENV{RELEASE_TESTING})
+ if $missing;
+}
+
+sub _skip { _fail_or_skip($_[0], 0) }
+sub _fail { _fail_or_skip($_[0], 1) }
+
+sub _fail_or_skip {
+ my ($message, $fail) = @_;
+ if ($INC{'Test2/API.pm'}) {
+ my $ctx = Test2::API::context();
+ my $hub = $ctx->hub;
+ if ($fail) {
+ $ctx->ok(0, "Test::Needs modules available", [$message]);
+ }
+ else {
+ my $plan = $hub->plan;
+ my $tests = $hub->count;
+ if ($plan || $tests) {
+ my $skips
+ = $plan && $plan ne 'NO PLAN' ? $plan - $tests : 1;
+ $ctx->skip("Test::Needs modules not available") for 1 .. $skips;
+ $ctx->note($message);
+ }
+ else {
+ $ctx->plan(0, 'SKIP', $message);
+ }
+ }
+ $ctx->done_testing;
+ $ctx->release if $Test2::API::VERSION < 1.302053;
+ $ctx->send_event('+'._t2_terminate_event());
+ }
+ elsif ($INC{'Test/Builder.pm'}) {
+ my $tb = Test::Builder->new;
+ my $has_plan = Test::Builder->can('has_plan') ? 'has_plan'
+ : sub { $_[0]->expected_tests || eval { $_[0]->current_test($_[0]->current_test); 'no_plan' } };
+ if ($fail) {
+ $tb->plan(tests => 1)
+ unless $tb->$has_plan;
+ $tb->ok(0, "Test::Needs modules available");
+ $tb->diag($message);
+ }
+ else {
+ my $plan = $tb->$has_plan;
+ my $tests = $tb->current_test;
+ if ($plan || $tests) {
+ my $skips
+ = $plan && $plan ne 'no_plan' ? $plan - $tests : 1;
+ $tb->skip("Test::Needs modules not available")
+ for 1 .. $skips;
+ Test::Builer->can('note') ? $tb->note($message) : print "# $message\n";
+ }
+ else {
+ $tb->skip_all($message);
+ }
+ }
+ $tb->done_testing
+ if Test::Builder->can('done_testing');
+ die bless {} => 'Test::Builder::Exception'
+ if Test::Builder->can('parent') && $tb->parent;
+ }
+ else {
+ if ($fail) {
+ print "1..1\n";
+ print "not ok 1 - Test::Needs modules available\n";
+ print STDERR "# $message\n";
+ exit 1;
+ }
+ else {
+ print "1..0 # SKIP $message\n";
+ }
+ }
+ exit 0;
+}
+
+my $terminate_event;
+sub _t2_terminate_event () {
+ local $@;
+ $terminate_event ||= eval q{
+ $INC{'Test/Needs/Event/Terminate.pm'} = $INC{'Test/Needs.pm'};
+ package # hide
+ Test::Needs::Event::Terminate;
+ use Test2::Event ();
+ our @ISA = qw(Test2::Event);
+ sub no_display { 1 }
+ sub terminate { 0 }
+ __PACKAGE__;
+ } or die "$@";
+}
+
+1;
+__END__
+
+=pod
+
+=encoding utf-8
+
+=head1 NAME
+
+Test::Needs - Skip tests when modules not available
+
+=head1 SYNOPSIS
+
+ # need one module
+ use Test::Needs 'Some::Module';
+
+ # need multiple modules
+ use Test::Needs 'Some::Module', 'Some::Other::Module';
+
+ # need a given version of a module
+ use Test::Needs {
+ 'Some::Module' => '1.005',
+ };
+
+ # check later
+ use Test::Needs;
+ test_needs 'Some::Module';
+
+ # skips remainder of subtest
+ use Test::More;
+ use Test::Needs;
+ subtest 'my subtest' => sub {
+ test_needs 'Some::Module';
+ ...
+ };
+
+ # check perl version
+ use Test::Needs { perl => 5.020 };
+
+=head1 DESCRIPTION
+
+Skip test scripts if modules are not available. The requested modules will be
+loaded, and optionally have their versions checked. If the module is missing,
+the test script will be skipped. Modules that are found but fail to compile
+will exit with an error rather than skip.
+
+If used in a subtest, the remainder of the subtest will be skipped.
+
+Skipping will work even if some tests have already been run, or if a plan has
+been declared.
+
+Versions are checked via a C<< $module->VERSION($wanted_version) >> call.
+Versions must be provided in a format that will be accepted. No extra
+processing is done on them.
+
+If C<perl> is used as a module, the version is checked against the running perl
+version (L<$]|perlvar/$]>). The version can be specified as a number,
+dotted-decimal string, v-string, or version object.
+
+If the C<RELEASE_TESTING> environment variable is set, the tests will fail
+rather than skip. Subtests will be aborted, but the test script will continue
+running after that point.
+
+=head1 EXPORTS
+
+=head2 test_needs
+
+Has the same interface as when using Test::Needs in a C<use>.
+
+=head1 SEE ALSO
+
+=over 4
+
+=item L<Test::Requires>
+
+A similar module, with some important differences. L<Test::Requires> will act
+as a C<use> statement (despite its name), calling the import sub. Under
+C<RELEASE_TESTING>, it will BAIL_OUT if a module fails to load rather than
+using a normal test fail. It also doesn't distinguish between missing modules
+and broken modules.
+
+=item L<Test2::Require::Module>
+
+Part of the L<Test2> ecosystem. Only supports running as a C<use> command to
+skip an entire plan.
+
+=back
+
+=head1 AUTHOR
+
+haarg - Graham Knop (cpan:HAARG) <haarg@haarg.org>
+
+=head1 CONTRIBUTORS
+
+None so far.
+
+=head1 COPYRIGHT
+
+Copyright (c) 2016 the Test::Needs L</AUTHOR> and L</CONTRIBUTORS>
+as listed above.
+
+=head1 LICENSE
+
+This library is free software and may be distributed under the same terms
+as perl itself. See L<http://dev.perl.org/licenses/>.
+
+=cut
diff --git a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/Test/RequiresInternet.pm b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/Test/RequiresInternet.pm
new file mode 100644
index 0000000000..e78ca0bc6d
--- /dev/null
+++ b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/Test/RequiresInternet.pm
@@ -0,0 +1,131 @@
+use strict;
+use warnings;
+package Test::RequiresInternet;
+$Test::RequiresInternet::VERSION = '0.05';
+# ABSTRACT: Easily test network connectivity
+
+
+use Socket;
+
+sub import {
+ skip_all("NO_NETWORK_TESTING") if env("NO_NETWORK_TESTING");
+
+ my $namespace = shift;
+
+ my $argc = scalar @_;
+ if ( $argc == 0 ) {
+ push @_, 'www.google.com', 80;
+ }
+ elsif ( $argc % 2 != 0 ) {
+ die "Must supply server and a port pairs. You supplied " . (join ", ", @_) . "\n";
+ }
+
+ while ( @_ ) {
+ my $host = shift;
+ my $port = shift;
+
+ local $@;
+
+ eval {make_socket($host, $port)};
+
+ if ( $@ ) {
+ skip_all("$@");
+ }
+ }
+}
+
+sub make_socket {
+ my ($host, $port) = @_;
+
+ my $portnum;
+ if ($port =~ /\D/) {
+ $portnum = getservbyname($port, "tcp");
+ }
+ else {
+ $portnum = $port;
+ }
+
+ die "Could not find a port number for $port\n" if not $portnum;
+
+ my $iaddr = inet_aton($host) or die "no host: $host\n";
+
+ my $paddr = sockaddr_in($portnum, $iaddr);
+ my $proto = getprotobyname("tcp");
+
+ socket(my $sock, PF_INET, SOCK_STREAM, $proto) or die "socket: $!\n";
+ connect($sock, $paddr) or die "connect: $!\n";
+ close ($sock) or die "close: $!\n";
+
+ 1;
+}
+
+sub env {
+ exists $ENV{$_[0]} && $ENV{$_[0]} eq '1'
+}
+
+sub skip_all {
+ my $reason = shift;
+ print "1..0 # Skipped: $reason";
+ exit 0;
+}
+
+1;
+
+__END__
+
+=pod
+
+=encoding UTF-8
+
+=head1 NAME
+
+Test::RequiresInternet - Easily test network connectivity
+
+=head1 VERSION
+
+version 0.05
+
+=head1 SYNOPSIS
+
+ use Test::More;
+ use Test::RequiresInternet ('www.example.com' => 80, 'foobar.io' => 25);
+
+ # if you reach here, sockets successfully connected to hosts/ports above
+ plan tests => 1;
+
+ ok(do_that_internet_thing());
+
+=head1 OVERVIEW
+
+This module is intended to easily test network connectivity before functional
+tests begin to non-local Internet resources. It does not require any modules
+beyond those supplied in core Perl.
+
+If you do not specify a host/port pair, then the module defaults to using
+C<www.google.com> on port C<80>.
+
+You may optionally specify the port by its name, as in C<http> or C<ldap>.
+If you do this, the test module will attempt to look up the port number
+using C<getservbyname>.
+
+If you do specify a host and port, they must be specified in B<pairs>. It is a
+fatal error to omit one or the other.
+
+If the environment variable C<NO_NETWORK_TESTING> is set, then the tests
+will be skipped without attempting any socket connections.
+
+If the sockets cannot connect to the specified hosts and ports, the exception
+is caught, reported and the tests skipped.
+
+=head1 AUTHOR
+
+Mark Allen <mrallen1@yahoo.com>
+
+=head1 COPYRIGHT AND LICENSE
+
+This software is copyright (c) 2014 by Mark Allen.
+
+This is free software; you can redistribute it and/or modify it under
+the same terms as the Perl 5 programming language system itself.
+
+=cut