From e0c6872cf40896c7be36b11dcc744620f10adf1d Mon Sep 17 00:00:00 2001 From: Norbert Preining Date: Mon, 2 Sep 2019 13:46:59 +0900 Subject: Initial commit --- .../tlnet/tlpkg/tlperl/site/lib/Test/Fatal.pm | 364 +++++++++++++++++++++ .../tlnet/tlpkg/tlperl/site/lib/Test/Needs.pm | 315 ++++++++++++++++++ .../tlpkg/tlperl/site/lib/Test/RequiresInternet.pm | 131 ++++++++ 3 files changed, 810 insertions(+) create mode 100644 systems/texlive/tlnet/tlpkg/tlperl/site/lib/Test/Fatal.pm create mode 100644 systems/texlive/tlnet/tlpkg/tlperl/site/lib/Test/Needs.pm create mode 100644 systems/texlive/tlnet/tlpkg/tlperl/site/lib/Test/RequiresInternet.pm (limited to 'systems/texlive/tlnet/tlpkg/tlperl/site/lib/Test') 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. 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. +#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 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 If the block results in a I 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. If you must test for these conditions, you should use +#pod L'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 in an +#pod existing test like C, C, C, et cetera. Or you may wish to use +#pod the C and C wrappers, which do provide TAP output. +#pod +#pod C does I 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 and the thing throwing the exception. +#pod This is considered a I because it avoids the occasionally twitchy +#pod C mechanism. +#pod +#pod B 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, +#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: 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 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. +#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, exported only by request, is a L helper with semantics +#pod identical to L|Try::Tiny/finally>, but the body of the block will +#pod only be run if the C block ran without error. +#pod +#pod Although almost any needed exception tests can be performed with C, +#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. +#pod +#pod RJBS does not suggest using this except as a convenience while porting tests to +#pod use Test::Fatal's C 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. 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. + +=head1 FUNCTIONS + +=head2 exception + + my $exception = exception { ... }; + +C takes a bare block of code and returns the exception thrown by +that block. If no exception was thrown, it returns undef. + +B If the block results in a I 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. If you must test for these conditions, you should use +L'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 in an +existing test like C, C, C, et cetera. Or you may wish to use +the C and C wrappers, which do provide TAP output. + +C does I 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 and the thing throwing the exception. +This is considered a I because it avoids the occasionally twitchy +C mechanism. + +B 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, +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: 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 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. + +=head2 success + + try { + should_live; + } catch { + fail("boo, we died"); + } success { + pass("hooray, we lived"); + }; + +C, exported only by request, is a L helper with semantics +identical to L|Try::Tiny/finally>, but the body of the block will +only be run if the C block ran without error. + +Although almost any needed exception tests can be performed with C, +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. + +RJBS does not suggest using this except as a convenience while porting tests to +use Test::Fatal's C 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 + +=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 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 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. + +=head1 SEE ALSO + +=over 4 + +=item L + +A similar module, with some important differences. L will act +as a C statement (despite its name), calling the import sub. Under +C, 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 + +Part of the L ecosystem. Only supports running as a C command to +skip an entire plan. + +=back + +=head1 AUTHOR + +haarg - Graham Knop (cpan:HAARG) + +=head1 CONTRIBUTORS + +None so far. + +=head1 COPYRIGHT + +Copyright (c) 2016 the Test::Needs L and L +as listed above. + +=head1 LICENSE + +This library is free software and may be distributed under the same terms +as perl itself. See L. + +=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 on port C<80>. + +You may optionally specify the port by its name, as in C or C. +If you do this, the test module will attempt to look up the port number +using C. + +If you do specify a host and port, they must be specified in B. It is a +fatal error to omit one or the other. + +If the environment variable C 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 + +=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 -- cgit v1.2.3