diff options
Diffstat (limited to 'Master/tlpkg/tlperl/site/lib/Test')
| -rw-r--r-- | Master/tlpkg/tlperl/site/lib/Test/Fatal.pm | 364 | ||||
| -rw-r--r-- | Master/tlpkg/tlperl/site/lib/Test/RequiresInternet.pm | 131 |
2 files changed, 495 insertions, 0 deletions
diff --git a/Master/tlpkg/tlperl/site/lib/Test/Fatal.pm b/Master/tlpkg/tlperl/site/lib/Test/Fatal.pm new file mode 100644 index 00000000000..29aa6629fb3 --- /dev/null +++ b/Master/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/Master/tlpkg/tlperl/site/lib/Test/RequiresInternet.pm b/Master/tlpkg/tlperl/site/lib/Test/RequiresInternet.pm new file mode 100644 index 00000000000..e78ca0bc6dc --- /dev/null +++ b/Master/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 |